Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -19,49 +19,54 @@
 # rm <files>.o ; make install CSCOPTS='-profile' ; ... ;  chicken-profile | less
 SHELL=/bin/bash
 PREFIX=$(PWD)
 CSCOPTS=
 INSTALL=install
-SRCFILES = common.scm items.scm launch.scm ods.scm runconfig.scm	\
-           server.scm configf.scm db.scm keys.scm margs.scm		\
+SRCFILES = common.scm items.scm launch.scm runconfig.scm	\
+           server.scm configf.scm db.scm margs.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 = 
+MSRCFILES = dbmod.scm servermod.scm apimod.scm commonmod.scm rmtmod.scm ods.scm configfmod.scm
+MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o))
+MOIMPFILES = $(MSRCFILES:%.scm=%.import.o)
 # ftail.scm rmtmod.scm commonmod.scm removed
 # MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm	\
 #             mtargs.scm commonmod.scm dbmod.scm adjutant.scm ulex.scm	\
 #             rmtmod.scm apimod.scm
 
+DMSRCFILES = dcommonmod.scm
+DMOFILES = $(addprefix mofiles/,$(DMSRCFILES:%.scm=%.o))
+DMOIMPFILES = $(DMSRCFILES:%.scm=%.import.o)
+
 GUISRCF = dashboard-context-menu.scm dashboard-tests.scm		\
           dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm	\
           vg.scm
 
 OFILES   = $(SRCFILES:%.scm=%.o)
 GOFILES  = $(GUISRCF:%.scm=%.o)
 
-MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o))
-# compiled import files
-MOIMPFILES = $(MSRCFILES:%.scm=%.import.o)
 
-%.import.o : %.import.scm
+%.import.o : %.import.scm mofiles/%.o
 	csc $(CSCOPTS) -unit $*.import -c $*.import.scm -o $*.import.o
 
 # I'm not sure the cp is a good idea, changed a lot of things and it may not have been necessary...
 # mofiles/%.o  %.import.scm : %.scm megatest-fossil-hash.scm
 #	@[ -e mofiles ] || mkdir -p mofiles
 #	csc $(CSCOPTS) -I mofiles -I $* -J -c $< -o $*.o
 #	cp $*.o mofiles/$*.o
-#	@touch $*.import.scm # ensure it is touched after the .o is made
 
-mofiles/%.o : %.scm
-	mkdir -p mofiles
+
+# ensure import.scm is touched after the .o is made
+#
+mofiles/%.o %.import.scm : %.scm
 	csc $(CSCOPTS) -J -c $< -o mofiles/$*.o
+	@touch $*.import.scm
 
 ADTLSCR=mt_laststep mt_runstep mt_ezstep
 HELPERS=$(addprefix $(PREFIX)/bin/,$(ADTLSCR))
 DEPLOYHELPERS=$(addprefix deploytarg/,$(ADTLSCR))
 MTESTHASH=$(shell fossil info|grep checkout:| awk '{print $$2}')
@@ -74,11 +79,10 @@
 # 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)
 
 # all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut ndboard
 all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut tcmt
@@ -87,12 +91,13 @@
 	csc $(CSCOPTS) $(OFILES) $(MOFILES) $(MOIMPFILES) megatest.o -o mtest
 
 showmtesthash:
 	@echo $(MTESTHASH)
 
-dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES) $(MOIMPFILES) megatest-version.scm megatest-fossil-hash.scm
-	csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) $(MOIMPFILES) -o dboard
+# dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES) $(MOIMPFILES) megatest-version.scm megatest-fossil-hash.scm dashboard-new-runs-view.scm
+dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES) $(MOIMPFILES) $(DMOFILES) $(DMOIMPFILES) megatest-version.scm megatest-fossil-hash.scm dashboard-new-runs-view.scm
+	csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) $(MOIMPFILES) $(DMOFILES) $(DMOIMPFILES) -o dboard
 
 mtut: $(OFILES) $(MOFILES) megatest-fossil-hash.scm mtut.scm megatest-version.scm
 	csc $(CSCOPTS) $(OFILES) $(MOFILES) mtut.scm -o mtut
 
 # include makefile.inc
@@ -106,16 +111,14 @@
 	configf.o \
 	db.o \
 	env.o \
 	http-transport.o \
 	items.o \
-	keys.o \
 	launch.o \
 	lock-queue.o \
 	margs.o \
 	mt.o \
-	ods.o \
 	portlogger.o \
 	process.o \
 	rmt.o \
 	runconfig.o \
 	runs.o \
@@ -124,14 +127,15 @@
 	tdb.o \
 	tests.o \
 	subrun.o \
         ezsteps.o
 
+# 	 ods.o \
 #        mofiles/rmtmod.o \
 #        mofiles/commonmod.o \
 
-tcmt : $(TCMTOBJS) tcmt.scm megatest-version.scm
+tcmt : $(TCMTOBJS) tcmt.scm megatest-version.scm $(MOIMPFILES) $(MOFILES)
 	csc $(CSCOPTS) $(TCMTOBJS) $(MOFILES) $(MOIMPFILES) tcmt.scm -o tcmt
 
 # install documentation to $(PREFIX)/docs
 # DOES NOT REBUILD DOCS
 #
@@ -147,43 +151,79 @@
 
 $(PREFIX)/share/db/mt-pg.sql : mt-pg.sql
 	mkdir -p $(PREFIX)/share/db
 	$(INSTALL) mt-pg.sql $(PREFIX)/share/db/mt-pg.sql
 
-# Special dependencies for the includes
+# Include the generated dependency file
+# include build.inc
+
+# Special dependencies for the module includes
 $(MOFILE) $(MOIMPFILES) : megatest-fossil-hash.scm
+# we are going to generate this by running make without -j
+# and only adding the needed deps. The full deps have too many
+# circular deps and can not (yet) be resolved.
 
-# common.o : mofiles/commonmod.o megatest-fossil-hash.scm
+mofiles/dcommonmod.o mofiles/configfmod.o mofiles/ods.o \
+      mofiles/apimod.o mofiles/rmtmod.o : \
+      mofiles/commonmod.o
 
-# commonmod.o dashboard.o megatest.o tcmt.o apimod.o : megatest-fossil-hash.scm
+mofiles/dbmod.o : mofiles/commonmod.o mofiles/ods.o mofiles/configfmod.o
+mofiles/servermod.o mofiles/rmtmod.o : mofiles/dbmod.o
 
-tests.o db.o launch.o runs.o dashboard-tests.o				\
+dcommon.o : mofiles/dcommonmod.o
+
+
+# megatest.o : $(MOIMPFILES)
+# mofiles/commonmod.o : megatest-fossil-hash.scm
+# mofiles/dbmod.o \
+#       mofiles/servermod.o \
+#       mofiles/apimod.o \
+#       mofiles/dcommonmod.o \
+#       mofiles/ods.o : mofiles/commonmod.o mofiles/configfmod.o
+# 
+# mofiles/dcommonmod.o : mofiles/configfmod.o mofiles/dbmod.o
+# mofiles/configfmod.o : mofiles/commonmod.o
+# # mofiles/dbmod.o      : mofiles/configfmod.o
+# mofiles/rmtmod.o : mofiles/apimod.o
+# # mofiles/servermod.o : mofiles/dbmod.o
+# common.o : mofiles/commonmod.o
+# 
+# # commonmod.o dashboard.o megatest.o tcmt.o apimod.o : megatest-fossil-hash.scm
+# 
+# tests.o db.o launch.o runs.o dashboard-tests.o				\
+
 dashboard-context-menu.o dashboard-guimonitor.o dashboard-main.o	\
 monitor.o dashboard.o archive.o megatest.o : db_records.scm megatest-fossil-hash.scm
+
+# dashboard.o : mofiles/apimod.o
 
 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
+db.o ezsteps.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm
 
 tests.o tasks.o dashboard-tasks.o : task_records.scm
 
 runs.o : test_records.scm
+# api.o rmt.o db.o : mofiles/apimod.o mofiles/dbmod.o mofiles/rmtmod.o mofiles/ods.o
 
-megatest.o : megatest-fossil-hash.scm megatest-version.scm
+mofiles/commonmod.o common.o megatest.o dashboard.o : megatest-fossil-hash.scm megatest-version.scm
 
-rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm megatest-version.scm
+# rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm megatest-version.scm
 
 common_records.scm : altdb.scm
 
 # mofiles/stml2.o : mofiles/cookie.o
 # configf.o : mofiles/commonmod.o
 
 vg.o dashboard.o : vg_records.scm megatest-version.scm
 
 dcommon.o : run_records.scm
+# mofiles/dcommonmod.o
 
-mofiles/stml2.o : mofiles/cookie.o
+mofiles/stml2.o  : mofiles/cookie.o
+# mofiles/dbmod.o  : mofiles/ods.o
+# mofiles/rmtmod.o : mofiles/dbmod.o
 
 # # special include based modules
 # mofiles/pkts.o      : pkts/pkts.scm
 # mofiles/stml2.o     : cookie.o
 # # mofiles/mtargs.o    : mtargs/mtargs.scm
@@ -195,11 +235,11 @@
 
 # Temporary while transitioning to new routine
 # runs.o : run-tests-queue-classic.scm  run-tests-queue-new.scm
 
 # for the modularized stuff
-mofiles/rmtmod.o : mofiles/commonmod.o
+# mofiles/rmtmod.o : mofiles/commonmod.o
 
 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
 
@@ -316,23 +356,23 @@
 	utils/mk_wrapper $(PREFIX) dboard $(PREFIX)/bin/dashboard
 	chmod a+x $(PREFIX)/bin/dashboard
 	$(INSTALL) dboard $(PREFIX)/bin/.$(ARCHSTR)/dboard
 
 $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so : lib/libpangox-1.0.so
-	if [[ $(ARCHSTR) == 12.5 ]]; then \
+	@if [[ $(ARCHSTR) == 12.5 ]]; then \
 	mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib; \
 	$(INSTALL) lib/libpangox-1.0.so $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so; \
 	fi
 
 $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so.0 : lib/libpangox-1.0.so.0
-	if [[ $(ARCHSTR) == 12.5 ]]; then \
+	@if [[ $(ARCHSTR) == 12.5 ]]; then \
 	mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib; \
 	$(INSTALL) lib/libpangox-1.0.so.0 $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so.0; \
         fi
 
 $(PREFIX)/bin/.$(ARCHSTR)/lib/libxcb-xlib.so.0 : lib/libxcb-xlib.so.0
-	if [[ $(ARCHSTR) == 12.5 ]]; then \
+	@if [[ $(ARCHSTR) == 12.5 ]]; then \
 	mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib; \
 	$(INSTALL) lib/libxcb-xlib.so.0 $(PREFIX)/bin/.$(ARCHSTR)/lib/libxcb-xlib.so.0; \
         fi
 
 install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \
@@ -453,12 +493,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 configf.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 mt.o ods.o portlogger.o process.o rmt.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 configf.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 mt.o ods.o portlogger.o process.o rmt.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 configf.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 launch.o lock-queue.o margs.o mt.o portlogger.o process.o rmt.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 configf.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 launch.o lock-queue.o margs.o mt.o portlogger.o process.o rmt.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: api.scm
==================================================================
--- api.scm
+++ api.scm
@@ -25,119 +25,18 @@
 (declare (unit api))
 (declare (uses rmt))
 (declare (uses db))
 (declare (uses tasks))
 
-;; allow these queries through without starting a server
-;;
-(define api:read-only-queries
-  '(get-key-val-pairs
-    get-var
-    get-keys
-    get-key-vals
-    test-toplevel-num-items
-    get-test-info-by-id
-    get-steps-info-by-id
-    get-data-info-by-id
-    test-get-rundir-from-test-id
-    get-count-tests-running-for-testname
-    get-count-tests-running
-    get-count-tests-running-in-jobgroup
-    get-previous-test-run-record
-    get-matching-previous-test-run-records
-    test-get-logfile-info
-    test-get-records-for-index-file
-    get-testinfo-state-status
-    test-get-top-process-pid
-    test-get-paths-matching-keynames-target-new
-    get-prereqs-not-met
-    get-count-tests-running-for-run-id
-    get-run-info
-    get-run-status
-    get-run-state
-    get-run-stats
-    get-run-times
-    get-targets
-    get-target
-    ;; register-run
-    get-tests-tags
-    get-test-times
-    get-tests-for-run
-    get-tests-for-run-state-status
-    get-test-id
-    get-tests-for-runs-mindata
-    get-tests-for-run-mindata
-    get-run-name-from-id
-    get-runs
-    simple-get-runs
-    get-num-runs
-    get-runs-cnt-by-patt
-    get-all-run-ids
-    get-prev-run-ids
-    get-run-ids-matching-target
-    get-runs-by-patt
-    get-steps-data
-    get-steps-for-test
-    read-test-data
-    read-test-data-varpatt
-    login
-    tasks-get-last
-    testmeta-get-record
-    have-incompletes?
-    ;; synchash-get
-    get-changed-record-ids
-    get-run-record-ids 
-    get-not-completed-cnt))
-
-(define api:write-queries
-  '(
-    get-keys-write ;; dummy "write" query to force server start
-
-    ;; SERVERS
-    start-server
-    kill-server
-
-    ;; TESTS
-    test-set-state-status-by-id
-    delete-test-records
-    delete-old-deleted-test-records
-    test-set-state-status
-    test-set-top-process-pid
-    set-state-status-and-roll-up-items
-    
-    update-pass-fail-counts
-    top-test-set-per-pf-counts ;; (db:top-test-set-per-pf-counts (db:get-db *db* 5) 5 "runfirst")
-
-    ;; RUNS
-    register-run
-    set-tests-state-status
-    delete-run
-    lock/unlock-run
-    update-run-event_time
-    mark-incomplete
-    set-state-status-and-roll-up-run
-    ;; STEPS
-    teststep-set-status!
-    delete-steps-for-test
-    ;; TEST DATA
-    test-data-rollup
-    csv->test-data
-
-    ;; MISC
-    sync-inmem->db
-    drop-all-triggers
-    create-all-triggers
-    update-tesdata-on-repilcate-db 
-
-    ;; TESTMETA
-    testmeta-add-record
-    testmeta-update-field
-
-    ;; TASKS
-    tasks-add
-    tasks-set-state-given-param-key
-    ))
+(declare (uses commonmod))
+(import commonmod)
+
+(declare (uses apimod))
+(import apimod)
+
+(declare (uses dbmod))
+(import dbmod)
 
 ;; These are called by the server on recipt of /api calls
 ;;    - keep it simple, only return the actual result of the call, i.e. no meta info here
 ;;
 ;;    - returns #( flag result )

Index: apimod.scm
==================================================================
--- apimod.scm
+++ apimod.scm
@@ -18,17 +18,124 @@
 
 ;;======================================================================
 
 (declare (unit apimod))
 (declare (uses commonmod))
-(declare (uses ulex))
+;; (declare (uses ulex))
 
 (module apimod
 	*
 	
 (import scheme chicken data-structures extras)
 (import (prefix sqlite3 sqlite3:) posix typed-records srfi-18)
 (import commonmod)
-(import (prefix ulex ulex:))
+
+;; allow these queries through without starting a server
+;;
+(define api:read-only-queries
+  '(get-key-val-pairs
+    get-var
+    get-keys
+    get-key-vals
+    test-toplevel-num-items
+    get-test-info-by-id
+    get-steps-info-by-id
+    get-data-info-by-id
+    test-get-rundir-from-test-id
+    get-count-tests-running-for-testname
+    get-count-tests-running
+    get-count-tests-running-in-jobgroup
+    get-previous-test-run-record
+    get-matching-previous-test-run-records
+    test-get-logfile-info
+    test-get-records-for-index-file
+    get-testinfo-state-status
+    test-get-top-process-pid
+    test-get-paths-matching-keynames-target-new
+    get-prereqs-not-met
+    get-count-tests-running-for-run-id
+    get-run-info
+    get-run-status
+    get-run-state
+    get-run-stats
+    get-run-times
+    get-targets
+    get-target
+    ;; register-run
+    get-tests-tags
+    get-test-times
+    get-tests-for-run
+    get-tests-for-run-state-status
+    get-test-id
+    get-tests-for-runs-mindata
+    get-tests-for-run-mindata
+    get-run-name-from-id
+    get-runs
+    simple-get-runs
+    get-num-runs
+    get-runs-cnt-by-patt
+    get-all-run-ids
+    get-prev-run-ids
+    get-run-ids-matching-target
+    get-runs-by-patt
+    get-steps-data
+    get-steps-for-test
+    read-test-data
+    read-test-data-alt
+    login
+    tasks-get-last
+    testmeta-get-record
+    have-incompletes?
+    ;; synchash-get
+    get-changed-record-ids
+    get-run-record-ids 
+    get-not-completed-cnt))
+
+(define api:write-queries
+  '(
+    get-keys-write ;; dummy "write" query to force server start
+
+    ;; SERVERS
+    start-server
+    kill-server
+
+    ;; TESTS
+    test-set-state-status-by-id
+    delete-test-records
+    delete-old-deleted-test-records
+    test-set-state-status
+    test-set-top-process-pid
+    set-state-status-and-roll-up-items
+    
+    update-pass-fail-counts
+    top-test-set-per-pf-counts ;; (db:top-test-set-per-pf-counts (db:get-db *db* 5) 5 "runfirst")
+
+    ;; RUNS
+    register-run
+    set-tests-state-status
+    delete-run
+    lock/unlock-run
+    update-run-event_time
+    mark-incomplete
+    set-state-status-and-roll-up-run
+    ;; STEPS
+    teststep-set-status!
+    delete-steps-for-test
+    ;; TEST DATA
+    test-data-rollup
+    csv->test-data
+
+    ;; MISC
+    sync-inmem->db
+    drop-all-triggers
+    create-all-triggers
+    update-tesdata-on-repilcate-db 
+
+    ;; TESTMETA
+    testmeta-add-record
+    testmeta-update-field
 
-
+    ;; TASKS
+    tasks-add
+    tasks-set-state-given-param-key
+    ))
 )

Index: archive.scm
==================================================================
--- archive.scm
+++ archive.scm
@@ -21,10 +21,19 @@
 (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 format md5 message-digest srfi-18)
 
 (declare (unit archive))
 (declare (uses db))
 (declare (uses common))
+
+(declare (uses configfmod))
+(import configfmod)
+
+(declare (uses commonmod))
+(import commonmod)
+
+(declare (uses dbmod))
+(import dbmod)
 
 (include "common_records.scm")
 (include "db_records.scm")
 
 ;;======================================================================

ADDED   attic/portlogger-example.scm
Index: attic/portlogger-example.scm
==================================================================
--- /dev/null
+++ attic/portlogger-example.scm
@@ -0,0 +1,21 @@
+;;  Copyright 2006-2017, Matthew Welland.
+;; 
+;; This file is part of Megatest.
+;; 
+;;     Megatest is free software: you can redistribute it and/or modify
+;;     it under the terms of the GNU General Public License as published by
+;;     the Free Software Foundation, either version 3 of the License, or
+;;     (at your option) any later version.
+;; 
+;;     Megatest is distributed in the hope that it will be useful,
+;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;     GNU General Public License for more details.
+;; 
+;;     You should have received a copy of the GNU General Public License
+;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
+
+
+(declare (uses portlogger))
+
+(print (apply portlogger:main (cdr (argv))))

ADDED   build.inc
Index: build.inc
==================================================================
--- /dev/null
+++ build.inc
@@ -0,0 +1,288 @@
+# To regenerate this file do:
+#   (cd utils/;ck52 csc gendeps.scm) && ./utils/gendeps allunits *scm
+#   cp allunits.inc build.inc
+#
+
+mofiles/apimod.o : mofiles/commonmod.o
+api.o : rmt.o
+api.o : db.o
+api.o : tasks.o
+api.o : mofiles/commonmod.o
+api.o : mofiles/apimod.o
+api.o : mofiles/dbmod.o
+archive.o : db.o
+archive.o : common.o
+archive.o : mofiles/configfmod.o
+archive.o : mofiles/commonmod.o
+archive.o : mofiles/dbmod.o
+client.o : common.o
+client.o : db.o
+client.o : mofiles/commonmod.o
+client.o : mofiles/dbmod.o
+client.o : rmt.o
+client.o : mofiles/servermod.o
+common.o : mofiles/commonmod.o
+common.o : mofiles/dbmod.o
+common.o : mofiles/configfmod.o
+common.o : mofiles/servermod.o
+mofiles/configfmod.o : mofiles/commonmod.o
+configf.o : process.o
+configf.o : env.o
+configf.o : mofiles/commonmod.o
+configf.o : mofiles/configfmod.o
+dashboard-context-menu.o : common.o
+dashboard-context-menu.o : db.o
+dashboard-context-menu.o : gutils.o
+dashboard-context-menu.o : rmt.o
+dashboard-context-menu.o : ezsteps.o
+dashboard-context-menu.o : subrun.o
+dashboard-context-menu.o : mofiles/commonmod.o
+dashboard-context-menu.o : mofiles/configfmod.o
+dashboard-context-menu.o : mofiles/dbmod.o
+dashboard-guimonitor.o : common.o
+dashboard-guimonitor.o : db.o
+dashboard-guimonitor.o : tasks.o
+dashboard-guimonitor.o : mofiles/commonmod.o
+dashboard-guimonitor.o : mofiles/dbmod.o
+dashboard.o : common.o
+dashboard.o : margs.o
+dashboard.o : items.o
+dashboard.o : db.o
+dashboard.o : configf.o
+dashboard.o : process.o
+dashboard.o : launch.o
+dashboard.o : runs.o
+dashboard.o : dashboard-tests.o
+dashboard.o : dashboard-guimonitor.o
+dashboard.o : tree.o
+dashboard.o : dcommon.o
+dashboard.o : dashboard-context-menu.o
+dashboard.o : vg.o
+dashboard.o : subrun.o
+dashboard.o : mt.o
+dashboard.o : mofiles/commonmod.o
+# dashboard.o : commonmod.import.o
+dashboard.o : mofiles/configfmod.o
+# dashboard.o : configfmod.import.o
+dashboard.o : mofiles/dcommonmod.o
+# dashboard.o : dcommonmod.import.o
+dashboard.o : mofiles/apimod.o
+dashboard.o : mofiles/dbmod.o
+dashboard.o : mofiles/servermod.o
+dashboard-tests.o : common.o
+dashboard-tests.o : db.o
+dashboard-tests.o : gutils.o
+dashboard-tests.o : rmt.o
+dashboard-tests.o : ezsteps.o
+dashboard-tests.o : subrun.o
+dashboard-tests.o : mofiles/commonmod.o
+dashboard-tests.o : mofiles/configfmod.o
+dashboard-tests.o : mofiles/dbmod.o
+mofiles/dbmod.o : mofiles/commonmod.o
+mofiles/dbmod.o : ods.o
+mofiles/dbmod.o : mofiles/configfmod.o
+db.o : common.o
+db.o : client.o
+db.o : mt.o
+db.o : mofiles/commonmod.o
+db.o : mofiles/configfmod.o
+db.o : mofiles/dbmod.o
+db.o : mofiles/servermod.o
+mofiles/dcommonmod.o : mofiles/commonmod.o
+mofiles/dcommonmod.o : mofiles/configfmod.o
+dcommon.o : gutils.o
+dcommon.o : db.o
+dcommon.o : mofiles/commonmod.o
+dcommon.o : mofiles/dbmod.o
+dcommon.o : mofiles/configfmod.o
+dcommon.o : mofiles/dcommonmod.o
+dcommon.o : mofiles/servermod.o
+diff-report.o : common.o
+diff-report.o : rmt.o
+diff-report.o : mofiles/commonmod.o
+env.o : mofiles/commonmod.o
+ezsteps.o : db.o
+ezsteps.o : common.o
+ezsteps.o : items.o
+ezsteps.o : runconfig.o
+ezsteps.o : mofiles/commonmod.o
+ezsteps.o : mofiles/configfmod.o
+ezsteps.o : mofiles/dbmod.o
+genexample.o : mofiles/commonmod.o
+http-transport.o : common.o
+http-transport.o : db.o
+http-transport.o : portlogger.o
+http-transport.o : rmt.o
+http-transport.o : mofiles/commonmod.o
+http-transport.o : mofiles/configfmod.o
+http-transport.o : mofiles/dbmod.o
+http-transport.o : mofiles/servermod.o
+index-tree.o : lock-queue.o
+index-tree.o : db.o
+index-tree.o : common.o
+index-tree.o : items.o
+index-tree.o : runconfig.o
+index-tree.o : mofiles/commonmod.o
+items.o : common.o
+items.o : mofiles/commonmod.o
+items.o : mofiles/configfmod.o
+launch.o : subrun.o
+launch.o : common.o
+launch.o : configf.o
+launch.o : db.o
+launch.o : ezsteps.o
+launch.o : mofiles/commonmod.o
+launch.o : mofiles/configfmod.o
+launch.o : mofiles/dbmod.o
+lock-queue.o : common.o
+lock-queue.o : tasks.o
+lock-queue.o : mofiles/commonmod.o
+megatest.o : common.o
+megatest.o : margs.o
+megatest.o : runs.o
+megatest.o : launch.o
+megatest.o : server.o
+megatest.o : client.o
+megatest.o : tests.o
+megatest.o : genexample.o
+megatest.o : db.o
+megatest.o : tdb.o
+megatest.o : mt.o
+megatest.o : api.o
+megatest.o : env.o
+megatest.o : diff-report.o
+megatest.o : mofiles/commonmod.o
+# megatest.o : commonmod.import.o
+megatest.o : mofiles/configfmod.o
+# megatest.o : configfmod.import.o
+megatest.o : ods.o
+# megatest.o : ods.import.o
+megatest.o : mofiles/dbmod.o
+# megatest.o : dbmod.import.o
+megatest.o : mofiles/servermod.o
+# megatest.o : servermod.import.o
+megatest.o : mofiles/apimod.o
+# megatest.o : apimod.import.o
+megatest.o : mofiles/rmtmod.o
+# megatest.o : rmtmod.import.o
+mlaunch.o : db.o
+mlaunch.o : common.o
+monitor.o : db.o
+monitor.o : common.o
+monitor.o : items.o
+monitor.o : runconfig.o
+mtexec.o : margs.o
+mtexec.o : configf.o
+mtexec.o : mofiles/configfmod.o
+mt.o : db.o
+mt.o : common.o
+mt.o : tests.o
+mt.o : rmt.o
+mt.o : mofiles/commonmod.o
+mt.o : mofiles/configfmod.o
+mt.o : mofiles/dbmod.o
+mtut.o : common.o
+mtut.o : margs.o
+mtut.o : configf.o
+mtut.o : mofiles/commonmod.o
+mtut.o : mofiles/configfmod.o
+newdashboard.o : common.o
+newdashboard.o : megatest-version.o
+newdashboard.o : margs.o
+newdashboard.o : mofiles/commonmod.o
+newdashboard.o : mofiles/dbmod.o
+newdashboard.o : dcommon.o
+newdashboard.o : mofiles/configfmod.o
+ods.o : mofiles/commonmod.o
+portlogger.o : db.o
+portlogger.o : mofiles/commonmod.o
+portlogger.o : mofiles/configfmod.o
+portlogger.o : mofiles/dbmod.o
+process.o : mofiles/commonmod.o
+mofiles/rmtmod.o : mofiles/commonmod.o
+mofiles/rmtmod.o : mofiles/apimod.o
+mofiles/rmtmod.o : mofiles/dbmod.o
+rmt.o : api.o
+rmt.o : http-transport.o
+rmt.o : mofiles/commonmod.o
+rmt.o : mofiles/apimod.o
+rmt.o : mofiles/rmtmod.o
+rmt.o : mofiles/dbmod.o
+rmt.o : mofiles/configfmod.o
+rmt.o : mofiles/servermod.o
+runconfig.o : common.o
+runconfig.o : mofiles/commonmod.o
+runs.o : db.o
+runs.o : common.o
+runs.o : items.o
+runs.o : runconfig.o
+runs.o : tests.o
+runs.o : server.o
+runs.o : mt.o
+runs.o : archive.o
+runs.o : mofiles/commonmod.o
+runs.o : mofiles/configfmod.o
+runs.o : mofiles/dbmod.o
+runs.o : mofiles/servermod.o
+mofiles/servermod.o : mofiles/commonmod.o
+mofiles/servermod.o : mofiles/configfmod.o
+mofiles/servermod.o : mofiles/dbmod.o
+server.o : common.o
+server.o : db.o
+server.o : http-transport.o
+server.o : launch.o
+server.o : mofiles/commonmod.o
+server.o : mofiles/dbmod.o
+server.o : mofiles/configfmod.o
+server.o : mofiles/servermod.o
+sharedat.o : configf.o
+sharedat.o : margs.o
+sharedat.o : megatest-version.o
+spublish.o : margs.o
+subrun.o : db.o
+subrun.o : common.o
+subrun.o : mt.o
+subrun.o : mofiles/commonmod.o
+subrun.o : mofiles/configfmod.o
+subrun.o : mofiles/dbmod.o
+synchash.o : db.o
+synchash.o : server.o
+synchash.o : mofiles/dbmod.o
+tasks.o : db.o
+tasks.o : rmt.o
+tasks.o : common.o
+tasks.o : cgisetup/models/pgdb.o
+tasks.o : mofiles/commonmod.o
+tasks.o : mofiles/configfmod.o
+tasks.o : mofiles/dbmod.o
+tcmt.o : margs.o
+tcmt.o : rmt.o
+tcmt.o : common.o
+tcmt.o : mofiles/commonmod.o
+tdb.o : common.o
+tdb.o : client.o
+tdb.o : mt.o
+tdb.o : db.o
+tdb.o : mofiles/commonmod.o
+tdb.o : mofiles/dbmod.o
+tdb.o : ods.o
+tests.o : lock-queue.o
+tests.o : db.o
+tests.o : tdb.o
+tests.o : common.o
+tests.o : items.o
+tests.o : runconfig.o
+tests.o : server.o
+tests.o : mofiles/commonmod.o
+tests.o : mofiles/dbmod.o
+tests.o : mofiles/configfmod.o
+tests.o : mofiles/servermod.o
+tree.o : margs.o
+tree.o : launch.o
+tree.o : gutils.o
+tree.o : db.o
+tree.o : server.o
+tree.o : dcommon.o
+tree.o : mofiles/commonmod.o
+tree.o : mofiles/dbmod.o
+ulex.o : pkts.o

Index: client.scm
==================================================================
--- client.scm
+++ client.scm
@@ -27,10 +27,21 @@
 (declare (unit client))
 
 (declare (uses common))
 (declare (uses db))
 (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
+
+(declare (uses commonmod))
+(import commonmod)
+
+(declare (uses dbmod))
+(import dbmod)
+
+(declare (uses rmt))
+
+(declare (uses servermod))
+(import servermod)
 
 (include "common_records.scm")
 (include "db_records.scm")
 
 ;; client:get-signature
@@ -93,22 +104,21 @@
 		  (port  (caddr server-dat))
                   (server-id (caddr (cddr server-dat))))
 	      (debug:print-info 4 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries)
 	      (if (and (not area-dat)
 		       (not *runremote*))
-                  (begin       
-		    (set! *runremote* (make-remote))
+                  (begin
+		    ;; POSSIBLE BUG. I removed the full initialization call. mrw
+		    (set! *runremote* (create-remote-record))
                     (let* ((server-info (remote-server-info *runremote*))) 
                       (if server-info
                         (begin
                           (remote-server-url-set! *runremote* (server:record->url server-info))
                           (remote-server-id-set! *runremote* (server:record->id server-info)))))))
 	      (if (and host port server-id)
-		  (let* ((start-res (case *transport-type*
-				      ((http)(http-transport:client-connect host port server-id))))
-			 (ping-res  (case *transport-type* 
-				      ((http)(rmt:login-no-auto-client-setup start-res)))))
+		  (let* ((start-res (http-transport:client-connect host port server-id))
+			 (ping-res  (rmt:login-no-auto-client-setup start-res)))
 		    (if (and start-res
 			     ping-res)
 			(let ((runremote (or area-dat *runremote*))) ;; it might have been generated only a few statements ago
 			  (remote-conndat-set! runremote start-res) ;; (hash-table-set! runremote run-id start-res)
 			  (debug:print-info 2 *default-log-port* "connected to " (http-transport:server-dat-make-url start-res))

DELETED codescanlib.scm
Index: codescanlib.scm
==================================================================
--- codescanlib.scm
+++ /dev/null
@@ -1,144 +0,0 @@
-;;  Copyright 2006-2017, Matthew Welland.
-;; 
-;; This file is part of Megatest.
-;; 
-;;     Megatest is free software: you can redistribute it and/or modify
-;;     it under the terms of the GNU General Public License as published by
-;;     the Free Software Foundation, either version 3 of the License, or
-;;     (at your option) any later version.
-;; 
-;;     Megatest is distributed in the hope that it will be useful,
-;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;     GNU General Public License for more details.
-;; 
-;;     You should have received a copy of the GNU General Public License
-;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
-;;
-
-;; gotta compile with csc, doesn't work with csi -s for whatever reason
-
-(use srfi-69)
-(use matchable)
-(use utils)
-(use ports)
-(use extras)
-(use srfi-1)
-(use posix)
-(use srfi-12)
-
-;; turn scheme file to a list of sexps, sexps of interest will be in the form of (define (<procname> <args>) <body> )
-(define (load-scm-file scm-file)
-  ;;(print "load "scm-file)
-  (handle-exceptions
-   exn
-   '()
-   (with-input-from-string
-       (conc "("
-             (with-input-from-file scm-file read-all)
-             ")" )
-     read)))
-
-;; extract a list of procname, filename, args and body of procedures defined in filename, input from load-scm-file
-;;   -- be advised:
-;;      * this may be fooled by macros, since this code does not take them into account.
-;;      * this code does only checks for form (define (<procname> ... ) <body>)
-;;           so it excludes from reckoning
-;;               - generated functions, as in things like foo-set! from defstructs,
-;;               - define-inline, (
-;;               - define procname (lambda ..
-;;               - etc...
-(define (get-toplevel-procs+file+args+body filename)
-  (let* ((scm-tree (load-scm-file filename))
-         (procs
-          (filter identity
-                  (map
-                   (match-lambda 
-                    [('define ('uses args ...) body ...) #f] ;; filter out (define (uses ...
-                    [('define ('unit args ...) body ...) #f] ;; filter out (define (unit ...
-                    [('define ('prefix args ...) body ...) #f] ;; filter out (define (prefix ...
-                    [('define (defname args ...) body ...) ;; match (define (procname <args>) <body>)
-                     (if (atom? defname) ;; filter out things we dont understand (procname is a list, what??)
-                         (list defname filename args body)
-                         #f)]
-                    [else #f] ) scm-tree))))
-    procs))
-
-
-;; given a sexp, return a flat list of atoms in that sexp
-(define (get-atoms-in-body body)
-  (cond
-   ((null? body) '())
-   ((atom? body) (list body))
-   (else
-    (apply append (map get-atoms-in-body body)))))
-
-;;  given a file, return a list of procname, file, list of atoms in said procname
-(define (get-procs+file+atoms file)
-  (let* ((toplevel-proc-items (get-toplevel-procs+file+args+body file))
-         (res
-          (map
-           (lambda (item)
-             (let* ((proc (car item))
-                    (file (cadr item))
-                    (args (caddr item))
-                    (body (cadddr item))
-                    (atoms (append (get-atoms-in-body args) (get-atoms-in-body body))))
-               (list proc file atoms)))
-           toplevel-proc-items)))
-    res))
-
-;; uniquify a list of atoms 
-(define (unique-atoms lst)
-  (let loop ((lst (flatten lst)) (res '()))
-    (if (null? lst)
-        (reverse res)
-        (let ((c (car lst)))
-          (loop (cdr lst) (if (member c res) res (cons c res)))))))
-
-;; given a list of procname, filename, list of procs called from procname, cross reference and reverse
-;; returning alist mapping procname to procname that calls said procname
-(define (get-callers-alist all-procs+file+calls)
-  (let* ((all-procs (map car all-procs+file+calls))
-         (caller-ht (make-hash-table))) 
-    ;; let's cross reference with a hash table
-    (for-each (lambda (proc) (hash-table-set! caller-ht proc '())) all-procs)
-    (for-each (lambda (item)
-               (let* ((proc (car item))
-                      (file (cadr item))
-                      (calls (caddr item)))
-                 (for-each (lambda (callee)
-                             (hash-table-set! caller-ht callee
-                                              (cons proc
-                                                    (hash-table-ref caller-ht callee))))
-                           calls)))
-              all-procs+file+calls)
-    (map (lambda (x)
-           (let ((k (car x))
-                 (r (unique-atoms (cdr x))))
-             (cons k r)))                    
-         (hash-table->alist caller-ht))))
-
-;; create a handy cross-reference of callees to callers in the form of an alist.
-(define (get-xref all-scm-files)
-  (let* ((all-procs+file+atoms
-          (apply append (map get-procs+file+atoms all-scm-files)))
-         (all-procs (map car all-procs+file+atoms))
-         (all-procs+file+calls  ; proc calls things in calls list
-          (map (lambda (item)
-                 (let* ((proc (car item))
-                        (file (cadr item))
-                        (atoms (caddr item))
-                        (calls
-                         (filter identity
-                                 (map
-                                  (lambda (x)
-                                    (if (and ;; (not (equal? x proc))  ;; uncomment to prevent listing self
-                                         (member x all-procs))
-                                        x
-                                        #f))
-                                  atoms))))
-                   (list proc file calls)))
-               all-procs+file+atoms))
-         (callers (get-callers-alist all-procs+file+calls))) 
-    callers))

Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -16,26 +16,55 @@
 ;;     You should have received a copy of the GNU General Public License
 ;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
 
 ;;======================================================================
 
-(use srfi-1 data-structures posix regex-case (prefix base64 base64:)
-     format dot-locking csv-xml z3 udp ;; sql-de-lite
-     hostinfo md5 message-digest typed-records directory-utils stack
-     matchable regex posix (srfi 18) extras ;; tcp 
-     (prefix nanomsg nmsg:)
-     (prefix sqlite3 sqlite3:)
-     pkts (prefix dbi dbi:)
-     )
+(use
+ (prefix base64 base64:)
+ (prefix nanomsg nmsg:)
+ (prefix sqlite3 sqlite3:)
+ (srfi 18)
+ csv-xml
+ data-structures
+ directory-utils
+ dot-locking
+ extras ;; tcp 
+ format
+ hostinfo
+ matchable
+ md5
+ message-digest
+ pkts
+ (prefix dbi dbi:)
+ posix
+ posix
+ regex
+ regex-case
+ srfi-1
+ stack
+ typed-records
+ udp ;; sql-de-lite
+ z3
+ )
 
 (declare (unit common))
-;; (declare (uses commonmod))
-;; (import commonmod)
+(declare (uses commonmod))
+(import commonmod)
+
+;; dbr:dbstruct is used here. should move it
+(declare (uses dbmod))
+(import dbmod)
+
+(declare (uses configfmod))
+(import configfmod)
+
+(declare (uses servermod))
+(import servermod)
 
 (include "common_records.scm")
 
-
+;;======================================================================
 ;; (require-library margs)
 ;; (include "margs.scm")
 
 ;; (define old-exit exit)
 ;; 
@@ -42,464 +71,698 @@
 ;; (define (exit . code)
 ;;   (if (null? code)
 ;;       (old-exit)
 ;;       (old-exit code)))
 
-
-;; execute thunk, return value.  If exception thrown, trap exception, return #f, and emit nonfatal condition note to *default-log-port* .
-;; arguments - thunk, message
-(define (common:fail-safe thunk warning-message-on-exception)
-  (handle-exceptions
-   exn
-   (begin
-     (debug:print-info 0 *default-log-port* "notable but nonfatal condition - "warning-message-on-exception", exn=" exn)
-     (debug:print-info 0 *default-log-port*
-                       (string-substitute "\n?Error:" "nonfatal condition:"
-                                          (with-output-to-string
-                                            (lambda ()
-                                              (print-error-message exn) ))))
-     (debug:print-info 0 *default-log-port* "    -- continuing after nonfatal condition...")
-     #f)
-   (thunk)))
-
-(define getenv get-environment-variable)
-(define (safe-setenv key val)
-  (if (or (substring-index "!" key)
-	  (substring-index ":" key)  ;; variables containing : are for internal use and cannot be environment variables.
-	  (substring-index "." key)) ;; periods are not allowed in environment variables
-      (debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\" or starting with \"!\"")
-      (if (and (string? val)
-	       (string? key))
-	  (handle-exceptions
-	      exn
-	      (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val ", exn=" exn)
-	    (setenv key val))
-	  (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val))))
-
-(define home (getenv "HOME"))
-(define user (getenv "USER"))
-
-
-;; returns list of fd count, socket count
-(define (get-file-descriptor-count #!key  (pid (current-process-id )))
-  (list
-    (length (glob (conc "/proc/" pid "/fd/*")))
-    (length  (filter identity (map socket? (glob (conc "/proc/" pid "/fd/*")))))
-  )
-)
-
-  
-
-;; GLOBALS
-
-;; CONTEXTS
-(defstruct cxt
-  (taskdb #f)
-  (cmutex (make-mutex)))
-;; (define *contexts* (make-hash-table))
-;; (define *context-mutex* (make-mutex))
-
-;; ;; safe method for accessing a context given a toppath
-;; ;;
-;; (define (common:with-cxt toppath proc)
-;;   (mutex-lock! *context-mutex*)
-;;   (let ((cxt (hash-table-ref/default *contexts* toppath #f)))
-;;     (if (not cxt)
-;;         (set! cxt (let ((x (make-cxt)))(hash-table-set! *contexts* toppath x) x)))
-;;     (let ((cxt-mutex (cxt-mutex cxt)))
-;;       (mutex-unlock! *context-mutex*)
-;;       (mutex-lock! cxt-mutex)
-;;       (let ((res (proc cxt)))
-;;         (mutex-unlock! cxt-mutex)
-;;         res))))
-        
-;; A hash table that can be accessed by #{scheme ...} calls in
-;; config files. Allows communicating between confgs
-;;
-(define *user-hash-data* (make-hash-table))
-
-(define *db-keys* #f)
-
-(define *pkts-info*    (make-hash-table)) ;; store stuff like the last parent here
-(define *configinfo*   #f)   ;; raw results from setup, includes toppath and table from megatest.config
-(define *runconfigdat* #f)   ;; run configs data
-(define *configdat*    #f)   ;; megatest.config data
-(define *configstatus* #f)   ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done
-(define *toppath*      #f)
-(define *already-seen-runconfig-info* #f)
-
-(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 *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.
-;; db stats
-(define *db-stats*            (make-hash-table)) ;; hash of vectors < count duration-total >
-(define *db-stats-mutex*      (make-mutex))
-;; db access
-(define *db-last-access*      (current-seconds)) ;; last db access, used in server
-(define *db-write-access*     #t)
-;; db sync
-(define *db-last-sync*        0)                 ;; last time the sync to megatest.db happened
-(define *db-sync-in-progress* #f)                ;; if there is a sync in progress do not try to start another
-(define *db-multi-sync-mutex* (make-mutex))      ;; protect access to *db-sync-in-progress*, *db-last-sync*
-;; task db
-(define *task-db*             #f) ;; (vector db path-to-db)
-(define *db-access-allowed*   #t) ;; flag to allow access
-(define *db-access-mutex*     (make-mutex))
-(define *db-transaction-mutex* (make-mutex))
-(define *db-cache-path*       #f)
-(define *db-with-db-mutex*    (make-mutex))
-(define *db-api-call-time*    (make-hash-table)) ;; hash of command => (list of times)
-;; no sync db
-(define *no-sync-db*          #f)
-
-;; SERVER
-(define *my-client-signature* #f)
-(define *transport-type*    'http)             ;; override with [server] transport http|rpc|nmsg
-(define *runremote*         #f)                ;; if set up for server communication this will hold <host port>
-;; (define *max-cache-size*    0)
-(define *logged-in-clients* (make-hash-table))
-(define *server-id*         #f)
-(define *server-info*       #f)  ;; good candidate for easily convert to non-global
-(define *time-to-exit*      #f)
-(define *server-run*        #t)
-(define *run-id*            #f)
-(define *server-kind-run*   (make-hash-table))
-(define *home-host*         #f)
-;; (define *total-non-write-delay* 0)
-(define *heartbeat-mutex*   (make-mutex))
-(define *api-process-request-count* 0)
-(define *max-api-process-requests* 0)
-(define *server-overloaded*  #f)
-
-;; client
-(define *rmt-mutex*         (make-mutex))     ;; remote access calls mutex 
-
-;; RPC transport
-(define *rpc:listener*      #f)
-
-;; KEY info
-(define *target*            (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN
-(define *keys*              (make-hash-table)) ;; cache the keys here
-(define *keyvals*           (make-hash-table))
-(define *toptest-paths*     (make-hash-table)) ;; cache toptest path settings here
-(define *test-paths*        (make-hash-table)) ;; cache test-id to test run paths here
-(define *test-ids*          (make-hash-table)) ;; cache run-id, testname, and item-path => test-id
-(define *test-info*         (make-hash-table)) ;; cache the test info records, update the state, status, run_duration etc. from testdat.db
-
-(define *run-info-cache*     (make-hash-table)) ;; run info is stable, no need to reget
-(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
+(define (common:debug-setup)
+  (debug:setup (cond ;; debug arg
+		((args:get-arg "-debug-noprop") 'noprop)
+		((args:get-arg "-debug")         #t)
+		(else #f))
+	       (cond ;; verbosity arg
+		((args:get-arg "-q") 'v)
+		((args:get-arg "-q") 'q)
+		(else #f))))
 (define *numcpus-cache* (make-hash-table))
 
-(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*))
-
 (define (common:get-sync-lock-filepath)
   (let* ((tmp-area     (common:get-db-tmp-area))
          (lockfile     (conc tmp-area "/megatest.db.sync-lock")))
     lockfile))
 
 ;;======================================================================
-;; when called from a wrapper I need sometimes to find the calling
-;; wrapper, this is for dashboard to find the correct megatest.
-;;
-(define (common:find-local-megatest #!optional (progname "megatest"))
-  (let ((res (filter file-exists?
-		     (map (lambda (updir)
-			    (let* ((lm  (car (argv)))
-				   (dir (pathname-directory lm))
-				   (exe (pathname-strip-directory lm)))
-			      (conc (if dir (conc dir "/") "")
-				    (case (string->symbol exe)
-				      ((dboard)    (conc updir progname))
-				      ((mtest)     (conc updir progname))
-				      ((dashboard) progname)
-				      (else exe)))))
-			  '("../../" "../")))))
-    (if (null? res)
-	(begin
-	  (debug:print 0 *default-log-port* "Failed to find this executable! Using what can be found on the path")
-	  progname)
-	(car res))))
-
-(define *common:logpro-exit-code->status-sym-alist*
-  '( ( 0 . pass )
-     ( 1 . fail )
-     ( 2 . warn )
-     ( 3 . check )
-     ( 4 . waived )
-     ( 5 . abort )
-     ( 6 . skip )))
-
-(define (common:logpro-exit-code->status-sym exit-code)
-  (or (alist-ref exit-code *common:logpro-exit-code->status-sym-alist*) 'fail))
-
-(define (common:worse-status-sym ss1 ss2)
-  (let loop ((status-syms-remaining '(abort fail check skip warn waived pass)))
-    (cond
-     ((null? status-syms-remaining)
-      'fail)
-     ((eq? (car status-syms-remaining) ss1)
-      ss1)
-     ((eq? (car status-syms-remaining) ss2)
-      ss2)
-     (else
-      (loop (cdr status-syms-remaining))))))
-
-(define (common:steps-can-proceed-given-status-sym status-sym)
-  (if (member status-sym '(warn waived pass))
-      #t
-      #f))
-
-(define (status-sym->string status-sym)
-  (case status-sym
-      ((pass) "PASS")
-    ((fail) "FAIL")
-    ((warn) "WARN")
-    ((check) "CHECK")
-    ((waived) "WAIVED")
-    ((abort) "ABORT")
-    ((skip) "SKIP")
-    (else "FAIL")))
-
-(define (common:logpro-exit-code->test-status exit-code)
-  (status-sym->string (common:logpro-exit-code->status-sym exit-code)))
-
-(defstruct remote
-  (hh-dat            (common:get-homehost)) ;; homehost record ( addr . hhflag )
-  (server-url        #f) ;; (server:check-if-running *toppath*) #f))
-  (server-id         #f)
-  (server-info       (if *toppath* (server:check-if-running *toppath*) #f))
-  (last-server-check 0)  ;; last time we checked to see if the server was alive
-  (conndat           #f)
-  (transport         *transport-type*)
-  (server-timeout    (server:expiration-timeout))
-  (force-server      #f)
-  (ro-mode           #f)  
-  (ro-mode-checked   #f)) ;; flag that indicates we have checked for ro-mode
-
-;; launching and hosts
-(defstruct host
-  (reachable    #f)
-  (last-update  0)
-  (last-used    0)
-  (last-cpuload 1))
-
-(define *host-loads*         (make-hash-table))
-
-;; cache environment vars for each run here
-(define *env-vars-by-run-id* (make-hash-table))
-
-;; Testconfig and runconfig caches. 
-(define *testconfigs*        (make-hash-table)) ;; test-name => testconfig
-(define *runconfigs*         (make-hash-table)) ;; target    => runconfig
-
-;; 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))
-  (set! *test-paths*         (make-hash-table))
-  (set! *test-ids*           (make-hash-table))
-  (set! *test-info*          (make-hash-table))
-  (set! *run-info-cache*     (make-hash-table))
-  (set! *env-vars-by-run-id* (make-hash-table))
-  (set! *test-id-cache*      (make-hash-table)))
-
-;; Generic string database
-(define sdb:qry #f) ;; (make-sdb:qry)) ;;  'init #f)
-;; Generic path database
-(define *fdb* #f)
-
-(define *last-launch* (current-seconds)) ;; use for throttling the launch rate. Would be better to use the db and last time of a test in LAUNCHED state.
-
-;;======================================================================
-;; V E R S I O N
-;;======================================================================
-
-(define (common:get-full-version)
-  (conc megatest-version "-" megatest-fossil-hash))
-
-(define (common:version-signature)
-  (conc megatest-version "-" (substring megatest-fossil-hash 0 4)))
-
-;;======================================================================
-;; from metadat lookup MEGATEST_VERSION
-;;
-(define (common:get-last-run-version) ;; RADT => How does this work in send-receive function??; assume it is the value saved in some DB
-  (rmt:get-var "MEGATEST_VERSION"))
-
-(define (common:get-last-run-version-number)
-  (string->number 
-   (substring (common:get-last-run-version) 0 6)))
-
-(define (common:set-last-run-version)
-  (rmt:set-var "MEGATEST_VERSION" (common:version-signature)))
-
-;;======================================================================
-;; postive number if megatest version > db version
-;; negative number if megatest version < db version
-(define (common:version-db-delta)
-  (- megatest-version (common:get-last-run-version-number)))
-
-(define (common:version-changed?)
-  (not (equal? (common:get-last-run-version)
-               (common:version-signature))))
-
-(define (common:api-changed?)
-  (not (equal? (substring (->string megatest-version) 0 4)
-               (substring (conc (common:get-last-run-version)) 0 4))))
-
-;;======================================================================
-;; Move me elsewhere ...
-;; RADT => Why do we meed the version check here, this is called only if version misma
-;;
-(define (common:cleanup-db dbstruct #!key (full #f))
-  (apply db:multi-db-sync 
-   dbstruct
-   'schema
-   ;; 'new2old
-   'killservers
-   'adj-target
-   ;; 'old2new
-   'new2old
-   ;; (if full
-       '(dejunk)
-       ;; '())
-       )
-  (if (common:api-changed?)
-      (common:set-last-run-version)))
-
-(define (common:snapshot-file filepath #!key (subdir  ".") )
-  (if (file-exists? filepath)
-      (let* ((age-sec  (lambda (file)
-                         (if (file-exists? file)
-                             (- (current-seconds) (file-modification-time file))
-                             1000000000))) ;; return really old value if file doesn't exist.  we want to clobber it if old or not exist.
-             (ok-flag  #t)
-             (age-mins (lambda (file) (/ (age-sec   file) 60)))
-             (age-hrs  (lambda (file) (/ (age-mins file) 60)))
-             (age-days (lambda (file) (/ (age-hrs   file) 24)))
-             (age-wks  (lambda (file) (/ (age-days  file) 7)))
-             (docmd    (lambda (cmd)
-                         (cond
-                          (ok-flag
-                           (let ((res (system cmd)))
-                             (cond
-                              ((eq? 0 res)
-                               #t)
-                              (else
-                               (set! ok-flag #f)
-                               (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Command failed with exit code "
-                                            (if (< res 0)
-                                                res
-                                                (/ res 8)) " ["cmd"]" )
-                               #f))))
-                          (else
-                           (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Not runnining command due to prior error. ["cmd"]")
-                           #f))))
-             (copy     (lambda (src dest) (docmd (conc "/bin/cp '"src"' '"dest"'"))))
-             (copy+zip (lambda (src dest) (docmd (conc "gzip -c - < '"src"' > '"dest"'"))))
-             (fullpath (realpath filepath))
-             (basedir  (pathname-directory fullpath))
-             (basefile (pathname-strip-directory fullpath))
-             ;;(prevfile (conc filepath ".prev.gz"))
-             (minsfile (conc basedir "/" subdir "/" basefile ".mins.gz"))
-             (hrsfile  (conc basedir "/" subdir "/" basefile ".hrs.gz"))
-             (daysfile (conc basedir "/" subdir "/" basefile ".days.gz"))
-             (wksfile  (conc basedir "/" subdir "/" basefile ".weeks.gz")))
-
-        ;; create subdir it not exists
-        (if (not (directory-exists? (conc basedir "/" subdir)))
-            (docmd (conc "/bin/mkdir -p '"(conc basedir "/" subdir)"'")))
-        
-        ;; copy&zip <file> to <file>.mins if not exists
-        (if (not (file-exists? minsfile))
-            (copy+zip filepath minsfile))
-        ;; copy <file>.mins to <file>.hrs if not exists
-        (if (not (file-exists? hrsfile))
-            (copy minsfile hrsfile))
-        ;; copy <file>.hrs to <file>.days if not exists
-        (if (not (file-exists? daysfile))
-            (copy hrsfile daysfile))
-        ;; copy <file>.days to <file>.weeks if not exists
-        (if (not (file-exists? wksfile))
-            (copy daysfile wksfile))
-
-
-        ;; if age(<file>.mins.gz) >= 1h:
-        ;;     copy <file>.mins.gz <file>.hrs.gz
-        ;;     copy <prev file> <file>.mins.gz
-        (when (>= (age-mins minsfile) 1)
-          (copy minsfile hrsfile)
-          (copy+zip filepath  minsfile))
-        
-        ;; if age(<file>.hrs.gz) >= 1d:
-        ;;     copy <file>.hrs.gz <file>.days.gz
-        ;;     copy <file>.mins.gz <file>.hrs.gz
-        (when (>= (age-days hrsfile) 1)
-          (copy hrsfile daysfile)
-          (copy minsfile hrsfile))
-        
-        ;; if age(<file>.days.gz) >= 1w:
-        ;;     copy <file>.days.gz <file>.weeks.gz
-        ;;     copy <file>.hrs.gz <file>.days.gz
-        (when (>= (age-wks daysfile) 1)
-          (copy daysfile wksfile)
-          (copy hrsfile daysfile))
-        #t)
-      #f))
+	  (debug:print 0 *default-log-port* "Failed to find this executable! Using what can be found on the path")
+
+;;======================================================================
+;; L O C K I N G   M E C H A N I S M S 
+;;======================================================================
+
+;;======================================================================
+;; faux-lock is deprecated. Please use simple-lock below
+;;======================================================================
+;;======================================================================
+;;
+(define (common:faux-lock keyname #!key (wait-time 8)(allow-lock-steal #t))
+  (if (rmt:no-sync-get/default keyname #f) ;; do not be tempted to compare to pid. locking is a one-shot action, if already locked for this pid it doesn't actually count
+      (if (> wait-time 0)
+	  (begin
+	    (thread-sleep! 1)
+	    (if (eq? wait-time 1) ;; only one second left, steal the lock
+		(begin
+		  (debug:print-info 0 *default-log-port* "stealing lock for " keyname)
+		  (common:faux-unlock keyname force: #t)))
+	    (common:faux-lock keyname wait-time: (- wait-time 1)))
+	  #f)
+      (begin
+        (rmt:no-sync-set keyname (conc (current-process-id)))
+        (equal? (conc (current-process-id)) (conc (rmt:no-sync-get/default keyname #f))))))
+
+(define (common:faux-unlock keyname #!key (force #f))
+  (if (or force (equal? (conc (current-process-id)) (conc (rmt:no-sync-get/default keyname #f))))
+      (begin
+        (if (rmt:no-sync-get/default keyname #f) (rmt:no-sync-del! keyname))
+        #t)
+      #f))
+;;======================================================================
+
+;;======================================================================
+;; simple lock. improve and converge on this one.
+;;
+(define (common:simple-lock keyname)
+  (rmt:no-sync-get-lock keyname))
+
+(define (common:simple-unlock keyname #!key (force #f))
+  (rmt:no-sync-del! keyname))
+
+
+(define (common:run-a-command cmd #!key (with-vars #f) (with-orig-env #f))
+  (let* ((pre-cmd  (dtests:get-pre-command))
+         (post-cmd (dtests:get-post-command))
+         (fullcmd  (if (or pre-cmd post-cmd)
+                       (conc pre-cmd cmd post-cmd)
+                       (conc "viewscreen " cmd))))
+    (debug:print-info 02 *default-log-port* "Running command: " fullcmd)
+    (cond
+     (with-vars     (common:without-vars  fullcmd))
+     (with-orig-env (common:with-orig-env fullcmd))
+     (else          (common:without-vars  fullcmd "MT_.*")))))
+
+;;======================================================================
+;; ideally put all this info into the db, no need to preserve it across moving homehost
+;;
+;; return list of
+;;  ( reachable? cpuload update-time )
+(define (common:get-host-info hostname)
+  (let* ((loadinfo                         (rmt:get-latest-host-load hostname)) ;; if this host happens to have been recently used by a test reuse the load data
+         (load                             (car loadinfo))
+         (load-sample-time                 (cdr loadinfo))
+         (load-sample-age                  (- (current-seconds) load-sample-time))
+         (loadinfo-timeout-seconds         6) ;; this was 20 seconds, seems way too lax. Switch to 6 seconds
+         (host-last-update-timeout-seconds 4)
+         (host-rec (hash-table-ref/default *host-loads* hostname #f))
+         )
+    (cond
+     ((< load-sample-age loadinfo-timeout-seconds)
+      (list #t
+            load-sample-time
+            load))
+     ((and host-rec
+           (< (current-seconds) (+ (host-last-update host-rec) host-last-update-timeout-seconds)))
+      (list #t
+            (host-last-update host-rec)
+            (host-last-cpuload host-rec )))
+     ((common:unix-ping hostname)
+      (list #t
+            (current-seconds)
+            (alist-ref 'adj-core-load (common:get-normalized-cpu-load hostname)))) ;; this is cheaper than you might think. get-normalized-cpu-load is cached for up to 5 seconds
+     (else
+      (list #f 0 -1) ;; bad host, don't use!
+      ))))
+
+;;======================================================================
+;; see defstruct host at top of file.
+;;    host: reachable last-update last-used last-cpuload
+;;
+(define (common:update-host-loads-table hosts-raw)
+  (let* ((hosts (filter (lambda (x)
+                          (string-match (regexp "^\\S+$") x))
+                        hosts-raw)))
+    (for-each
+     (lambda (hostname)
+       (let* ((rec       (let ((h (hash-table-ref/default *host-loads* hostname #f)))
+                          (if h
+                              h
+                              (let ((h (make-host)))
+                                (hash-table-set! *host-loads* hostname h)
+                                h))))
+              (host-info         (common:get-host-info hostname))
+              (is-reachable      (car host-info))
+              (last-reached-time (cadr host-info))
+              (load              (caddr host-info)))
+         (host-reachable-set!    rec is-reachable)
+         (host-last-update-set!  rec last-reached-time)
+         (host-last-cpuload-set! rec load)))
+     hosts)))
+
+;;======================================================================
+;; hash-table tree to html list tree
+;;
+;;   tipfunc takes two parameters: y the tip value and path the path to that point
+;;
+(define (common:htree->html ht path tipfunc)
+  (let ((datlist 	(sort (hash-table->alist ht)
+;;======================================================================
+;;======================================================================
+                              (lambda (a b)
+                                (string< (car a)(car b))))))
+    (if (null? datlist)
+    	(tipfunc #f path) ;; really shouldn't get here
+	(s:ul
+	 (map (lambda (x)
+		(let* ((levelname (car x))
+		       (y         (cdr x))
+		       (newpath   (append path (list levelname)))
+		       (leaf      (or (not (hash-table? y))
+				      (null? (hash-table-keys y)))))
+		  (if leaf
+		      (s:li (tipfunc y newpath))
+		      (s:li
+		       (list 
+			levelname
+			(common:htree->html y newpath tipfunc))))))
+	      datlist)))))
+
+;;======================================================================
+;; logic for getting homehost. Returns (host . at-home)
+;; IF *toppath* is not set, wait up to five seconds trying every two seconds
+;; (this is to accomodate the watchdog)
+;;
+(define (common:get-homehost #!key (trynum 5))
+  ;; called often especially at start up. use mutex to eliminate collisions
+  (mutex-lock! *homehost-mutex*)
+  (cond
+   (*home-host*
+    (mutex-unlock! *homehost-mutex*)
+    *home-host*)
+   ((not *toppath*)
+    (mutex-unlock! *homehost-mutex*)
+    (launch:setup) ;; safely mutexed now
+    (if (> trynum 0)
+;;======================================================================
+	(begin
+	  (thread-sleep! 2)
+	  (common:get-homehost trynum: (- trynum 1)))
+	#f))
+   (else
+    (let* ((currhost (get-host-name))
+	   (bestadrs (server:get-best-guess-address currhost))
+	   ;; first look in config, then look in file .homehost, create it if not found
+	   (homehost (or (configf:lookup *configdat* "server" "homehost" )
+			 (handle-exceptions
+			     exn
+			     (if (> trynum 0)
+				 (let ((delay-time (* (- 5 trynum) 5)))
+				   (mutex-unlock! *homehost-mutex*)
+				   (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Failed to read .homehost file, delaying "
+						delay-time " seconds and trying again, message: "  ((condition-property-accessor 'exn 'message) exn)
+						", exn=" exn)
+				   (thread-sleep! delay-time)
+				   (common:get-homehost trynum: (- trynum 1)))
+				 (begin
+				   (mutex-unlock! *homehost-mutex*)
+				   (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)
+						"] Failed to read .homehost file after trying five times. Giving up and exiting, message: "
+						((condition-property-accessor 'exn 'message) exn))
+;;======================================================================
+				   (exit 1)))
+			   (let ((hhf (conc *toppath* "/.homehost")))
+			     (if (common:file-exists? hhf)
+				 (with-input-from-file hhf read-line)
+				 (if (file-write-access? *toppath*)
+				     (begin
+				       (with-output-to-file hhf
+					 (lambda ()
+					   (print bestadrs)))
+				       (begin
+					 (mutex-unlock! *homehost-mutex*)
+					 (car (common:get-homehost))))
+				     #f))))))
+	   (at-home  (or (equal? homehost currhost)
+			 (equal? homehost bestadrs))))
+      (set! *home-host* (cons homehost at-home))
+      (mutex-unlock! *homehost-mutex*)
+      *home-host*))))
+
+;;======================================================================
+;; am I on the homehost?
+;;======================================================================
+;;======================================================================
+;;======================================================================
+;;
+(define (common:on-homehost?)
+  (let ((hh (common:get-homehost)))
+    (if hh
+	(cdr hh)
+	#f)))
+
+;;======================================================================
+;;======================================================================
+;;======================================================================
+;;======================================================================
+;; D A S H B O A R D   U S E R   V I E W S
+;;======================================================================
+
+;;======================================================================
+;; first read ~/views.config if it exists, then read $MTRAH/views.config if it exists
+;;
+(define (common:load-views-config)
+  (let* ((view-cfgdat    (make-hash-table))
+	 (home-cfgfile   (conc (get-environment-variable "HOME") "/.mtviews.config"))
+	 (mthome-cfgfile (conc *toppath* "/.mtviews.config")))
+    (if (common:file-exists? mthome-cfgfile)
+	(read-config mthome-cfgfile view-cfgdat #t))
+    ;; we load the home dir file AFTER the MTRAH file so the user can clobber settings when running the dashboard in read-only areas
+    (if (common:file-exists? home-cfgfile)
+	(read-config home-cfgfile view-cfgdat #t))
+    view-cfgdat))
+
+;;======================================================================
+;; T A R G E T S  ,   S T A T E ,   S T A T U S ,   
+;;                    R U N N A M E    A N D   T E S T P A T T
+;;======================================================================
+
+;;======================================================================
+;; (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")
+						      #f #t)
+					 (make-hash-table))))
+			   string<?))
+	(target-patt (args:get-arg "-target")))
+    (if target-patt
+	(filter (lambda (x)
+		  (patt-list-match x target-patt))
+		targs)
+	targs)))
+
+;;======================================================================
+;; Lookup a value in runconfigs based on -reqtarg or -target
+;; 
+(define (runconfigs-get config var)
+  (let ((targ (common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET"))))
+    (if targ
+	(or (configf:lookup config targ var)
+	    (configf:lookup config "default" var))
+	(configf:lookup config "default" var))))
+
+(define (common:args-get-state)
+  (or (args:get-arg "-state")(args:get-arg ":state")))
+
+(define (common:args-get-status)
+  (or (args:get-arg "-status")(args:get-arg ":status")))
+
+(define (common:args-get-testpatt rconf)
+  (let* (;; (tagexpr       (args:get-arg "-tagexpr"))
+         ;; (tags-testpatt (if tagexpr (string-join (runs:get-tests-matching-tags tagexpr) ",") #f))
+         (testpatt-key  (or (args:get-arg "-modepatt") (args:get-arg "--modepatt") "TESTPATT"))
+         (args-testpatt (or (args:get-arg "-testpatt") (args:get-arg "-runtests") "%"))
+         (rtestpatt     (if rconf (runconfigs-get rconf testpatt-key) #f)))
+    (cond
+     ((or (args:get-arg "--modepatt") (args:get-arg "-modepatt")) ;; modepatt is a forced setting, when set it MUST refer to an existing PATT in the runconfig
+      (if rconf
+	  (let* ((patts-from-mode-patt	  (runconfigs-get rconf testpatt-key)))
+	    (debug:print-info 0 *default-log-port* "modepatt defined is: "testpatt-key" runconfigs values for  " testpatt-key " "  patts-from-mode-patt)
+	    patts-from-mode-patt)
+	  (begin
+	    (debug:print-info 0 *default-log-port* " modepatt defined is: "testpatt-key" runconfigs values for  " testpatt-key) ;;  " " patts-from-mode-patt)
+	    #f)))     ;; We do NOT fall back to "%"
+     ;; (tags-testpatt
+     ;;  (debug:print-info 0 *default-log-port* "-tagexpr "tagexpr" selects testpatt "tags-testpatt)
+     ;;  tags-testpatt)
+     ((and (equal? args-testpatt "%") rtestpatt)
+      (debug:print-info 0 *default-log-port* "testpatt defined in "testpatt-key" from runconfigs: " rtestpatt)
+      rtestpatt)
+     (else 
+      (debug:print-info 0 *default-log-port* "using testpatt " args-testpatt " rtestpatt:" rtestpatt)
+      args-testpatt))))
+
+;;======================================================================
+(define (common:get-linktree)
+  (or (getenv "MT_LINKTREE")
+      (if *configdat*
+	  (configf:lookup *configdat* "setup" "linktree")
+	  #f)
+      (if (or *toppath* (getenv "MT_RUN_AREA_HOME"))
+	  (conc (or *toppath* (getenv "MT_RUN_AREA_HOME")) "/lt")
+	  #f)
+      (let* ((tp (common:get-toppath #f))
+	     (lt (conc tp "/lt")))
+	(if (not tp)(debug:print 0 *default-log-port* "WARNING: cannot calculate best path for linktree, using " lt))
+	lt)))
+
+(define (common:args-get-runname)
+  (let ((res (or (args:get-arg "-runname")
+		 (args:get-arg ":runname")
+		 (getenv "MT_RUNNAME"))))
+    ;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ...
+    res))
+
+(define (std-exit-procedure)
+  ;;(common:telemetry-log-close)
+  (on-exit (lambda () 0))
+  ;;(debug:print-info 13 *default-log-port* "std-exit-procedure called; *time-to-exit*="*time-to-exit*)
+  (let ((no-hurry  (if *time-to-exit* ;; hurry up
+		       #f
+		       (begin
+			 (set! *time-to-exit* #t)
+			 #t))))
+    (debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.")
+    (if (and no-hurry (debug:debug-mode 18))
+	(rmt:print-db-stats))
+    (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds
+                              (if *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated
+			      (if *task-db*    
+				  (let ((db (cdr *task-db*)))
+				    (if (sqlite3:database? db)
+					(begin
+					  (sqlite3:interrupt! db)
+					  (sqlite3:finalize! db #t)
+					  ;; (vector-set! *task-db* 0 #f)
+					  (set! *task-db* #f)))))
+                              (http-client#close-all-connections!)
+                              ;; (if (and *runremote*
+                              ;;          (remote-conndat *runremote*))
+                              ;;     (begin
+                              ;;       (http-client#close-all-connections!))) ;; for http-client
+                              (if (not (eq? *default-log-port* (current-error-port)))
+                                  (close-output-port *default-log-port*))
+			      (set! *default-log-port* (current-error-port))) "Cleanup db exit thread"))
+	  (th2 (make-thread (lambda ()
+			      (debug:print 4 *default-log-port* "Attempting clean exit. Please be patient and wait a few seconds...")
+			      (if no-hurry
+                                  (begin
+                                    (thread-sleep! 5)) ;; give the clean up few seconds to do it's stuff
+                                  (begin
+      				  (thread-sleep! 2)))
+      			      (debug:print 4 *default-log-port* " ... done")
+      			      )
+			    "clean exit")))
+      (thread-start! th1)
+      (thread-start! th2)
+      (thread-join! th1)
+      )
+    )
+
+  0)
+
+;;======================================================================
+;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
+(define (common:watchdog)
+  (debug:print-info 13 *default-log-port* "common:watchdog entered.")
+  (if (launch:setup)
+      (if (common:on-homehost?)
+	  (let ((dbstruct (db:setup #t)))
+	    (debug:print-info 13 *default-log-port* "after db:setup with dbstruct=" dbstruct)
+	    (cond
+	     ((dbr:dbstruct-read-only dbstruct)
+	      (debug:print-info 13 *default-log-port* "loading read-only watchdog")
+	      (common:readonly-watchdog dbstruct))
+	     (else
+	      (debug:print-info 13 *default-log-port* "loading writable-watchdog.")
+              (let* ((syncer (or (configf:lookup *configdat* "server" "sync-method") "brute-force-sync")))
+                (cond
+                 ((equal? syncer "brute-force-sync")
+                  (server:writable-watchdog-bruteforce dbstruct))
+                 ((equal? syncer "delta-sync")
+                  (server:writable-watchdog-deltasync dbstruct))
+                 (else
+                  (debug:print-error 0 *default-log-port* "Unknown server/sync-method specified ("syncer") - valid values are brute-force-sync and delta-sync.")
+                  (exit 1)))
+                ;;(debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] Syncer started (method="syncer")")
+                )))
+	    (debug:print-info 13 *default-log-port* "watchdog done."))
+	  (debug:print-info 13 *default-log-port* "no need for watchdog on non-homehost"))))
+
+(define (common:wait-for-homehost-load maxnormload msg)
+  (let* ((hh-dat (if (common:on-homehost?) ;; if we are on the homehost then pass in #f so the calls are local.
+                     #f
+                     (common:get-homehost)))
+         (hh     (if hh-dat (car hh-dat) #f)))
+    (common:wait-for-normalized-load maxnormload msg hh)))
+
+(define (get-with-default val default)
+  (let ((val (args:get-arg val)))
+    (if val val default)))
+
+(define (common:run-sync?)
+    (and (common:on-homehost?)
+	 (args:get-arg "-server")))
+
+(define (common:args-get-target #!key (split #f)(exit-if-bad #f))
+  (let* ((keys    (if (hash-table? *configdat*) (common:get-fields *configdat*) '()))
+	 (numkeys (length keys))
+	 (target  (or (args:get-arg "-reqtarg")
+		      (args:get-arg "-target")
+		      (getenv "MT_TARGET")))
+	 (tlist   (if target (string-split target "/" #t) '()))
+	 (valid   (if target
+		      (or (null? keys) ;; probably don't know our keys yet
+			  (and (not (null? tlist))
+			       (eq? numkeys (length tlist))
+			       (null? (filter string-null? tlist))))
+		      #f)))
+    (if valid
+	(if split
+	    tlist
+	    target)
+	(if target
+	    (begin
+	      (debug:print-error 0 *default-log-port* "Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements")
+	      (if exit-if-bad (exit 1))
+	      #f)
+	    #f))))
+
+;;======================================================================
+;;======================================================================
+;;======================================================================
+;;======================================================================
+;; do we honor the caches of the config files?
+;;
+(define (common:use-cache?)
+  (let ((res #t)) ;; priority by order of evaluation
+    (if *configdat* ;; sillyness here. can't use setup/use-cache to know if we can use the cached files!
+	(if (equal? (configf:lookup *configdat* "setup" "use-cache") "no")
+	    (set! res #f)
+	    (if (equal? (configf:lookup *configdat* "setup" "use-cache") "yes")
+		(set! res #t))))
+    (if (args:get-arg "-no-cache")(set! res #f)) ;; overrides setting in "setup"
+    (if (getenv "MT_USE_CACHE")
+	(if (equal? (getenv "MT_USE_CACHE") "yes")
+	    (set! res #t)
+	    (if (equal? (getenv "MT_USE_CACHE") "no")
+		(set! res #f))))    ;; overrides -no-cache switch
+    res))
+
+;;======================================================================
+;; force use of server?
+;;
+(define (common:force-server?)
+  (let* ((force-setting (configf:lookup *configdat* "server" "force"))
+	 (force-type    (if force-setting (string->symbol force-setting) #f))
+	 (force-result  (case force-type
+			  ((#f)     #f)
+			  ((always) #t)
+			  ((test)   (if (args:get-arg "-execute") ;; we are in a test
+					#t
+					#f))
+			  (else
+			   (debug:print 0 *default-log-port* "ERROR: Bad server force setting " force-setting ", forcing server.")
+			   #t)))) ;; default to requiring server
+    (if force-result
+	(begin
+	  (debug:print-info 0 *default-log-port* "forcing use of server, force setting is \"" force-setting "\".")
+	  #t)
+	#f)))
+
+(define (common:in-running-test?)
+  (and (args:get-arg "-execute") (get-environment-variable "MT_CMDINFO")))
+;;======================================================================
+;;======================================================================
+;;======================================================================
+;;======================================================================
+;;======================================================================
+;;======================================================================
+;;======================================================================
+;;======================================================================
+;;======================================================================
+
+(define (debug:setup debug-arg verbose-arg) ;; debug-arg= #f, #t or 'noprop
+  (let ((debugstr (or debug-arg ;; (args:get-arg "-debug")
+		      ;; (args:get-arg "-debug-noprop")
+		      (get-environment-variable "MT_DEBUG_MODE"))))
+    (debug:calc-verbosity debugstr verbose-arg)
+    ;; (debug:check-verbosity *verbosity* debugstr)
+    ;; if we were handed a bad verbosity rule then we will override it with 1 and continue
+    (if (not (verbosity))(set! (verbosity) 1))
+    (if (and (not (eq? debug-arg 'noprop))
+	     (or debug-arg
+		 (not (get-environment-variable "MT_DEBUG_MODE"))))
+	(setenv "MT_DEBUG_MODE" (if (list? (verbosity))
+				    (string-intersperse (map conc (verbosity)) ",")
+				    (conc (verbosity)))))))
+
+;;======================================================================
+;;======================================================================
+;;======================================================================
+;;======================================================================
+;;======================================================================
+;;======================================================================
+;;======================================================================
+
+;;======================================================================
+;;======================================================================
+;;======================================================================
+;;======================================================================
+;;======================================================================
+;;======================================================================
+;;======================================================================
+;; go through the hosts from least recently used to most recently used, pick the first that meets the load criteral from the
+;; [host-rules] section.
+;;
+(define (common:get-least-loaded-host hosts-raw host-type configdat)
+  (let* ((rdat       (configf:lookup configdat "host-rules" host-type))
+	 (rules      (common:val->alist (or rdat "") convert: #t))   ;; maxnload, maxnjobs, maxjobrate
+	 (maxnload   (common:alist-ref/default 'maxnload rules 1.5)) ;; max normalized load
+	 (maxnjobs   (common:alist-ref/default 'maxnjobs rules 1.5)) ;; max normalized number of jobs
+	 (maxjobrate (common:alist-ref/default 'maxjobrate rules (/ 1 6))) ;; max rate of submitting jobs to a given host in jobs/second
+	 (hosts      (filter (lambda (x)
+			       (string-match (regexp "^\\S+$") x))
+			     hosts-raw))
+         ;; (best-host #f)
+	 (get-rec    (lambda (hostname)
+		       ;; (print "get-rec hostname=" hostname)
+		       (let ((h (hash-table-ref/default *host-loads* hostname #f)))
+			 (if h
+			     h
+			     (let ((h (make-host)))
+			       (hash-table-set! *host-loads* hostname h)
+			       h)))))
+         (best-load 99999)
+         (curr-time (current-seconds))
+	 (get-hosts-sorted (lambda (hosts)
+			     (sort hosts (lambda (a b)
+					   (let ((a-rec (get-rec a))
+						 (b-rec (get-rec b)))
+					     ;; (print "a=" a " a-rec=" a-rec " host-last-used=" (host-last-used a-rec))
+					     ;; (print "b=" b " b-rec=" b-rec " host-last-used=" (host-last-used b-rec))
+					     (< (host-last-used a-rec)
+						(host-last-used b-rec))))))))
+    (debug:print 0 *default-log-port* "INFO: hosts-sorted=" (get-hosts-sorted hosts))
+    (if (null? hosts)
+	#f ;; no hosts to select from. All done and giving up now.
+	(let ((hosts-sorted (get-hosts-sorted hosts)))
+	  (common:update-host-loads-table hosts)
+	  (let loop ((hostname  (car hosts-sorted))
+		     (tal       (cdr hosts-sorted))
+		     (best-host #f))
+	    (let* ((rec       (get-rec hostname))
+		   (reachable (host-reachable     rec))
+		   (load      (host-last-cpuload  rec))
+		   (last-used (host-last-used     rec))
+		   (delta     (- curr-time last-used))
+		   (job-rate  (if (> delta 0)
+				  (/ 1 delta)
+				  999)) ;; jobs per second
+		   (new-best  
+		    (cond
+		     ((not reachable)
+		      (debug:print 0 *default-log-port* "Skipping host " hostname " as it cannot be reached.")
+		      best-host)
+		     ((and (< load maxnload)        ;; load is acceptable
+			   (< job-rate maxjobrate)) ;; job rate is acceptable
+		      (set! best-load load)
+		      hostname)
+		     (else best-host))))
+	      (debug:print 0 *default-log-port* "INFO: Trying host " hostname " with load " load ", last used " delta " seconds ago, with job-rate " job-rate " for running a test." )
+	      (if new-best
+		  (begin ;; found a host, return it
+		    (debug:print 0 *default-log-port* "INFO: Found host: " new-best " load: " load " last-used: " delta " seconds ago, with job-rate: " job-rate)
+		    (host-last-used-set! rec curr-time)
+		    new-best)
+		  (if (null? tal) #f (loop (car tal)(cdr tal) best-host)))))))))
+
+;;======================================================================
+;; '(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))
+   "disks" '("none" "")))
+
+;;======================================================================
+;; currently the primary job of the watchdog is to run the sync back to megatest.db from the db in /tmp
+;; if we are on the homehost and we are a server (by definition we are on the homehost if we are a server)
+;;
+(define (common:readonly-watchdog dbstruct)
+  (thread-sleep! 0.05) ;; delay for startup
+  (debug:print-info 13 *default-log-port* "common:readonly-watchdog entered.")
+  ;; sync megatest.db to /tmp/.../megatst.db
+  (let* ((sync-cool-off-duration   3)
+        (golden-mtdb     (dbr:dbstruct-mtdb dbstruct))
+        (golden-mtpath   (db:dbdat-get-path golden-mtdb))
+        (tmp-mtdb        (dbr:dbstruct-tmpdb dbstruct))
+        (tmp-mtpath      (db:dbdat-get-path tmp-mtdb)))
+    (debug:print-info 0 *default-log-port* "Read-only periodic sync thread started.")
+    (let loop ((last-sync-time 0))
+      (debug:print-info 13 *default-log-port* "loop top tmp-mtpath="tmp-mtpath" golden-mtpath="golden-mtpath)
+      (let* ((duration-since-last-sync (- (current-seconds) last-sync-time)))
+        (debug:print-info 13 *default-log-port* "duration-since-last-sync="duration-since-last-sync)
+        (if (and (not *time-to-exit*)
+                 (< duration-since-last-sync sync-cool-off-duration))
+            (thread-sleep! (- sync-cool-off-duration duration-since-last-sync)))
+        (if (not *time-to-exit*)
+            (let ((golden-mtdb-mtime (file-modification-time golden-mtpath))
+                  (tmp-mtdb-mtime    (file-modification-time tmp-mtpath)))
+	      (if (> golden-mtdb-mtime tmp-mtdb-mtime)
+		  (if (< golden-mtdb-mtime (- (current-seconds) 3)) ;; file has NOT been touched in past three seconds, this way multiple servers won't fight to sync back
+		      (let ((res (db:multi-db-sync dbstruct 'old2new)))
+			(debug:print-info 13 *default-log-port* "rosync called, " res " records transferred."))))
+              (loop (current-seconds)))
+            #t)))
+    (debug:print-info 0 *default-log-port* "Exiting readonly-watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" mtpath="golden-mtpath)))
+
+;;======================================================================
+;; Force a megatest cleanup-db if version is changed and skip-version-check not specified
+;; Do NOT check if not on homehost!
+;;
+(define (common:exit-on-version-changed)
+  (if (common:on-homehost?)
+      (if (common:api-changed?)
+	  (let* ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config"))
+                (dbfile  (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.db"))
+                (read-only (not (file-write-access? dbfile)))
+                (dbstruct (db:setup #t)))
+	    (debug:print 0 *default-log-port*
+			 "WARNING: Version mismatch!\n"
+			 "   expected: " (common:version-signature) "\n"
+			 "   got:      " (common:get-last-run-version))
+            (cond
+             ((get-environment-variable "MT_SKIP_DB_MIGRATE") #t)
+             ((and (common:file-exists? mtconf) (common:file-exists? dbfile) (not read-only)
+                   (eq? (current-user-id)(file-owner mtconf))) ;; safe to run -cleanup-db
+              (debug:print 0 *default-log-port* "   I see you are the owner of megatest.config, attempting to cleanup and reset to new version")
+              (handle-exceptions
+               exn
+               (begin
+                 (debug:print 0 *default-log-port* "Failed to switch versions. exn=" exn)
+                 (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+                 (print-call-chain (current-error-port))
+                 (exit 1))
+               (common:cleanup-db dbstruct)))
+             ((not (common:file-exists? mtconf))
+              (debug:print 0 *default-log-port* "   megatest.config does not exist in this area.  Cannot proceed with megatest version migration.")
+              (exit 1))
+             ((not (common:file-exists? dbfile))
+              (debug:print 0 *default-log-port* "   megatest.db does not exist in this area.  Cannot proceed with megatest version migration.")
+              (exit 1))
+             ((not (eq? (current-user-id)(file-owner mtconf)))
+              (debug:print 0 *default-log-port* "   You do not own megatest.db in this area.  Cannot proceed with megatest version migration.")
+              (exit 1))
+             (read-only
+              (debug:print 0 *default-log-port* "   You have read-only access to this area.  Cannot proceed with megatest version migration.")
+              (exit 1))
+             (else
+              (debug:print 0 *default-log-port* " to switch versions you can run: \"megatest -cleanup-db\"")
+              (exit 1)))))))
+;;======================================================================
+;;      (begin
+;;	(debug:print 0 *default-log-port* "ERROR: cannot migrate version unless on homehost. Exiting.")
+;;	(exit 1))))
 
 ;;======================================================================
 ;; Rotate logs, logic: 
 ;;                 if > 500k and older than 1 week:
 ;;                     remove previous compressed log and compress this log
@@ -582,1220 +845,11 @@
 		      exn
 		      (debug:print-error 0 *default-log-port* "failed to remove " fullname ", exn=" exn)
 		      (delete-file* fullname)))))
 	     files)
 	    (debug:print-info 0 *default-log-port* "Deleted " (length files) " files from logs, keeping " max-allowed " files."))))))
-
-;;======================================================================
-;; Force a megatest cleanup-db if version is changed and skip-version-check not specified
-;; Do NOT check if not on homehost!
-;;
-(define (common:exit-on-version-changed)
-  (if (common:on-homehost?)
-      (if (common:api-changed?)
-	  (let* ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config"))
-                (dbfile  (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.db"))
-                (read-only (not (file-write-access? dbfile)))
-                (dbstruct (db:setup #t)))
-	    (debug:print 0 *default-log-port*
-			 "WARNING: Version mismatch!\n"
-			 "   expected: " (common:version-signature) "\n"
-			 "   got:      " (common:get-last-run-version))
-            (cond
-             ((get-environment-variable "MT_SKIP_DB_MIGRATE") #t)
-             ((and (common:file-exists? mtconf) (common:file-exists? dbfile) (not read-only)
-                   (eq? (current-user-id)(file-owner mtconf))) ;; safe to run -cleanup-db
-              (debug:print 0 *default-log-port* "   I see you are the owner of megatest.config, attempting to cleanup and reset to new version")
-              (handle-exceptions
-               exn
-               (begin
-                 (debug:print 0 *default-log-port* "Failed to switch versions. exn=" exn)
-                 (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
-                 (print-call-chain (current-error-port))
-                 (exit 1))
-               (common:cleanup-db dbstruct)))
-             ((not (common:file-exists? mtconf))
-              (debug:print 0 *default-log-port* "   megatest.config does not exist in this area.  Cannot proceed with megatest version migration.")
-              (exit 1))
-             ((not (common:file-exists? dbfile))
-              (debug:print 0 *default-log-port* "   megatest.db does not exist in this area.  Cannot proceed with megatest version migration.")
-              (exit 1))
-             ((not (eq? (current-user-id)(file-owner mtconf)))
-              (debug:print 0 *default-log-port* "   You do not own megatest.db in this area.  Cannot proceed with megatest version migration.")
-              (exit 1))
-             (read-only
-              (debug:print 0 *default-log-port* "   You have read-only access to this area.  Cannot proceed with megatest version migration.")
-              (exit 1))
-             (else
-              (debug:print 0 *default-log-port* " to switch versions you can run: \"megatest -cleanup-db\"")
-              (exit 1)))))))
-;;======================================================================
-;;      (begin
-;;	(debug:print 0 *default-log-port* "ERROR: cannot migrate version unless on homehost. Exiting.")
-;;	(exit 1))))
-
-;;======================================================================
-;; S P A R S E   A R R A Y S
-;;======================================================================
-
-(define (make-sparse-array)
-  (let ((a (make-sparse-vector)))
-    (sparse-vector-set! a 0 (make-sparse-vector))
-    a))
-
-(define (sparse-array? a)
-  (and (sparse-vector? a)
-       (sparse-vector? (sparse-vector-ref a 0))))
-
-(define (sparse-array-ref a x y)
-  (let ((row (sparse-vector-ref a x)))
-    (if row
-	(sparse-vector-ref row y)
-	#f)))
-
-(define (sparse-array-set! a x y val)
-  (let ((row (sparse-vector-ref a x)))
-    (if row
-	(sparse-vector-set! row y val)
-	(let ((new-row (make-sparse-vector)))
-	  (sparse-vector-set! a x new-row)
-	  (sparse-vector-set! new-row y val)))))
-
-;;======================================================================
-;; L O C K E R S   A N D   B L O C K E R S 
-;;======================================================================
-
-;; block further accesses to databases. Call this before shutting db down
-(define (common:db-block-further-queries)
-  (mutex-lock! *db-access-mutex*)
-  (set! *db-access-allowed* #f)
-  (mutex-unlock! *db-access-mutex*))
-
-(define (common:db-access-allowed?)
-  (let ((val (begin
-	       (mutex-lock! *db-access-mutex*)
-	       *db-access-allowed*
-	       (mutex-unlock! *db-access-mutex*))))
-    val))
-
-;;======================================================================
-;; U S E F U L   S T U F F
-;;======================================================================
-
-;; convert things to an alist or assoc list, #f gets converted to ""
-;;
-(define (common:to-alist dat)
-  (cond
-   ((list? dat)   (map common:to-alist dat))
-   ((vector? dat)
-    (map common:to-alist (vector->list dat)))
-   ((pair? dat)
-    (cons (common:to-alist (car dat))
-	  (common:to-alist (cdr dat))))
-   ((hash-table? dat)
-    (map common:to-alist (hash-table->alist dat)))
-   (else
-    (if dat
-	dat
-	""))))
-
-(define (common:alist-ref/default key alist default)
-  (or (alist-ref key alist) default))
-
-(define (common:low-noise-print waitval . keys)
-  (let* ((key      (string-intersperse (map conc keys) "-" ))
-	 (lasttime (hash-table-ref/default *common:denoise* key 0))
-	 (currtime (current-seconds)))
-    (if (> (- currtime lasttime) waitval)
-	(begin
-	  (hash-table-set! *common:denoise* key currtime)
-	  #t)
-	#f)))
-
-(define (common:get-megatest-exe)
-  (or (getenv "MT_MEGATEST") "megatest"))
-
-(define (common:read-encoded-string instr)
-  (handle-exceptions
-   exn
-   (handle-exceptions
-    exn
-    (begin
-      (debug:print-error 0 *default-log-port* "received bad encoded string \"" instr "\", message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
-      (print-call-chain (current-error-port))
-      #f)
-    (read (open-input-string (base64:base64-decode instr))))
-   (read (open-input-string (z3:decode-buffer (base64:base64-decode instr))))))
-
-;; dot-locking egg seems not to work, using this for now
-;; if lock is older than expire-time then remove it and try again
-;; to get the lock
-;;
-(define (common:simple-file-lock fname #!key (expire-time 300))
-  (let ((fmod-time (handle-exceptions
-		       ext
-		     (current-seconds)
-		     (file-modification-time fname))))
-    (if (common:file-exists? fname)
-	(if (> (- (current-seconds) fmod-time) expire-time)
-	    (begin
-	      (handle-exceptions exn #f (delete-file* fname))	
-	      (common:simple-file-lock fname expire-time: expire-time))
-	    #f)
-	(let ((key-string (conc (get-host-name) "-" (current-process-id))))
-	  (with-output-to-file fname
-	    (lambda ()
-	      (print key-string)))
-	  (thread-sleep! 0.25)
-	  (if (common:file-exists? fname)
-	      (handle-exceptions exn
-                #f 
-                (with-input-from-file fname
-	  	  (lambda ()
-		    (equal? key-string (read-line)))))
-	      #f)))))
-
-(define (common:simple-file-lock-and-wait fname #!key (expire-time 300))
-  (let ((end-time (+ expire-time (current-seconds))))
-    (let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time)))
-      (if got-lock
-	  #t
-	  (if (> end-time (current-seconds))
-	      (begin
-		(thread-sleep! 3)
-		(loop (common:simple-file-lock fname expire-time: expire-time)))
-	      #f)))))
-
-(define (common:simple-file-release-lock fname)
-  (handle-exceptions
-      exn
-      #f ;; I don't really care why this failed (at least for now)
-    (delete-file* fname)))
-
-;;======================================================================
-;; S T A T E S   A N D   S T A T U S E S
-;;======================================================================
-
-;; BBnote: *common:std-states* - dashboard filter control and test control state buttons defined here; used in set-fields-panel and dboard:make-controls
-(define *common:std-states*   ;; for toggle buttons in dashboard
-  '(
-    (0 "ARCHIVED")
-    (1 "STUCK")
-    (2 "KILLREQ")
-    (3 "KILLED")
-    (4 "NOT_STARTED")
-    (5 "COMPLETED")
-    (6 "LAUNCHED")
-    (7 "REMOTEHOSTSTART")
-    (8 "RUNNING")
-    ))
-
-(define *common:dont-roll-up-states*
-  '("DELETED"
-    "REMOVING"
-    "CLEANING"
-    "ARCHIVE_REMOVING"
-    ))
-
-;;======================================================================
-;; BBnote: *common:std-statuses* dashboard filter control and test control status buttons defined here; used in set-fields-panel and dboard:make-controls
-;; note these statuses are sorted from better to worse.
-;; This sort order is important to dcommon:status-compare3 and db:set-state-status-and-roll-up-items
-(define *common:std-statuses*
-  '(;; (0 "DELETED")  
-    (1 "n/a")
-    (2 "PASS")
-    (3 "SKIP")
-    (4 "WARN")
-    (5 "WAIVED")
-    (6 "CHECK")
-    (7 "STUCK/DEAD")
-    (8 "DEAD")
-    (9 "FAIL")
-    (10 "PREQ_FAIL")
-    (11 "PREQ_DISCARDED")
-    (12 "ABORT")))
-
-(define *common:ended-states*       ;; states which indicate the test is stopped and will not proceed
-  '("COMPLETED" "ARCHIVED" "KILLED" "KILLREQ" "STUCK" "INCOMPLETE" ))
-
-(define *common:badly-ended-states* ;; these roll up as CHECK, i.e. results need to be checked
-  '("KILLED" "KILLREQ" "STUCK" "INCOMPLETE" "DEAD"))
-
-(define *common:well-ended-states* ;; an item's prereq in this state allows item to proceed
-  '("PASS" "WARN" "CHECK" "WAIVED" "SKIP"))
-
-;; BBnote: *common:running-states* used from db:set-state-status-and-roll-up-items
-(define *common:running-states*     ;; test is either running or can be run
-  '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "STARTED"))
-
-(define *common:cant-run-states*    ;; These are stopping conditions that prevent a test from being run
-  '("COMPLETED" "KILLED" "UNKNOWN" "INCOMPLETE" "ARCHIVED"))
-
-(define *common:not-started-ok-statuses* ;; if not one of these statuses when in not_started state treat as dead
-  '("n/a" "na" "PASS" "FAIL" "WARN" "CHECK" "WAIVED" "DEAD" "SKIP"))
-
-;;======================================================================
-;; group tests into buckets corresponding to rollup
-;;; Running, completed-pass,  completed-non-pass + worst status, not started.
-;; filter out 
-;(define (common:categorize-items-for-rollup in-tests)
-;  (
-
-(define (common:special-sort items order comp)
-  (let ((items-order (map reverse order))
-        (acomp       (or comp >)))
-    (sort items
-        (lambda (a b)
-          (let ((a-num (cadr (or (assoc a items-order) '(0 0))))
-                (b-num (cadr (or (assoc b items-order) '(0 0)))))
-            (acomp a-num b-num))))))
-
-;;======================================================================
-;; ;; given a toplevel with currstate, currstatus apply state and status
-;; ;;  => (newstate . newstatus)
-;; (define (common:apply-state-status currstate currstatus state status)
-;;   (let* ((cstate  (string->symbol (string-downcase currstate)))
-;;          (cstatus (string->symbol (string-downcase currstatus)))
-;;          (sstate  (string->symbol (string-downcase state)))
-;;          (sstatus (string->symbol (string-downcase status)))
-;;          (nstate  #f)
-;;          (nstatus #f))
-;;     (set! nstate
-;;           (case cstate
-;;             ((completed not_started killed killreq stuck archived) 
-;;              (case sstate ;; completed -> sstate
-;;                ((completed killed killreq stuck archived) completed)
-;;                ((running remotehoststart launched)        running)
-;;                (else                                      unknown-error-1)))
-;;             ((running remotehoststart launched)
-;;              (case sstate
-;;                ((completed killed killreq stuck archived) #f) ;; need to look at all items
-;;                ((running remotehoststart launched)        running)
-;;                (else                                      unknown-error-2)))
-;;             (else unknown-error-3)))
-;;     (set! nstatus
-;;           (case sstatus
-;;             ((pass)
-;;              (case nstate
-;;                ((pass n/a deleted)     pass)
-;;                ((warn)                 warn)
-;;                ((fail)                 fail)
-;;                ((check)               check)
-;;                ((waived)             waived)
-;;                ((skip)                 skip)
-;;                ((stuck/dead)          stuck)
-;;                ((abort)               abort)
-;;                (else        unknown-error-4)))
-;;             ((warn)
-;;              (case nstate
-;;                ((pass warn n/a skip deleted)   warn)
-;;                ((fail)                         fail)
-;;                ((check)                       check)
-;;                ((waived)                     waived)
-;;                ((stuck/dead)                  stuck)
-;;                (else                unknown-error-5)))
-;;             ((fail)
-;;              (case nstate
-;;                ((pass warn fail check n/a waived skip deleted stuck/dead stuck)  fail)
-;;                ((abort)                                                         abort)
-;;                (else                                                  unknown-error-6)))
-;;             (else    unknown-error-7)))
-;;     (cons 
-;;      (if nstate  (symbol->string nstate)  nstate)
-;;      (if nstatus (symbol->string nstatus) nstatus))))
-               
-;;======================================================================
-;; D E B U G G I N G   S T U F F 
-;;======================================================================
-
-(define *verbosity*         1)
-(define *logging*           #f)
-
-(define (get-with-default val default)
-  (let ((val (args:get-arg val)))
-    (if val val default)))
-
-(define (assoc/default key lst . default)
-  (let ((res (assoc key lst)))
-    (if res (cadr res)(if (null? default) #f (car default)))))
-
-(define (common:get-testsuite-name)
-  (or (configf:lookup *configdat* "setup" "area-name") ;; megatest is a flexible tool, testsuite is too limiting a description.
-      (configf:lookup *configdat* "setup" "testsuite" )
-      (getenv "MT_TESTSUITE_NAME")
-      (pathname-file (or (if (string? *toppath* )
-			     (pathname-file *toppath*)
-			     #f)
-			 (common:get-toppath #f)))
-      "please-set-setup-area-name")) ;; (pathname-file (current-directory)))))
-
-;;======================================================================
-;; safe getting of toppath
-(define (common:get-toppath areapath)
-  (or *toppath*
-      (if areapath
-	  (begin
-	    (set! *toppath* areapath)
-	    (setenv "MT_RUN_AREA_HOME" areapath)
-	    areapath)
-	  #f)
-      (if (getenv "MT_RUN_AREA_HOME")
-	  (begin
-	    (set! *toppath* (getenv "MT_RUN_AREA_HOME"))
-	    *toppath*)
-	  #f)
-      ;; last resort, look for megatest.config
-      (let loop ((thepath (realpath ".")))
-	(if (file-exists? (conc thepath "/megatest.config"))
-	    thepath
-	    (if (equal? thepath "/")
-		(begin
-		  (debug:print-error 0 *default-log-port* "Unable to find megatest home directory.")
-		  #f)
-		(loop (pathname-directory thepath)))))
-      ))
-
-;;======================================================================
-;; redefine for future cleanup (converge on area-name, the more generic
-;;
-(define common:get-area-name common:get-testsuite-name)
-
-(define (common:get-db-tmp-area . junk)
-  (if *db-cache-path*
-      *db-cache-path*
-      (if *toppath* ;; common:get-create-writeable-dir
-	  (handle-exceptions
-	      exn
-	      (begin
-		(debug:print-error 0 *default-log-port* "Couldn't create path to " *db-cache-path* ", exn=" exn)
-		(exit 1))
-	      (let* ((tsname (common:get-testsuite-name))
-		     (dbpath (common:get-create-writeable-dir
-			      (list (conc "/tmp/" (current-user-name)
-					  "/megatest_localdb/"
-					  tsname "/"
-					  (string-translate *toppath* "/" "."))
-				    (conc "/tmp/" (current-process-id) ;; just in case we have an issue with the dir by own user name
-					  "/megatest_localdb/"
-					  tsname
-					  (string-translate *toppath* "/" "."))
-				    ))))
-		(set! *db-cache-path* dbpath)
-		dbpath))
-	  #f)))
-
-(define (common:get-area-path-signature)
-  (message-digest-string (md5-primitive) *toppath*))
-
-(define (common:get-signature str)
-  (message-digest-string (md5-primitive) str))
-
-;;======================================================================
-;; E X I T   H A N D L I N G
-;;======================================================================
-
-(define (common:run-sync?)
-    (and (common:on-homehost?)
-	 (args:get-arg "-server")))
-
-(define (common:human-time)
-  (time->string (seconds->local-time (current-seconds)) "%Y-%m-%d %H:%M:%S"))
-
-;;======================================================================
-;; currently the primary job of the watchdog is to run the sync back to megatest.db from the db in /tmp
-;; if we are on the homehost and we are a server (by definition we are on the homehost if we are a server)
-;;
-(define (common:readonly-watchdog dbstruct)
-  (thread-sleep! 0.05) ;; delay for startup
-  (debug:print-info 13 *default-log-port* "common:readonly-watchdog entered.")
-  ;; sync megatest.db to /tmp/.../megatst.db
-  (let* ((sync-cool-off-duration   3)
-        (golden-mtdb     (dbr:dbstruct-mtdb dbstruct))
-        (golden-mtpath   (db:dbdat-get-path golden-mtdb))
-        (tmp-mtdb        (dbr:dbstruct-tmpdb dbstruct))
-        (tmp-mtpath      (db:dbdat-get-path tmp-mtdb)))
-    (debug:print-info 0 *default-log-port* "Read-only periodic sync thread started.")
-    (let loop ((last-sync-time 0))
-      (debug:print-info 13 *default-log-port* "loop top tmp-mtpath="tmp-mtpath" golden-mtpath="golden-mtpath)
-      (let* ((duration-since-last-sync (- (current-seconds) last-sync-time)))
-        (debug:print-info 13 *default-log-port* "duration-since-last-sync="duration-since-last-sync)
-        (if (and (not *time-to-exit*)
-                 (< duration-since-last-sync sync-cool-off-duration))
-            (thread-sleep! (- sync-cool-off-duration duration-since-last-sync)))
-        (if (not *time-to-exit*)
-            (let ((golden-mtdb-mtime (file-modification-time golden-mtpath))
-                  (tmp-mtdb-mtime    (file-modification-time tmp-mtpath)))
-	      (if (> golden-mtdb-mtime tmp-mtdb-mtime)
-		  (if (< golden-mtdb-mtime (- (current-seconds) 3)) ;; file has NOT been touched in past three seconds, this way multiple servers won't fight to sync back
-		      (let ((res (db:multi-db-sync dbstruct 'old2new)))
-			(debug:print-info 13 *default-log-port* "rosync called, " res " records transferred."))))
-              (loop (current-seconds)))
-            #t)))
-    (debug:print-info 0 *default-log-port* "Exiting readonly-watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" mtpath="golden-mtpath)))
-
-;;======================================================================
-;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
-(define (common:watchdog)
-  (debug:print-info 13 *default-log-port* "common:watchdog entered.")
-  (if (launch:setup)
-      (if (common:on-homehost?)
-	  (let ((dbstruct (db:setup #t)))
-	    (debug:print-info 13 *default-log-port* "after db:setup with dbstruct=" dbstruct)
-	    (cond
-	     ((dbr:dbstruct-read-only dbstruct)
-	      (debug:print-info 13 *default-log-port* "loading read-only watchdog")
-	      (common:readonly-watchdog dbstruct))
-	     (else
-	      (debug:print-info 13 *default-log-port* "loading writable-watchdog.")
-              (let* ((syncer (or (configf:lookup *configdat* "server" "sync-method") "brute-force-sync")))
-                (cond
-                 ((equal? syncer "brute-force-sync")
-                  (server:writable-watchdog-bruteforce dbstruct))
-                 ((equal? syncer "delta-sync")
-                  (server:writable-watchdog-deltasync dbstruct))
-                 (else
-                  (debug:print-error 0 *default-log-port* "Unknown server/sync-method specified ("syncer") - valid values are brute-force-sync and delta-sync.")
-                  (exit 1)))
-                ;;(debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] Syncer started (method="syncer")")
-                )))
-	    (debug:print-info 13 *default-log-port* "watchdog done."))
-	  (debug:print-info 13 *default-log-port* "no need for watchdog on non-homehost"))))
-
-
-(define (std-exit-procedure)
-  ;;(common:telemetry-log-close)
-  (on-exit (lambda () 0))
-  ;;(debug:print-info 13 *default-log-port* "std-exit-procedure called; *time-to-exit*="*time-to-exit*)
-  (let ((no-hurry  (if *time-to-exit* ;; hurry up
-		       #f
-		       (begin
-			 (set! *time-to-exit* #t)
-			 #t))))
-    (debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.")
-    (if (and no-hurry (debug:debug-mode 18))
-	(rmt:print-db-stats))
-    (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds
-                              (if *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated
-			      (if *task-db*    
-				  (let ((db (cdr *task-db*)))
-				    (if (sqlite3:database? db)
-					(begin
-					  (sqlite3:interrupt! db)
-					  (sqlite3:finalize! db #t)
-					  ;; (vector-set! *task-db* 0 #f)
-					  (set! *task-db* #f)))))
-                              (http-client#close-all-connections!)
-                              ;; (if (and *runremote*
-                              ;;          (remote-conndat *runremote*))
-                              ;;     (begin
-                              ;;       (http-client#close-all-connections!))) ;; for http-client
-                              (if (not (eq? *default-log-port* (current-error-port)))
-                                  (close-output-port *default-log-port*))
-			      (set! *default-log-port* (current-error-port))) "Cleanup db exit thread"))
-	  (th2 (make-thread (lambda ()
-			      (debug:print 4 *default-log-port* "Attempting clean exit. Please be patient and wait a few seconds...")
-			      (if no-hurry
-                                  (begin
-                                    (thread-sleep! 5)) ;; give the clean up few seconds to do it's stuff
-                                  (begin
-      				  (thread-sleep! 2)))
-      			      (debug:print 4 *default-log-port* " ... done")
-      			      )
-			    "clean exit")))
-      (thread-start! th1)
-      (thread-start! th2)
-      (thread-join! th1)
-      )
-    )
-
-  0)
-
-(define (std-signal-handler signum)
-  ;; (signal-mask! signum)
-  (set! *time-to-exit* #t) 
-  ;;(debug:print-info 13 *default-log-port* "got signal "signum)
-  (debug:print-error 0 *default-log-port* "Received signal " signum " aaa exiting promptly")
-  ;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway
-  (exit))
-
-(define (special-signal-handler signum)
-  ;; (signal-mask! signum)
-  (set! *time-to-exit* #t)
-  ;;(debug:print-info 13 *default-log-port* "got signal "signum)
-  (debug:print-error 0 *default-log-port* "Received signal " signum " sending email befor exiting!!")
-  ;;TODO send email to notify admin contact listed in the config that the lisner got killed
-  ;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway
-  (exit))
-
-
-(set-signal-handler! signal/int  std-signal-handler)  ;; ^C
-(set-signal-handler! signal/term std-signal-handler)
-
-;; (set-signal-handler! signal/stop std-signal-handler)  ;; ^Z NO, do NOT handle ^Z!
-
-;;======================================================================
-;; M I S C   U T I L S
-;;======================================================================
-
-;;======================================================================
-;; convert stuff to a number if possible
-(define (any->number val)
-  (cond 
-   ((number? val) val)
-   ((string? val) (string->number val))
-   ((symbol? val) (any->number (symbol->string val)))
-   (else #f)))
-
-(define (any->number-if-possible val)
-  (let ((num (any->number val)))
-    (if num num val)))
-
-(define (patt-list-match item patts)
-  (debug:print-info 8 *default-log-port* "patt-list-match item=" item " patts=" patts)
-  (if (and item patts)  ;; here we are filtering for matches with item patterns
-      (let ((res #f))   ;; look through all the item-patts if defined, format is patt1,patt2,patt3 ... wildcard is %
-	(for-each 
-	 (lambda (patt)
-	   (let ((modpatt (string-substitute "%" ".*" patt #t)))
-	     (debug:print-info 10 *default-log-port* "patt " patt " modpatt " modpatt)
-	     (if (string-match (regexp modpatt) item)
-		 (set! res #t))))
-	 (string-split patts ","))
-	res)
-      #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))
-   "disks" '("none" "")))
-
-;;======================================================================
-;; return first command that exists, else #f
-;;
-(define (common:which cmds)
-  (if (null? cmds)
-      #f
-      (let loop ((hed (car cmds))
-		 (tal (cdr cmds)))
-	(let ((res (with-input-from-pipe (conc "which " hed) read-line)))
-	  (if (and (string? res)
-		   (common:file-exists? res))
-	      res
-	      (if (null? tal)
-		  #f
-		  (loop (car tal)(cdr tal))))))))
-  
-(define (common:get-install-area)
-  (let ((exe-path (car (argv))))
-    (if (common:file-exists? exe-path)
-	(handle-exceptions
-	 exn
-	 #f
-	 (pathname-directory
-	  (pathname-directory 
-	   (pathname-directory exe-path))))
-	#f)))
-
-;;======================================================================
-;; return first path that can be created or already exists and is writable
-;;
-(define (common:get-create-writeable-dir dirs)
-  (if (null? dirs)
-      #f
-      (let loop ((hed (car dirs))
-		 (tal (cdr dirs)))
-	(let ((res (or (and (directory? hed)
-			    (file-write-access? hed)
-			    hed)
-		       (handle-exceptions
-			   exn
-			   (begin
-			     (debug:print-info 0 *default-log-port* "could not create " hed
-					       ", this might cause problems down the road. exn=" exn)
-			     #f)
-			(create-directory hed #t)))))
-	  (if (and (string? res)
-		   (directory? res))
-	      res
-	      (if (null? tal)
-		  #f
-		  (loop (car tal)(cdr tal))))))))
-
-;;======================================================================
-;; return the youngest timestamp . filename
-;;
-(define (common:get-youngest glob-list)
-  (let ((all-files (apply append
-			  (map (lambda (patt)
-				 (handle-exceptions
-				     exn
-				     '()
-				   (glob patt)))
-			       glob-list))))
-    (fold (lambda (fname res)
-	    (let ((last-mod (car res))
-		  (curmod   (handle-exceptions
-				exn
-				0
-			      (file-modification-time fname))))
-	      (if (> curmod last-mod)
-		  (list curmod fname)
-		  res)))
-	  '(0 "n/a")
-	  all-files)))
-
-;;======================================================================
-;; use bash to expand a glob. Does NOT handle paths with spaces!
-;;
-(define (common:bash-glob instr)
-  (string-split
-   (with-input-from-pipe
-       (conc "/bin/bash -c \"echo " instr "\"")
-       read-line)))
-
-;;======================================================================
-;; Some safety net stuff
-;;======================================================================
-
-;;======================================================================
-;; return input if it is a list or return null
-(define (common:list-or-null inlst #!key (ovrd #f)(message #f))
-  (if (list? inlst)
-      inlst
-      (begin
-	(if message (debug:print-error 0 *default-log-port* message))
-	(or ovrd '()))))
-  
-;;======================================================================
-;; T A R G E T S  ,   S T A T E ,   S T A T U S ,   
-;;                    R U N N A M E    A N D   T E S T P A T T
-;;======================================================================
-
-;;======================================================================
-;; (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")
-						      #f #t)
-					 (make-hash-table))))
-			   string<?))
-	(target-patt (args:get-arg "-target")))
-    (if target-patt
-	(filter (lambda (x)
-		  (patt-list-match x target-patt))
-		targs)
-	targs)))
-
-;;======================================================================
-;; Lookup a value in runconfigs based on -reqtarg or -target
-;; 
-(define (runconfigs-get config var)
-  (let ((targ (common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET"))))
-    (if targ
-	(or (configf:lookup config targ var)
-	    (configf:lookup config "default" var))
-	(configf:lookup config "default" var))))
-
-(define (common:args-get-state)
-  (or (args:get-arg "-state")(args:get-arg ":state")))
-
-(define (common:args-get-status)
-  (or (args:get-arg "-status")(args:get-arg ":status")))
-
-(define (common:args-get-testpatt rconf)
-  (let* (;; (tagexpr       (args:get-arg "-tagexpr"))
-         ;; (tags-testpatt (if tagexpr (string-join (runs:get-tests-matching-tags tagexpr) ",") #f))
-         (testpatt-key  (or (args:get-arg "-modepatt") (args:get-arg "--modepatt") "TESTPATT"))
-         (args-testpatt (or (args:get-arg "-testpatt") (args:get-arg "-runtests") "%"))
-         (rtestpatt     (if rconf (runconfigs-get rconf testpatt-key) #f)))
-    (cond
-     ((or (args:get-arg "--modepatt") (args:get-arg "-modepatt")) ;; modepatt is a forced setting, when set it MUST refer to an existing PATT in the runconfig
-      (if rconf
-	  (let* ((patts-from-mode-patt	  (runconfigs-get rconf testpatt-key)))
-	    (debug:print-info 0 *default-log-port* "modepatt defined is: "testpatt-key" runconfigs values for  " testpatt-key " "  patts-from-mode-patt)
-	    patts-from-mode-patt)
-	  (begin
-	    (debug:print-info 0 *default-log-port* " modepatt defined is: "testpatt-key" runconfigs values for  " testpatt-key) ;;  " " patts-from-mode-patt)
-	    #f)))     ;; We do NOT fall back to "%"
-     ;; (tags-testpatt
-     ;;  (debug:print-info 0 *default-log-port* "-tagexpr "tagexpr" selects testpatt "tags-testpatt)
-     ;;  tags-testpatt)
-     ((and (equal? args-testpatt "%") rtestpatt)
-      (debug:print-info 0 *default-log-port* "testpatt defined in "testpatt-key" from runconfigs: " rtestpatt)
-      rtestpatt)
-     (else 
-      (debug:print-info 0 *default-log-port* "using testpatt " args-testpatt " rtestpatt:" rtestpatt)
-      args-testpatt))))
-
-(define (common:false-on-exception thunk #!key (message #f))
-  (handle-exceptions exn
-                     (begin
-                       (if message
-                           (debug:print-info 0 *default-log-port* message))
-                       #f) (thunk) ))
-
-(define (common:file-exists? path-string #!key (silent #f))
-  ;;;; TODO: catch permission denied exceptions and emit appropriate warnings. Might be able to get rid of with chicken 5?
-  (common:false-on-exception (lambda () (file-exists? path-string))
-                             message: (if (not silent)
-                                          (conc "Unable to access path: " path-string)
-                                          #f)
-                             ))
-
-(define (common:directory-exists? path-string)
-  ;;;; TODO: catch permission denied exceptions and emit appropriate warnings
-  (common:false-on-exception (lambda () (directory-exists? path-string))
-                             message: (conc "Unable to access path: " path-string)
-                             ))
-
-;;======================================================================
-;; does the directory exist and do we have write access?
-;;
-;;    returns the directory or #f
-;;
-(define (common:directory-writable? path-string)
-  (handle-exceptions
-      exn
-    (begin
-      (debug:print 0 *default-log-port* "Failed to identify access to " path-string ", exn=" exn)
-      #f)
-   (if (and (directory-exists? path-string)
-            (file-write-access? path-string))
-       path-string
-       #f)))
-
-(define (common:get-linktree)
-  (or (getenv "MT_LINKTREE")
-      (if *configdat*
-	  (configf:lookup *configdat* "setup" "linktree")
-	  #f)
-      (if (or *toppath* (getenv "MT_RUN_AREA_HOME"))
-	  (conc (or *toppath* (getenv "MT_RUN_AREA_HOME")) "/lt")
-	  #f)
-      (let* ((tp (common:get-toppath #f))
-	     (lt (conc tp "/lt")))
-	(if (not tp)(debug:print 0 *default-log-port* "WARNING: cannot calculate best path for linktree, using " lt))
-	lt)))
-
-(define (common:args-get-runname)
-  (let ((res (or (args:get-arg "-runname")
-		 (args:get-arg ":runname")
-		 (getenv "MT_RUNNAME"))))
-    ;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ...
-    res))
-
-(define (common:get-fields cfgdat)
-  (let ((fields (hash-table-ref/default cfgdat "fields" '())))
-    (map car fields)))
-
-(define (common:args-get-target #!key (split #f)(exit-if-bad #f))
-  (let* ((keys    (if (hash-table? *configdat*) (common:get-fields *configdat*) '()))
-	 (numkeys (length keys))
-	 (target  (or (args:get-arg "-reqtarg")
-		      (args:get-arg "-target")
-		      (getenv "MT_TARGET")))
-	 (tlist   (if target (string-split target "/" #t) '()))
-	 (valid   (if target
-		      (or (null? keys) ;; probably don't know our keys yet
-			  (and (not (null? tlist))
-			       (eq? numkeys (length tlist))
-			       (null? (filter string-null? tlist))))
-		      #f)))
-    (if valid
-	(if split
-	    tlist
-	    target)
-	(if target
-	    (begin
-	      (debug:print-error 0 *default-log-port* "Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements")
-	      (if exit-if-bad (exit 1))
-	      #f)
-	    #f))))
-
-;;======================================================================
-;; looking only (at least for now) at the MT_ variables craft the full testname
-;;
-(define (common:get-full-test-name)
-  (if (getenv "MT_TEST_NAME")
-      (if (and (getenv "MT_ITEMPATH")
-               (not (equal? (getenv "MT_ITEMPATH") "")))
-          (getenv "MT_TEST_NAME")
-          (conc (getenv "MT_TEST_NAME") "/" (getenv "MT_ITEMPATH")))
-      #f))
-
-;;======================================================================
-;; logic for getting homehost. Returns (host . at-home)
-;; IF *toppath* is not set, wait up to five seconds trying every two seconds
-;; (this is to accomodate the watchdog)
-;;
-(define (common:get-homehost #!key (trynum 5))
-  ;; called often especially at start up. use mutex to eliminate collisions
-  (mutex-lock! *homehost-mutex*)
-  (cond
-   (*home-host*
-    (mutex-unlock! *homehost-mutex*)
-    *home-host*)
-   ((not *toppath*)
-    (mutex-unlock! *homehost-mutex*)
-    (launch:setup) ;; safely mutexed now
-    (if (> trynum 0)
-	(begin
-	  (thread-sleep! 2)
-	  (common:get-homehost trynum: (- trynum 1)))
-	#f))
-   (else
-    (let* ((currhost (get-host-name))
-	   (bestadrs (server:get-best-guess-address currhost))
-	   ;; first look in config, then look in file .homehost, create it if not found
-	   (homehost (or (configf:lookup *configdat* "server" "homehost" )
-			 (handle-exceptions
-			     exn
-			     (if (> trynum 0)
-				 (let ((delay-time (* (- 5 trynum) 5)))
-				   (mutex-unlock! *homehost-mutex*)
-				   (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Failed to read .homehost file, delaying "
-						delay-time " seconds and trying again, message: "  ((condition-property-accessor 'exn 'message) exn)
-						", exn=" exn)
-				   (thread-sleep! delay-time)
-				   (common:get-homehost trynum: (- trynum 1)))
-				 (begin
-				   (mutex-unlock! *homehost-mutex*)
-				   (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)
-						"] Failed to read .homehost file after trying five times. Giving up and exiting, message: "
-						((condition-property-accessor 'exn 'message) exn))
-				   (exit 1)))
-			   (let ((hhf (conc *toppath* "/.homehost")))
-			     (if (common:file-exists? hhf)
-				 (with-input-from-file hhf read-line)
-				 (if (file-write-access? *toppath*)
-				     (begin
-				       (with-output-to-file hhf
-					 (lambda ()
-					   (print bestadrs)))
-				       (begin
-					 (mutex-unlock! *homehost-mutex*)
-					 (car (common:get-homehost))))
-				     #f))))))
-	   (at-home  (or (equal? homehost currhost)
-			 (equal? homehost bestadrs))))
-      (set! *home-host* (cons homehost at-home))
-      (mutex-unlock! *homehost-mutex*)
-      *home-host*))))
-
-;;======================================================================
-;; am I on the homehost?
-;;
-(define (common:on-homehost?)
-  (let ((hh (common:get-homehost)))
-    (if hh
-	(cdr hh)
-	#f)))
-
-;;======================================================================
-;; do we honor the caches of the config files?
-;;
-(define (common:use-cache?)
-  (let ((res #t)) ;; priority by order of evaluation
-    (if *configdat* ;; sillyness here. can't use setup/use-cache to know if we can use the cached files!
-	(if (equal? (configf:lookup *configdat* "setup" "use-cache") "no")
-	    (set! res #f)
-	    (if (equal? (configf:lookup *configdat* "setup" "use-cache") "yes")
-		(set! res #t))))
-    (if (args:get-arg "-no-cache")(set! res #f)) ;; overrides setting in "setup"
-    (if (getenv "MT_USE_CACHE")
-	(if (equal? (getenv "MT_USE_CACHE") "yes")
-	    (set! res #t)
-	    (if (equal? (getenv "MT_USE_CACHE") "no")
-		(set! res #f))))    ;; overrides -no-cache switch
-    res))
-  
-;;======================================================================
-;; force use of server?
-;;
-(define (common:force-server?)
-  (let* ((force-setting (configf:lookup *configdat* "server" "force"))
-	 (force-type    (if force-setting (string->symbol force-setting) #f))
-	 (force-result  (case force-type
-			  ((#f)     #f)
-			  ((always) #t)
-			  ((test)   (if (args:get-arg "-execute") ;; we are in a test
-					#t
-					#f))
-			  (else
-			   (debug:print 0 *default-log-port* "ERROR: Bad server force setting " force-setting ", forcing server.")
-			   #t)))) ;; default to requiring server
-    (if force-result
-	(begin
-	  (debug:print-info 0 *default-log-port* "forcing use of server, force setting is \"" force-setting "\".")
-	  #t)
-	#f)))
-
-;;======================================================================
-;; M I S C   L I S T S
-;;======================================================================
-
-;;======================================================================
-;; items in lista are matched value and position in listb
-;; return the remaining items in listb or #f
-;;
-(define (common:list-is-sublist lista listb)
-  (if (null? lista)
-      listb ;; all items in listb are "remaining"
-      (if (> (length lista)(length listb)) 
-	  #f
-	  (let loop ((heda (car lista))
-		     (tala (cdr lista))
-		     (hedb (car listb))
-		     (talb (cdr listb)))
-	    (if (equal? heda hedb)
-		(if (null? tala) ;; we are done
-		    talb
-		    (loop (car tala)
-			  (cdr tala)
-			  (car talb)
-			  
-			  (cdr talb)))
-		#f)))))
-
-;;======================================================================
-;; Needed for long lists to be sorted where (apply max ... ) dies
-;;
-(define (common:max inlst)
-  (let loop ((max-val (car inlst))
-	     (hed     (car inlst))
-	     (tal     (cdr inlst)))
-    (if (not (null? tal))
-	(loop (max hed max-val)
-	      (car tal)
-	      (cdr tal))
-	(max hed max-val))))
-
-;;======================================================================
-;; get min or max, use > for max and < for min, this works around the limits on apply
-;;
-(define (common:min-max comp lst)
-  (if (null? lst)
-      #f ;; better than an exception for my needs
-      (fold (lambda (a b)
-	      (if (comp a b) a b))
-	    (car lst)
-	    lst)))
-
-;;======================================================================
-;; get min or max, use > for max and < for min, this works around the limits on apply
-;;
-(define (common:sum lst)
-  (if (null? lst)
-      0
-      (fold (lambda (a b)
-	      (+ a b))
-	    (car lst)
-	    lst)))
-
-;;======================================================================
-;; path list to hash-table tree
-;;   ((a b c)(a b d)(e b c)) => ((a (b (d) (c))) (e (b (c))))
-;;
-(define (common:list->htree lst)
-  (let ((resh (make-hash-table)))
-    (for-each
-     (lambda (inlst)
-       (let loop ((ht  resh)
-		  (hed (car inlst))
-		  (tal (cdr inlst)))
-	 (if (hash-table-ref/default ht hed #f)
-	     (if (not (null? tal))
-		 (loop (hash-table-ref ht hed)
-		       (car tal)
-		       (cdr tal)))
-	     (begin
-	       (hash-table-set! ht hed (make-hash-table))
-	       (loop ht hed tal)))))
-     lst)
-    resh))
-
-;;======================================================================
-;; hash-table tree to html list tree
-;;
-;;   tipfunc takes two parameters: y the tip value and path the path to that point
-;;
-(define (common:htree->html ht path tipfunc)
-  (let ((datlist 	(sort (hash-table->alist ht)
-                              (lambda (a b)
-                                (string< (car a)(car b))))))
-    (if (null? datlist)
-    	(tipfunc #f path) ;; really shouldn't get here
-	(s:ul
-	 (map (lambda (x)
-		(let* ((levelname (car x))
-		       (y         (cdr x))
-		       (newpath   (append path (list levelname)))
-		       (leaf      (or (not (hash-table? y))
-				      (null? (hash-table-keys y)))))
-		  (if leaf
-		      (s:li (tipfunc y newpath))
-		      (s:li
-		       (list 
-			levelname
-			(common:htree->html y newpath tipfunc))))))
-	      datlist)))))
-
-;;======================================================================
-;; hash-table tree to alist tree
-;;
-(define (common:htree->atree ht)
-  (map (lambda (x)
-	 (cons (car x)
-	       (let ((y (cdr x)))
-		 (if (hash-table? y)
-		     (common:htree->atree y)
-		     y))))
-       (hash-table->alist ht)))
-
-;;======================================================================
-;; M U N G E   D A T A   I N T O   N I C E   F O R M S
-;;======================================================================
-
-;;======================================================================
-;; Generate an index for a sparse list of key values
-;;   ( (rowname1 colname1 val1)(rowname2 colname2 val2) )
-;;
-;; => 
-;;
-;;   ( (rowname1 0)(rowname2 1))    ;; rownames -> num
-;;     (colname1 0)(colname2 1)) )  ;; colnames -> num
-;; 
-;; optional apply proc to rownum colnum value
-(define (common:sparse-list-generate-index data #!key (proc #f))
-  (if (null? data)
-      (list '() '())
-      (let loop ((hed (car data))
-		 (tal (cdr data))
-		 (rownames '())
-		 (colnames '())
-		 (rownum   0)
-		 (colnum   0))
-	(let* ((rowkey          (car   hed))
-	       (colkey          (cadr  hed))
-	       (value           (caddr hed))
-	       (existing-rowdat (assoc rowkey rownames))
-	       (existing-coldat (assoc colkey colnames))
-	       (curr-rownum     (if existing-rowdat rownum (+ rownum 1)))
-	       (curr-colnum     (if existing-coldat colnum (+ colnum 1)))
-	       (new-rownames    (if existing-rowdat rownames (cons (list rowkey curr-rownum) rownames)))
-	       (new-colnames    (if existing-coldat colnames (cons (list colkey curr-colnum) colnames))))
-	  ;; (debug:print-info 0 *default-log-port* "Processing record: " hed )
-	  (if proc (proc curr-rownum curr-colnum rowkey colkey value))
-	  (if (null? tal)
-	      (list new-rownames new-colnames)
-	      (loop (car tal)
-		    (cdr tal)
-		    new-rownames
-		    new-colnames
-		    (if (> curr-rownum rownum) curr-rownum rownum)
-		    (if (> curr-colnum colnum) curr-colnum colnum)
-		    ))))))
-
-;;======================================================================
-;; if it looks like a number -> convert it to a number, else return it
-;;
-(define (common:lazy-convert inval)
-  (let* ((as-num (if (string? inval)(string->number inval) #f)))
-    (or as-num inval)))
-
-;;======================================================================
-;; convert string a=1; b=2; c=a silly thing; d=
-;; to '((a . 1)(b . 2)(c . "a silly thing")(d . ""))
-;;
-(define (common:val->alist val #!key (convert #f))
-  (let ((val-list (string-split-fields ";\\s*" val #:infix)))
-    (if val-list
-	(map (lambda (x)
-	       (let ((f (string-split-fields "\\s*=\\s*" x #:infix)))
-		 (case (length f)
-		   ((0) `(,#f))  ;; null string case
-		   ((1) `(,(string->symbol (car f))))
-		   ((2) `(,(string->symbol (car f)) . ,(let ((inval (cadr f)))
-							 (if convert (common:lazy-convert inval) inval))))
-		   (else f))))
-	     val-list)
-	'())))
-
-;;======================================================================
-;; S Y S T E M   S T U F F
-;;======================================================================
-
-;;======================================================================
-;; lazy-safe get file mod time. on any error (file not existing etc.) return 0
-;;
-(define (common:lazy-modification-time fpath)
-  (handle-exceptions
-      exn
-    (begin
-      (debug:print 0 *default-log-port* "Failed to get modifcation time for " fpath ", treating it as zero. exn=" exn)
-      0)
-    (if (file-exists? fpath)
-	(file-modification-time fpath)
-	0)))
-
-;;======================================================================
-;; find timestamp of newest file associated with a sqlite db file
-(define (common:lazy-sqlite-db-modification-time fpath)
-  (let* ((glob-list (handle-exceptions
-			exn
-		      (begin
-			(debug:print 0 *default-log-port* "Failed to glob " fpath "*, exn=" exn)
-			`(,(conc "/no/such/file, message: " ((condition-property-accessor 'exn 'message) exn))))
-		      (glob (conc fpath "*"))))
-         (file-list (if (eq? 0 (length glob-list))
-			'("/no/such/file")
-			glob-list)))
-  (apply max
-	 (map
-	  common:lazy-modification-time 
-	  file-list))))
-
-;;======================================================================
-;; return a nice clean pathname made absolute
-(define (common:nice-path dir)
-  (let ((match (string-match "^(~[^\\/]*)(\\/.*|)$" dir)))
-    (if match ;; using ~ for home?
-	(common:nice-path (conc (common:read-link-f (cadr match)) "/" (caddr match)))
-	(normalize-pathname (if (absolute-pathname? dir)
-				dir
-				(conc (current-directory) "/" dir))))))
-
-;;======================================================================
-;; make "nice-path" available in config files and the repl
-(define nice-path common:nice-path)
-
-(define (common:read-link-f path)
-  (handle-exceptions
-      exn
-      (begin
-	(debug:print-error 0 *default-log-port* "command \"/bin/readlink -f " path "\" failed. exn=" exn)
-	path) ;; just give up
-    (with-input-from-pipe
-	(conc "/bin/readlink -f " path)
-      (lambda ()
-	(read-line)))))
-
-;;======================================================================
-;; returns *effective load* (not normalized)
-;;
-(define (common:get-intercept onemin fivemin)
-  (if (< onemin fivemin) ;; load is decreasing, just use the onemin load
-      onemin
-      (let* ((load-change (- onemin fivemin))
-	     (tchange     (- 300 60)))
-	(max (+ onemin (* 60 (/ load-change tchange))) 0))))
-
+  
 ;;======================================================================
 ;; calculate a delay number based on a droop curve
 ;;    inputs are:
 ;;      - load-in, load as from uptime, NOT normalized
 ;;      - numcpus, number of cpus, ideally use the real cpus, not threads
@@ -1828,381 +882,10 @@
   (let loop ((x 0))
     (print x "," (common:get-delay x 1))
     (if (< x 2)
 	(loop (+ x 0.1)))))
 
-(define (get-cpu-load #!key (remote-host #f))
-  (car (common:get-cpu-load remote-host)))
-
-;;======================================================================
-;;   (let* ((load-res (process:cmd-run->list "uptime"))
-;; 	 (load-rx  (regexp "load average:\\s+(\\d+)"))
-;; 	 (cpu-load #f))
-;;     (for-each (lambda (l)
-;; 		(let ((match (string-search load-rx l)))
-;; 		  (if match
-;; 		      (let ((newval (string->number (cadr match))))
-;; 			(if (number? newval)
-;; 			    (set! cpu-load newval))))))
-;; 	      (car load-res))
-;;     cpu-load))
-
-;;======================================================================
-;; get values from cached info from dropping file in logs dir
-;;  e.g. key is host and dtype is normalized-load
-;;
-(define (common:get-cached-info key dtype #!key (age 10))
-  (if *toppath*
-      (let* ((fullpath (conc *toppath* "/.sysdata/" key "-" dtype ".log"))
-	     (delfile  (lambda (exn)
-			 (debug:print-info 1 *default-log-port* " removing bad file " fullpath ", exn=" exn)
-			 (delete-file* fullpath)
-			 #f)))
-	(if (and (file-exists? fullpath)
-		 (file-read-access? fullpath))
-	    (handle-exceptions
-		exn
-	      (begin
-		(debug:print 0 *default-log-port* "failed to get cached info from " fullpath ", exn=" exn)
-		#f)
-	     (debug:print 2 *default-log-port* "reading file " fullpath)
-	     (let ((real-age (- (current-seconds)
-				(handle-exceptions
-				    exn
-				  (begin
-				    (debug:print 1 *default-log-port* "Failed to read mod time on file "
-						 fullpath ", using 0, exn=" exn)
-				    0)
-				  (file-change-time fullpath)))))
-	       (if (< real-age age)
-		   (handle-exceptions
-		       exn
-		     (delfile exn)
-		     (let* ((res (with-input-from-file fullpath read)))
-		       (if (eof-object? res)
-			   (begin
-			     (delfile "n/a")
-			     #f)
-			   res)))
-		   (begin
-		     (debug:print-info 2 *default-log-port* "file " fullpath
-				       " is too old (" real-age" seconds) to trust, skipping reading it")
-		     #f))))
-	    (begin
-	      (debug:print 2 *default-log-port* "not reading file " fullpath)
-	      #f)))
-      #f))
- 
-(define (common:write-cached-info key dtype dat)
-  (if *toppath*
-      (let* ((fulldir  (conc *toppath* "/.sysdata"))
-	     (fullpath (conc fulldir "/" key "-" dtype ".log")))
-	(if (not (file-exists? fulldir))(create-directory fulldir #t))
-	(handle-exceptions
-	    exn
-	  (begin
-	    (debug:print 0 *default-log-port* "failed to write file " fullpath ", exn=" exn)
-	    #f)
-	  (with-output-to-file fullpath (lambda ()(pp dat)))))
-      #f))
-
-(define (common:raw-get-remote-host-load remote-host)
-  (handle-exceptions
-      exn
-    (begin
-      (debug:print 0 *default-log-port* "failed to ssh to " remote-host " and get loadavg. exn=" exn)
-      #f) ;; more specific handling of errors needed
-    (with-input-from-pipe 
-     (conc "ssh " remote-host " cat /proc/loadavg")
-     (lambda ()(list (read)(read)(read))))))
-
-;;======================================================================
-;; get cpu load by reading from /proc/loadavg, return all three values
-;;
-(define (common:get-cpu-load remote-host)
-  (handle-exceptions
-      exn
-    (begin
-      (debug:print 0 *default-log-port* "failed to ssh or read loadavg from host " remote-host ", exn=" exn)
-      '(-99 -99 -99))
-    (let* ((actual-hostname (or remote-host (get-host-name) "localhost")))
-      (or (common:get-cached-info actual-hostname "cpu-load")
-	  (let ((result (if remote-host
-			    (map (lambda (res)
-				   (if (eof-object? res) 9e99 res))
-			         (with-input-from-pipe 
-				  (conc "ssh " remote-host " cat /proc/loadavg")
-				  (lambda ()(list (read)(read)(read)))))
-			    (with-input-from-file "/proc/loadavg" 
-			      (lambda ()(list (read)(read)(read)))))))
-	    (match
-		result
-	      ((l1 l2 l3)
-	       (if (and (number? l1)
-		      (number? l2)
-		      (number? l3))
-		   (begin
-		     (common:write-cached-info actual-hostname "cpu-load" result)
-		     result)
-		   '(-1 -1 -1))) ;; -1 is bad result
-	      (else '(-2 -2 -2))))))))
-
-;;======================================================================
-;; get normalized cpu load by reading from /proc/loadavg and /proc/cpuinfo return all three values and the number of real cpus and the number of threads
-;; returns alist '((adj-cpu-load . normalized-proc-load) ... etc.
-;;  keys: adj-proc-load, adj-core-load, 1m-load, 5m-load, 15m-load
-;;
-(define (common:get-normalized-cpu-load remote-host)
-  (let ((res (common:get-normalized-cpu-load-raw remote-host))
-	(default `((adj-proc-load . 2) ;; there is no right answer
-		   (adj-core-load . 2)
-		   (1m-load       . 2)
-		   (5m-load       . 0) ;; causes a large delta - thus causing default of throttling if stuff goes wrong
-		   (15m-load      . 0)
-		   (proc          . 1)
-		   (core          . 1)
-		   (phys          . 1)
-		   (error         . #t))))
-    (cond
-     ((and (list? res)
-	   (> (length res) 2))
-      res)
-     ((eq? res #f)   default) ;; add messages?
-     ((eq? res #f) default)   ;; this would be the #eof
-     (else default))))
-
-(define (common:get-normalized-cpu-load-raw remote-host)
-  (let* ((actual-host (or remote-host (get-host-name)))) ;; #f is localhost
-    (or (common:get-cached-info actual-host "normalized-load")
-	(let ((data (if remote-host
-			(with-input-from-pipe 
-			    (conc "ssh " remote-host " \"cat /proc/loadavg;cat /proc/cpuinfo;echo end\"")
-			  read-lines)
-			(append 
-			 (with-input-from-file "/proc/loadavg" 
-			   read-lines)
-			 (with-input-from-file "/proc/cpuinfo"
-			   read-lines)
-			 (list "end"))))
-	      (load-rx  (regexp "^([\\d\\.]+)\\s+([\\d\\.]+)\\s+([\\d\\.]+)\\s+.*$"))
-	      (proc-rx  (regexp "^processor\\s+:\\s+(\\d+)\\s*$"))
-	      (core-rx  (regexp "^core id\\s+:\\s+(\\d+)\\s*$"))
-	      (phys-rx  (regexp "^physical id\\s+:\\s+(\\d+)\\s*$"))
-	      (max-num  (lambda (p n)(max (string->number p) n))))
-	  ;; (print "data=" data)
-	  (if (null? data) ;; something went wrong
-	      #f
-	      (let loop ((hed      (car data))
-			 (tal      (cdr data))
-			 (loads    #f)
-			 (proc-num 0)  ;; processor includes threads
-			 (phys-num 0)  ;; physical chip on motherboard
-			 (core-num 0)) ;; core
-		;;; (print hed ", " loads ", " proc-num ", " phys-num ", " core-num)
-		(if (null? tal) ;; have all our data, calculate normalized load and return result
-		    (let* ((act-proc (+ proc-num 1))
-			   (act-phys (+ phys-num 1))
-			   (act-core (+ core-num 1))
-			   (adj-proc-load (/ (car loads) act-proc))
-			   (adj-core-load (/ (car loads) act-core))
-			   (result
-			    (append (list (cons 'adj-proc-load adj-proc-load)
-					  (cons 'adj-core-load adj-core-load))
-				    (list (cons '1m-load (car loads))
-					  (cons '5m-load (cadr loads))
-					  (cons '15m-load (caddr loads)))
-				    (list (cons 'proc act-proc)
-					  (cons 'core act-core)
-					  (cons 'phys act-phys)))))
-		      (common:write-cached-info actual-host "normalized-load" result)
-		      result)
-		  (regex-case
-		   hed
-		   (load-rx  ( x l1 l5 l15 ) (loop (car tal)(cdr tal)(map string->number (list l1 l5 l15)) proc-num phys-num core-num))
-		   (proc-rx  ( x p         ) (loop (car tal)(cdr tal) loads           (max-num p proc-num) phys-num core-num))
-		   (phys-rx  ( x p         ) (loop (car tal)(cdr tal) loads           proc-num (max-num p phys-num) core-num))
-		   (core-rx  ( x c         ) (loop (car tal)(cdr tal) loads           proc-num phys-num (max-num c core-num)))
-		   (else 
-		    (begin
-		      ;; (print "NO MATCH: " hed)
-		      (loop (car tal)(cdr tal) loads proc-num phys-num core-num)))))))))))
-
-(define (common:unix-ping hostname)
-  (let ((res (system (conc "ping -c 1 " hostname " > /dev/null"))))
-    (eq? res 0)))
-
-;;======================================================================
-;; ideally put all this info into the db, no need to preserve it across moving homehost
-;;
-;; return list of
-;;  ( reachable? cpuload update-time )
-(define (common:get-host-info hostname)
-  (let* ((loadinfo                         (rmt:get-latest-host-load hostname)) ;; if this host happens to have been recently used by a test reuse the load data
-         (load                             (car loadinfo))
-         (load-sample-time                 (cdr loadinfo))
-         (load-sample-age                  (- (current-seconds) load-sample-time))
-         (loadinfo-timeout-seconds         6) ;; this was 20 seconds, seems way too lax. Switch to 6 seconds
-         (host-last-update-timeout-seconds 4)
-         (host-rec (hash-table-ref/default *host-loads* hostname #f))
-         )
-    (cond
-     ((< load-sample-age loadinfo-timeout-seconds)
-      (list #t
-            load-sample-time
-            load))
-     ((and host-rec
-           (< (current-seconds) (+ (host-last-update host-rec) host-last-update-timeout-seconds)))
-      (list #t
-            (host-last-update host-rec)
-            (host-last-cpuload host-rec )))
-     ((common:unix-ping hostname)
-      (list #t
-            (current-seconds)
-            (alist-ref 'adj-core-load (common:get-normalized-cpu-load hostname)))) ;; this is cheaper than you might think. get-normalized-cpu-load is cached for up to 5 seconds
-     (else
-      (list #f 0 -1) ;; bad host, don't use!
-      ))))
-
-;;======================================================================
-;; see defstruct host at top of file.
-;;    host: reachable last-update last-used last-cpuload
-;;
-(define (common:update-host-loads-table hosts-raw)
-  (let* ((hosts (filter (lambda (x)
-                          (string-match (regexp "^\\S+$") x))
-                        hosts-raw)))
-    (for-each
-     (lambda (hostname)
-       (let* ((rec       (let ((h (hash-table-ref/default *host-loads* hostname #f)))
-                          (if h
-                              h
-                              (let ((h (make-host)))
-                                (hash-table-set! *host-loads* hostname h)
-                                h))))
-              (host-info         (common:get-host-info hostname))
-              (is-reachable      (car host-info))
-              (last-reached-time (cadr host-info))
-              (load              (caddr host-info)))
-         (host-reachable-set!    rec is-reachable)
-         (host-last-update-set!  rec last-reached-time)
-         (host-last-cpuload-set! rec load)))
-     hosts)))
-
-;;======================================================================
-;; go through the hosts from least recently used to most recently used, pick the first that meets the load criteral from the
-;; [host-rules] section.
-;;
-(define (common:get-least-loaded-host hosts-raw host-type configdat)
-  (let* ((rdat       (configf:lookup configdat "host-rules" host-type))
-	 (rules      (common:val->alist (or rdat "") convert: #t))   ;; maxnload, maxnjobs, maxjobrate
-	 (maxnload   (common:alist-ref/default 'maxnload rules 1.5)) ;; max normalized load
-	 (maxnjobs   (common:alist-ref/default 'maxnjobs rules 1.5)) ;; max normalized number of jobs
-	 (maxjobrate (common:alist-ref/default 'maxjobrate rules (/ 1 6))) ;; max rate of submitting jobs to a given host in jobs/second
-	 (hosts      (filter (lambda (x)
-			       (string-match (regexp "^\\S+$") x))
-			     hosts-raw))
-         ;; (best-host #f)
-	 (get-rec    (lambda (hostname)
-		       ;; (print "get-rec hostname=" hostname)
-		       (let ((h (hash-table-ref/default *host-loads* hostname #f)))
-			 (if h
-			     h
-			     (let ((h (make-host)))
-			       (hash-table-set! *host-loads* hostname h)
-			       h)))))
-         (best-load 99999)
-         (curr-time (current-seconds))
-	 (get-hosts-sorted (lambda (hosts)
-			     (sort hosts (lambda (a b)
-					   (let ((a-rec (get-rec a))
-						 (b-rec (get-rec b)))
-					     ;; (print "a=" a " a-rec=" a-rec " host-last-used=" (host-last-used a-rec))
-					     ;; (print "b=" b " b-rec=" b-rec " host-last-used=" (host-last-used b-rec))
-					     (< (host-last-used a-rec)
-						(host-last-used b-rec))))))))
-    (debug:print 0 *default-log-port* "INFO: hosts-sorted=" (get-hosts-sorted hosts))
-    (if (null? hosts)
-	#f ;; no hosts to select from. All done and giving up now.
-	(let ((hosts-sorted (get-hosts-sorted hosts)))
-	  (common:update-host-loads-table hosts)
-	  (let loop ((hostname  (car hosts-sorted))
-		     (tal       (cdr hosts-sorted))
-		     (best-host #f))
-	    (let* ((rec       (get-rec hostname))
-		   (reachable (host-reachable     rec))
-		   (load      (host-last-cpuload  rec))
-		   (last-used (host-last-used     rec))
-		   (delta     (- curr-time last-used))
-		   (job-rate  (if (> delta 0)
-				  (/ 1 delta)
-				  999)) ;; jobs per second
-		   (new-best  
-		    (cond
-		     ((not reachable)
-		      (debug:print 0 *default-log-port* "Skipping host " hostname " as it cannot be reached.")
-		      best-host)
-		     ((and (< load maxnload)        ;; load is acceptable
-			   (< job-rate maxjobrate)) ;; job rate is acceptable
-		      (set! best-load load)
-		      hostname)
-		     (else best-host))))
-	      (debug:print 0 *default-log-port* "INFO: Trying host " hostname " with load " load ", last used " delta " seconds ago, with job-rate " job-rate " for running a test." )
-	      (if new-best
-		  (begin ;; found a host, return it
-		    (debug:print 0 *default-log-port* "INFO: Found host: " new-best " load: " load " last-used: " delta " seconds ago, with job-rate: " job-rate)
-		    (host-last-used-set! rec curr-time)
-		    new-best)
-		  (if (null? tal) #f (loop (car tal)(cdr tal) best-host)))))))))
-
-(define (common:wait-for-homehost-load maxnormload msg)
-  (let* ((hh-dat (if (common:on-homehost?) ;; if we are on the homehost then pass in #f so the calls are local.
-                     #f
-                     (common:get-homehost)))
-         (hh     (if hh-dat (car hh-dat) #f)))
-    (common:wait-for-normalized-load maxnormload msg hh)))
-
-(define (common:get-num-cpus remote-host)
-  (let* ((actual-host (or remote-host (get-host-name))))
-    ;; hosts had better not be changing the number of cpus too often!
-    (or (hash-table-ref/default *numcpus-cache* actual-host #f)
-	(let* ((numcpus (or (common:get-cached-info actual-host "num-cpus" age: (+ 2592000 (random 3600)))
-			    (let* ((proc   (lambda ()
-					     (let loop ((numcpu 0)
-							(inl    (read-line)))
-					       (if (eof-object? inl)
-						   (if (> numcpu 0)
-						       numcpu
-						       #f) ;; if zero return #f so caller knows that things are not working
-						   (loop (if (string-match "^processor\\s+:\\s+\\d+$" inl)
-							     (+ numcpu 1)
-							     numcpu)
-							 (read-line))))))
-				   (result (if remote-host
-					       (with-input-from-pipe 
-						(conc "ssh " remote-host " cat /proc/cpuinfo")
-						proc)
-					       (with-input-from-file "/proc/cpuinfo" proc))))
-			      (if (and (number? result)
-				       (> result 0))
-				  (common:write-cached-info actual-host "num-cpus" result))
-			      result))))
-	  (hash-table-set! *numcpus-cache* actual-host numcpus)
-	  numcpus))))
-
-;;======================================================================
-;; wait for normalized cpu load to drop below maxload
-;;
-(define (common:wait-for-normalized-load maxnormload msg remote-host #!optional (rem-tries 5))
-  (let ((num-cpus (common:get-num-cpus remote-host)))
-    (if num-cpus
-	(common:wait-for-cpuload maxnormload num-cpus 15 msg: msg remote-host: remote-host)
-	(begin
-	  (thread-sleep! (random 60)) ;; we failed to get num cpus. wait a bit and try again
-	  (if (> rem-tries 0)
-	      (common:wait-for-normalized-load maxnormload msg remote-host (- rem-tries 1))
-	      #f)))))
-
 ;;======================================================================
 ;; DO NOT CALL THIS DIRECTLY. It is called from common:wait-for-normalized-load
 ;;   count     - count down to zero, at some point we'd give up if the load never drops
 ;;   num-tries - count down to zero number tries to get numcpus
 ;;
@@ -2273,134 +956,28 @@
      ;; overloaded and count expired (i.e. went to zero)
      (else
       (if (> num-tries 0) ;; should be "num-tries-left". 
 	  (if (common:low-noise-print 30 (conc (round effective-load) "-load-acceptable-" effective-host))
 	      (debug:print 0 *default-log-port* "Load on " effective-host " is acceptable at effective normalized load of "
-			   effective-normalized-load "  continuing."))
+			   normalized-effective-load "  continuing."))
 	  (debug:print 0 *default-log-port* "Load on " effective-host ", "
 		       first" could not be retrieved. Giving up and continuing."))))))
 
 ;;======================================================================
-;; DO NOT CALL THIS DIRECTLY. It is called from common:wait-for-normalized-load
-;;
-;; (define (common:wait-for-cpuload maxload-in numcpus-in waitdelay #!key (count 1000) (msg #f)(remote-host #f)(force-maxload #f)(num-tries 5))
-;;   (let* ((loadavg (common:get-cpu-load remote-host))
-;; 	 (numcpus (if (<= 1 numcpus-in) ;; not possible to have zero.  If we get 1, it's possible that we got the previous default, and we should check again
-;; 		      (common:get-num-cpus remote-host)
-;; 		      numcpus-in))
-;; 	 (maxload (if force-maxload
-;; 		      maxload-in
-;; 		      (if (number? maxload-in)
-;; 			  (max maxload-in 0.5)
-;; 			  0.5))) ;; so maxload must be greater than 0.5 for now BUG - FIXME?
-;; 	 (first   (car loadavg))
-;; 	 (next    (cadr loadavg))
-;; 	 (adjmaxload (* maxload (max 1 numcpus))) ;; possible bug where
-;; 					       ;; numcpus (or could be
-;; 					       ;; maxload) is zero,
-;; 					       ;; crude fallback is to
-;; 					       ;; at least use 1
-;; 	 (loadjmp (- first (if (> next (* numcpus 0.7)) ;; could do something with average of first and next?
-;; 			       0
-;; 			       next))) ;; we will force a conservative calculation any time next is large.
-;; 	 (first-next-avg    (/ (+ first next) 2))
-;; 	 ;; add some randomness to the time to break any alignment
-;; 	 ;; where netbatch dumps many jobs to machines simultaneously
-;;          (adjwait           (min (+ 300 (random 10)) (abs (* (+ (random 10)
-;; 								(/ (- 1000 count) 10)
-;; 								waitdelay)
-;; 							     (- first adjmaxload) ))))
-;; 	 (load-jump-limit   (configf:lookup-number *configdat* "setup" "load-jump-limit"))
-;; 	 ;; effective load accounts for load jumps, this should elminate all the first-next-avg, adjwait, load-jump-limit
-;; 	 ;; etc.
-;; 	 (effective-load    (common:get-intercept first next))
-;; 	 (effective-host    (or remote-host "localhost"))
-;; 	 (normalized-effective-load (/ effective-load numcpus))
-;; 	 (will-wait                 (> normalized-effective-load maxload)))
-;; 	 
-;;     ;; let's let the user know once in a long while that load checking
-;;     ;; is happening but not constantly report it
-;;     #;(if (common:low-noise-print 30 (conc "cpuload" (or remote-host "localhost"))) ;; (> (random 100) 75) ;; about 25% of the time
-;; 	(debug:print-info 1 *default-log-port* "Checking cpuload on " (or remote-host "localhost") ", maxload: " maxload
-;;     ", load: " first ", adjmaxload: " adjmaxload ", loadjmp: " loadjmp))
-;; 
-;;     (debug:print-info 1 *default-log-port*
-;; 		      "On host: " effective-host
-;; 		      ", effective load: " effective-load
-;; 		      ", numcpus: " numcpus
-;; 		      ", normalized effective load: " normalized-effective-load
-;; 		      )
-;;     
-;;     (cond
-;;      ;; bad data, try again to get the data
-;;      ((and (< first 0) ;; this indicates the loadavg data is bad - machine may not be reachable
-;; 	   (> num-tries 0))
-;;       (debug:print 0 *default-log-port* "WARNING: received bad data from get-cpu-load " first ", we'll sleep 10s and try " num-tries " more times.")
-;;       (thread-sleep! 10)
-;;       (common:wait-for-cpuload maxload-in numcpus-in waitdelay
-;; 			       count: count remote-host: remote-host force-maxload: force-maxload num-tries: (- num-tries 1)))
-;;      ;; need to wait for load to drop
-;;      ((and will-wait ;; (> first adjmaxload)
-;; 	   (> count 0))
-;;       (debug:print-info 0 *default-log-port*
-;; 			"Delaying " 15 ;; adjwait
-;; 			" seconds due to normalized effective load " normalized-effective-load ;; first
-;; 			" exceeding max of " adjmaxload
-;; 			" on server " (or remote-host (get-host-name))
-;; 			" (normalized load-limit: " maxload ") " (if msg msg ""))
-;;       (thread-sleep! 15) ;; adjwait)
-;;       (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host))
-;;      ((and (> loadjmp (cond
-;; 		       (load-jump-limit load-jump-limit)
-;; 		       ((> numcpus 8)(/ numcpus 2))
-;; 		       ((> numcpus 4)(/ numcpus 1.2))
-;; 		       (else 0.5)))
-;; 	   (> count 0))
-;;       (debug:print-info 0 *default-log-port* "waiting " adjwait " seconds due to possible load jump " loadjmp ". "
-;; 			(if msg msg ""))
-;;       (thread-sleep! adjwait)
-;;       (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host))
-;;      (else
-;;       (if (> num-tries 0)
-;; 	  (if (common:low-noise-print 30 (conc (round first) "-load-acceptable-" (or remote-host "localhost")))
-;; 	      (debug:print 0 *default-log-port* "Load on " (or remote-host "localhost") " is acceptable at " first " continuing."))
-;; 	  (debug:print 0 *default-log-port* "Load on " (or remote-host "localhost") ", "first" could not be retrieved. Giving up and continuing."))))))
-;; 
-(define (get-uname . params)
-  (let* ((uname-res (process:cmd-run->list (conc "uname " (if (null? params) "-a" (car params)))))
-	 (uname #f))
-    (if (null? (car uname-res))
-	"unknown"
-	(caar uname-res))))
-
-;; for reasons I don't understand multiple calls to real-path in parallel threads
-;; must be protected by mutexes
-;;
-(define (common:real-path inpath)
-  ;; (process:cmd-run-with-stderr->list "readlink" "-f" inpath)) ;; cmd . params)
-  ;; (let-values 
-  ;;  (((inp oup pid) (process "readlink" (list "-f" inpath))))
-  ;;  (with-input-from-port inp
-  ;;    (let loop ((inl (read-line))
-  ;;       	(res #f))
-  ;;      (print "inl=" inl)
-  ;;      (if (eof-object? inl)
-  ;;          (begin
-  ;;            (close-input-port inp)
-  ;;            (close-output-port oup)
-  ;;            ;; (process-wait pid)
-  ;;            res)
-  ;;          (loop (read-line) inl))))))
-  (with-input-from-pipe (conc "readlink -f " inpath) read-line))
-
-;;======================================================================
-;; D I S K   S P A C E 
-;;======================================================================
-
-(define (common:get-disk-space-used fpath)
-  (with-input-from-pipe (conc "/usr/bin/du -s " fpath) read))
-
+;; wait for normalized cpu load to drop below maxload
+;;
+(define (common:wait-for-normalized-load maxnormload msg remote-host #!optional (rem-tries 5))
+  (let ((num-cpus (common:get-num-cpus remote-host)))
+    (if num-cpus
+	(common:wait-for-cpuload maxnormload num-cpus 15 msg: msg remote-host: remote-host)
+	(begin
+	  (thread-sleep! (random 60)) ;; we failed to get num cpus. wait a bit and try again
+	  (if (> rem-tries 0)
+	      (common:wait-for-normalized-load maxnormload msg remote-host (- rem-tries 1))
+	      #f)))))
+
+;;======================================================================
 ;;======================================================================
 ;; given path get free space, allows override in [setup]
 ;; with free-space-script /path/to/some/script.sh
 ;;
 (define (get-df path)
@@ -2411,56 +988,163 @@
 	 (let ((res (read-line)))
 	   (if (string? res)
 	       (string->number res)))))
       (get-unix-df path)))
 
-(define (get-free-inodes path)
-  (if (configf:lookup *configdat* "setup" "free-inodes-script")
-      (with-input-from-pipe 
-	  (conc (configf:lookup *configdat* "setup" "free-inodes-script") " " path)
-	(lambda ()
-	  (let ((res (read-line)))
-	    (if (string? res)
-		(string->number res)))))
-      (get-unix-inodes path)))
-
-(define (get-unix-df path)
-  (let* ((df-results (process:cmd-run->list (conc "df " path)))
-	 (space-rx   (regexp "([0-9]+)\\s+([0-9]+)%"))
-	 (freespc    #f))
-    ;; (write df-results)
-    (for-each (lambda (l)
-		(let ((match (string-search space-rx l)))
-		  (if match 
-		      (let ((newval (string->number (cadr match))))
-			(if (number? newval)
-			    (set! freespc newval))))))
-	      (car df-results))
-    freespc))
-
-(define (get-unix-inodes path)
-  (let* ((df-results (process:cmd-run->list (conc "df -i " path)))
-	 (space-rx   (regexp "([0-9]+)\\s+([0-9]+)%"))
-	 (freenodes    0)) ;; 0 is a better failsafe than #f here.
-    ;; (write df-results)
-    (for-each (lambda (l)
-		(let ((match (string-search space-rx l)))
-		  (if match 
-		      (let ((newval (string->number (cadr match))))
-			(if (number? newval)
-			    (set! freenodes newval))))))
-	      (car df-results))
-    freenodes))
-
 (define (common:check-space-in-dir dirpath required)
   (let* ((dbspace  (if (directory? dirpath)
 		       (get-df dirpath)
 		       0)))
     (list (> dbspace required)
 	  dbspace
 	  required
 	  dirpath)))
+
+(define (get-free-inodes path)
+  (if (configf:lookup *configdat* "setup" "free-inodes-script")
+      (with-input-from-pipe 
+	  (conc (configf:lookup *configdat* "setup" "free-inodes-script") " " path)
+;;======================================================================
+;;======================================================================
+;;======================================================================
+;;======================================================================
+;;======================================================================
+
+	(lambda ()
+	  (let ((res (read-line)))
+	    (if (string? res)
+		(string->number res)))))
+      (get-unix-inodes path)))
+;;======================================================================
+;;======================================================================
+;;======================================================================
+;;======================================================================
+;;======================================================================
+;;======================================================================
+;;======================================================================
+;;======================================================================
+;;======================================================================
+
+;;======================================================================
+;;  T E S T   L A U N C H I N G   P E R   I T E M   W I T H   H O S T   T Y P E S
+;;======================================================================
+;; 
+;; [hosts]
+;; arm cubie01 cubie02
+;; x86_64 zeus xena myth01
+;; allhosts #{g hosts arm} #{g hosts x86_64}
+;; 
+;; [host-types]
+;; general #MTLOWESTLOAD #{g hosts allhosts}
+;; arm     #MTLOWESTLOAD #{g hosts arm}
+;; nbgeneral nbjob run JOBCOMMAND -log $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME.$MT_TESTNAME-$MT_ITEM_PATH.lgo
+;;
+;; [host-rules]
+;; # maxnload   => max normalized load
+;; # maxnjobs   => max jobs per cpu
+;; # maxjobrate => max jobs per second
+;; general maxnload=1.1; maxnjobs=1.2; maxjobrate=0.1 
+;; 
+;; [launchers]
+;; envsetup general
+;; xor/%/n 4C16G
+;; % nbgeneral
+;; 
+;; [jobtools]
+;; # if defined and not "no" flexi-launcher will bypass "launcher" unless no match.
+;; flexi-launcher yes  
+;; launcher nbfake
+;;
+(define (common:get-launcher configdat testname itempath)
+  (let ((fallback-launcher (configf:lookup configdat "jobtools" "launcher")))
+    (if (and (configf:lookup configdat "jobtools" "flexi-launcher") ;; overrides launcher
+	     (not (equal? (configf:lookup configdat "jobtools" "flexi-launcher") "no")))
+	(let* ((launchers         (hash-table-ref/default configdat "launchers" '())))
+	  (if (null? launchers)
+	      fallback-launcher
+	      (let loop ((hed (car launchers))
+			 (tal (cdr launchers)))
+		(let ((patt      (car hed))
+		      (host-type (cadr hed)))
+		  (if (tests:match patt testname itempath)
+		      (begin
+			(debug:print-info 2 *default-log-port* "Have flexi-launcher match for " testname "/" itempath " = " host-type)
+			(let ((launcher (configf:lookup configdat "host-types" host-type)))
+			  (if launcher
+			      (let* ((launcher-parts (string-split launcher))
+				     (launcher-exe   (car launcher-parts)))
+				(if (equal? launcher-exe "#MTLOWESTLOAD") ;; this is our special case, we will find the lowest load and craft a nbfake commandline
+				    (let host-loop ((targ-host (common:get-least-loaded-host (cdr launcher-parts) host-type configdat))
+						    (count     100))
+				      (if targ-host
+					  (conc "remrun " targ-host)
+					  (if (> count 0)
+					      (begin
+						(debug:print 0 *default-log-port* "INFO: Waiting for a host for host-type " host-type)
+						(thread-sleep! (- 101 count))
+						(host-loop (common:get-least-loaded-host (cdr launcher-parts) host-type configdat)
+							   (- count 1)))
+					      (begin
+						(debug:print 0 *default-log-port* "FATAL: Failed to find a host from #MTLOWESTLOAD for host-type " host-type)
+						(exit)))))
+				    launcher))
+			      (begin
+				(debug:print-info 0 *default-log-port* "WARNING: no launcher found for host-type " host-type)
+				(if (null? tal)
+				    fallback-launcher
+				    (loop (car tal)(cdr tal)))))))
+		      ;; no match, try again
+		      (if (null? tal)
+			  fallback-launcher
+			  (loop (car tal)(cdr tal))))))))
+	fallback-launcher)))
+
+;; 		(let ((cmddat (make-qitem
+;; 			       command:   command
+;; 			       host-port: host-port
+;; 			       params:    params)))
+;; 		  (queue-push cmddat) 		;; put request into the queue
+;; 		  (nn-send soc "queued"))         ;; reply with "queued"
+;; 		(print "ERROR: ["(common:human-time)"] BAD request " dat))
+;; 	    (loop (nn-recv soc)))))
+;;     (nn-close soc)))
+;;======================================================================
+;;======================================================================
+;;======================================================================
+;;======================================================================
+;;======================================================================
+(define (common:get-pkts-dirs mtconf use-lt)
+  (let* ((pktsdirs-str (or (configf:lookup mtconf "setup"  "pktsdirs")
+			   (and use-lt
+				(conc (or *toppath*
+					  (current-directory))
+				      "/lt/.pkts"))))
+	 (pktsdirs  (if pktsdirs-str
+			(string-split pktsdirs-str " ")
+			#f)))
+    pktsdirs))
+
+;;======================================================================
+(define (common:with-queue-db mtconf proc #!key (use-lt #f)(toppath-in #f))
+  (let* ((pktsdirs (common:get-pkts-dirs mtconf use-lt))
+	 (pktsdir  (if pktsdirs (car pktsdirs) #f))
+	 (toppath  (or (configf:lookup mtconf "scratchdat" "toppath")
+		       toppath-in))
+	 (pdbpath  (or (configf:lookup mtconf "setup"  "pdbpath") pktsdir)))
+    (cond
+     ((not (and  pktsdir toppath pdbpath))
+      (debug:print 0 *default-log-port* "ERROR: settings are missing in your megatest.config for area management.")
+      (debug:print  0 *default-log-port* "  you need to have pktsdirs in the [setup] section."))
+     ((not (common:file-exists? pktsdir))
+      (debug:print 0 *default-log-port* "ERROR: pkts directory not found " pktsdir))
+     ((not (equal? (file-owner pktsdir)(current-effective-user-id)))
+      (debug:print 0 *default-log-port* "ERROR: directory " pktsdir " is not owned by " (current-effective-user-name)))
+     (else
+	(let* ((pdb  (open-queue-db pdbpath "pkts.db"
+				    schema: '("CREATE TABLE groups (id INTEGER PRIMARY KEY,groupname TEXT, CONSTRAINT group_constraint UNIQUE (groupname));"))))
+	  (proc pktsdirs pktsdir pdb)
+	  (dbi:close pdb))))))
 
 ;;======================================================================
 ;; check space in dbdir and in megatest dir
 ;; returns: ok/not dbspace required-space
 ;;
@@ -2545,949 +1229,59 @@
     (if (and best (> bestsize minsize))
 	best
 	#f))) ;; #f means no disk candidate found
 
 ;;======================================================================
-;; convert a spec string to a list of vectors #( rx  action rx-string )
-(define (common:spec-string->list-of-specs spec-string actions)
-  (let ((spec-strings  (string-split-fields "\\s*;\\s*" spec-string #:infix))
-	(actions-regex (regexp (conc "^(.*)\\s+(" (string-intersperse (map conc actions) "|") ")"))))
-    (filter
-     (lambda (x) x)
-     (map (lambda (s)
-	    (let ((m (string-match actions-regex s)))
-	      (if m
-		  (vector (regexp (cadr m))(string->symbol (caddr m))(cadr m))
-		  (begin
-		    (debug:print 0 *default-log-port* "WARNING: Unrecognised rule \"" s "\" in clean-up specification.")
-		    #f))))
-	  spec-strings))))
-  
-;;======================================================================
-;; given a list of specs rx . rule and a file return the first matching rule
-;; 
-(define (common:file-find-rule fname rules) ;; rule is vector #( rx action rx-string)
-  (let loop ((rule   (car rules))
-	     (tail   (cdr rules)))
-    (let ((rx (vector-ref rule 0))
-	  (rn (vector-ref rule 1))) ;; rule name
-      (if (string-match rx fname)
-	  rule ;; return the whole rule so regex can be printed etc.
-	  (if (null? tail)
-	      #f
-	      (loop (car tail)(cdr tail)))))))
-
-;;======================================================================
-;; given a spec apply some rules to a directory
-;;
-;;  WARNING: This function will REMOVE files - be sure your spec and path is correct!
-;;
-;; spec format:
-;;   file-regex1 action; file-regex2 action; ...
-;; e.g.
-;;   .*\.log$ keep; .* remove
-;;   --> keep all .log files, remove everything else
-;; limitations:
-;;   cannot have a rule with ; as part of the spec
-;;   not very flexible, would be nice to return binned file names?
-;; supported rules:
-;;   keep     - keep this file
-;;   remove   - remove this file
-;;   compress - compress this file
-;;
-(define (common:dir-clean-up path spec-string #!key (compress "gzip")(actions '(keep remove compress))(remove-empty #f))
-  (let* ((specs         (common:spec-string->list-of-specs spec-string actions))
-	 (keepers       (make-hash-table))
-	 (directories   (make-hash-table)))
-    (find-files 
-     path
-     action: (lambda (p res)
-	       (let ((rule  (common:file-find-rule p specs)))
-		 (cond
-		  ((directory? p)(hash-table-set! directories p #t))
-		  (else
-		   (case (vector-ref rule 1)
-		     ((keep)(hash-table-set! keepers p rule))
-		     ((remove)
-		      (print "Removing file " p)
-		      (delete-file p))
-		     ((compress)
-		      (print "Compressing file " p)
-		      (system (conc compress " " p)))
-		     (else
-		      (print "No match for file " p))))))))
-    (if remove-empty
-	(for-each
-	 (lambda (d)
-	   (if (null? (glob (conc d "/.*")(conc d "/*")))
-	       (begin
-		 (print "Removing empty directory " d)
-		 (delete-directory d))))
-	 (sort (hash-table-keys directories) (lambda (a b)(> (string-length a)(string-length b))))))
-    ))
-
-;;======================================================================
-;; E N V I R O N M E N T   V A R S
-;;======================================================================
-
-(define (bb-check-path #!key (msg "check-path: "))
-  (let ((path (or (get-environment-variable "PATH") "none")))
-    (debug:print-info 0 *default-log-port* (conc msg" : $PATH="path))
-    (if (string-match "^.*/isoenv-core/.*" path)
-        (debug:print-error 0 *default-log-port* (conc msg" : !!ISOENV PRESENT!!")) ;; remove for prod
-        (debug:print-info 1 *default-log-port* (conc msg" : **no isoenv present**")))))
-	      
-(define (save-environment-as-files fname #!key (ignorevars (list "USER" "HOME" "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR" "MAKEFLAGS" "MAKEF" "MAKEOVERRIDES")))
-  ;;(bb-check-path msg: "save-environment-as-files entry")
-  (let ((envvars (get-environment-variables))
-        (whitesp (regexp "[^a-zA-Z0-9_\\-:,\\.\\/%$]"))
-	(mungeval (lambda (val)
-		    (cond
-		     ((eq? val #t) "") ;; convert #t to empty string
-		     ((eq? val #f) #f) ;; convert #f to itself (still thinking about this one
-		     (else val)))))
-    (with-output-to-file (conc fname ".csh")
-       (lambda ()
-          (for-each (lambda (keyval)
-		      (let* ((key   (car keyval))
-			     (val   (cdr keyval))
-			     (delim (if (string-search whitesp val) 
-					"\""
-					"")))
-			(print (if (or (member key ignorevars)
-				       (string-search whitesp key))
-				   "# setenv "
-				   "setenv ")
-			       key " " delim (mungeval val) delim)))
-		    envvars)))
-     (with-output-to-file (conc fname ".sh")
-       (lambda ()
-          (for-each (lambda (keyval)
-		      (let* ((key (car keyval))
-			     (val (cdr keyval))
-			     (delim (if (string-search whitesp val) 
-					"\""
-					"")))
-			(print (if (or (member key ignorevars)
-				       (string-search whitesp key)
-				       (string-search ":" key)) ;; internal only values to be skipped.
-				   "# export "
-				   "export ")
-			       key "=" delim (mungeval val) delim)))
-                    envvars)))))
-
-(define (common:get-param-mapping #!key (flavor #f))
-  "returns alist mapping string keys in testconfig/subrun to megatest command line switches; if flavor is switch-symbol, maps tcmt symbolic switches to megatest switches"
-  (let ((default '(("tag-expr"  . "-tagexpr")
-                   ("mode-patt" . "-modepatt")
-                   ("run-name"  . "-runname")
-                   ("contour"   . "-contour")
-                   ("target"    . "-target")
-                   ("test-patt" . "-testpatt")
-                   ("msg"       . "-m")
-                   ("log"       . "-log")
-                   ("start-dir" . "-start-dir")
-                   ("new"       . "-set-state-status"))))
-    (if (eq? flavor 'switch-symbol)
-        (map (lambda (x)
-               (cons (string->symbol (conc "-" (car x))) (cdr x)))
-             default)
-        default)))
-
-;;======================================================================
-;; set some env vars from an alist, return an alist with original values
-;; (("VAR" "value") ...)
-;; a value of #f means "unset this var"
-;;
-(define (alist->env-vars lst)
-  (if (list? lst)
-      (let ((res '()))
-	(for-each (lambda (p)
-		    (let* ((var (car  p))
-			   (val (cadr p))
-			   (prv (get-environment-variable var)))
-		      (set! res (cons (list var prv) res))
-		      (if val 
-			  (safe-setenv var (->string val))
-			  (unsetenv var))))
-		  lst)
-	res)
-      '()))
-
-;;======================================================================
-;; clear vars matching pattern, run proc, set vars back
-;; if proc is a string run that string as a command with
-;; system.
-;;
-(define *common:orig-env*
-  (let ((envvars (get-environment-variables)))
-    (if (get-environment-variable "MT_ORIG_ENV")
-        (with-input-from-string
-            (z3:decode-buffer (base64:base64-decode (get-environment-variable "MT_ORIG_ENV")))
-          read)
-        (filter-map (lambda (x)
-                      (if (string-match "^MT_.*" (car x))
-                          #f
-                          x))
-                    envvars))))
-
-(define (common:with-orig-env proc)
-  (let  ((current-env (get-environment-variables)))
-    (for-each (lambda (x) (unsetenv (car x)))             current-env)
-    (for-each (lambda (x) (setenv (car x) (cdr x))) *common:orig-env*)
-    (let ((rv (cond
-               ((string? proc)(system proc))
-               (proc          (proc)))))
-      (for-each (lambda (x) (unsetenv (car x))) *common:orig-env*)
-      (for-each (lambda (x) (setenv (car x) (cdr x))) current-env)
-      rv)))
-
-(define (common:without-vars proc . var-patts)
-  (let ((vars (make-hash-table)))
-    (for-each
-     (lambda (vardat) ;; each env var
-       (for-each
-	(lambda (var-patt)
-	  (if (string-match var-patt (car vardat))
-	      (let ((var (car vardat))
-		    (val (cdr vardat)))
-		(hash-table-set! vars var val)
-		(unsetenv var))))
-	var-patts))
-     (get-environment-variables))
-    (cond
-     ((string? proc)(system proc))
-     (proc          (proc)))
-    (hash-table-for-each
-     vars
-     (lambda (var val)
-       (setenv var val)))
-    vars))
-
-(define (common:run-a-command cmd #!key (with-vars #f) (with-orig-env #f))
-  (let* ((pre-cmd  (dtests:get-pre-command))
-         (post-cmd (dtests:get-post-command))
-         (fullcmd  (if (or pre-cmd post-cmd)
-                       (conc pre-cmd cmd post-cmd)
-                       (conc "viewscreen " cmd))))
-    (debug:print-info 02 *default-log-port* "Running command: " fullcmd)
-    (cond
-     (with-vars     (common:without-vars  fullcmd))
-     (with-orig-env (common:with-orig-env fullcmd))
-     (else          (common:without-vars  fullcmd "MT_.*")))))
-		  
-;;======================================================================
-;; T I M E   A N D   D A T E
-;;======================================================================
-
-;;======================================================================
-;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5
-(define (common:hms-string->seconds tstr)
-  (let ((parts     (string-split-fields "\\w+" tstr))
-	(time-secs 0)
-	;; s=seconds, m=minutes, h=hours, d=days, M=months, y=years, w=weeks
-	(trx       (regexp "(\\d+)([smhdMyw])")))
-    (for-each (lambda (part)
-		(let ((match  (string-match trx part)))
-		  (if match
-		      (let ((val (string->number (cadr match)))
-			    (unt (caddr match)))
-			(if val 
-			    (set! time-secs (+ time-secs (* val
-							    (case (string->symbol unt)
-							      ((s) 1)
-							      ((m) 60) ;; minutes
-							      ((h) 3600)
-							      ((d) 86400)
-							      ((w) 604800)
-							      ((M) 2628000) ;; aproximately one month
-							      ((y) 31536000)
-							      (else #f))))))))))
-	      parts)
-    time-secs))
-		       
-(define (seconds->hr-min-sec secs)
-  (let* ((hrs (quotient secs 3600))
-	 (min (quotient (- secs (* hrs 3600)) 60))
-	 (sec (- secs (* hrs 3600)(* min 60))))
-    (conc (if (> hrs 0)(conc hrs "hr ") "")
-	  (if (> min 0)(conc min "m ")  "")
-	  sec "s")))
-
-(define (seconds->time-string sec)
-  (time->string 
-   (seconds->local-time sec) "%H:%M:%S"))
-
-(define (seconds->work-week/day-time sec)
-  (time->string
-   (seconds->local-time sec) "ww%V.%u %H:%M"))
-
-(define (seconds->work-week/day sec)
-  (time->string
-   (seconds->local-time sec) "ww%V.%u"))
-
-(define (seconds->year-work-week/day sec)
-  (time->string
-   (seconds->local-time sec) "%yww%V.%w"))
-
-(define (seconds->year-work-week/day-time sec)
-  (time->string
-   (seconds->local-time sec) "%Yww%V.%w %H:%M"))
-
-(define (seconds->year-week/day-time sec)
-  (time->string
-   (seconds->local-time sec) "%Yw%V.%w %H:%M"))
-
-(define (seconds->quarter sec)
-  (case (string->number
-	 (time->string 
-	  (seconds->local-time sec)
-	  "%m"))
-    ((1 2 3) 1)
-    ((4 5 6) 2)
-    ((7 8 9) 3)
-    ((10 11 12) 4)
-    (else #f)))
-
-;;======================================================================
-;; basic ISO8601 format (e.g. "2017-02-28 06:02:54") date time => Unix epoch
-;;
-(define (common:date-time->seconds datetime)
-  (local-time->seconds (string->time datetime "%Y-%m-%d %H:%M:%S")))
-
-;;======================================================================
-;; given span of seconds tstart to tend
-;; find start time to mark and mark delta
-;;
-(define (common:find-start-mark-and-mark-delta tstart tend)
-  (let* ((deltat   (- (max tend (+ tend 10)) tstart)) ;; can't handle runs of less than 4 seconds. Pad it to 10 seconds ...
-	 (result   #f)
-	 (min      60)
-	 (hr       (* 60 60))
-	 (day      (* 24 hr))
-	 (yr       (* 365 day)) ;; year
-	 (mo       (/ yr 12))
-	 (wk       (* day 7)))
-    (for-each
-     (lambda (max-blks)
-       (for-each
-	(lambda (span) ;; 5 2 1
-	  (if (not result)
-	      (for-each 
-	       (lambda (timeunit timesym) ;; year month day hr min sec
-		 (if (not result)
-		     (let* ((time-blk (* span timeunit))
-			    (num-blks (quotient deltat time-blk)))
-		       (if (and (> num-blks 4)(< num-blks max-blks))
-			   (let ((first (* (quotient tstart time-blk) time-blk)))
-			     (set! result (list span timeunit time-blk first timesym))
-			     )))))
-	       (list yr mo wk day hr min 1)
-	       '(     y  mo w  d   h  m   s))))
-	(list 8 6 5 2 1)))
-     '(5 10 15 20 30 40 50 500))
-    (if values
-	(apply values result)
-	(values 0 day 1 0 'd))))
-
-;;======================================================================
-;; given x y lim return the cron expansion
-;;
-(define (common:expand-cron-slash x y lim)
-  (let loop ((curr x)
-	     (res  `()))
-    (if (< curr lim)
-	(loop (+ curr y) (cons curr res))
-	(reverse res))))
-
-;;======================================================================
-;; expand a complex cron string to a list of cron strings
-;;
-;;  x/y   => x, x+y, x+2y, x+3y while x+Ny<max_for_field
-;;  a,b,c => a, b ,c
-;;
-;;   NOTE: with flatten a lot of the crud below can be factored down.
-;;
-(define (common:cron-expand cron-str)
-  (if (list? cron-str)
-      (flatten
-       (fold (lambda (x res)
-	       (if (list? x)
-		   (let ((newres (map common:cron-expand x)))
-		     (append x newres))
-		   (cons x res)))
-	     '()
-	     cron-str)) ;; (map common:cron-expand cron-str))
-      (let ((cron-items (string-split cron-str))
-	    (slash-rx   (regexp "(\\d+)/(\\d+)"))
-	    (comma-rx   (regexp ".*,.*"))
-	    (max-vals   '((min        . 60)
-			  (hour       . 24)
-			  (dayofmonth . 28) ;;; BUG!!!! This will be a bug for some combinations
-			  (month      . 12)
-			  (dayofweek  . 7))))
-	(if (< (length cron-items) 5) ;; bad spec
-	    cron-str ;; `(,cron-str)              ;; just return the string, something downstream will fix it
-	    (let loop ((hed  (car cron-items))
-		       (tal  (cdr cron-items))
-		       (type 'min)
-		       (type-tal '(hour dayofmonth month dayofweek))
-		       (res  '()))
-	      (regex-case
-		  hed
-		(slash-rx ( _ base incr ) (let* ((basen          (string->number base))
-						 (incrn          (string->number incr))
-						 (expanded-vals  (common:expand-cron-slash basen incrn (alist-ref type max-vals)))
-						 (new-list-crons (fold (lambda (x myres)
-									 (cons (conc (if (null? res)
-											 ""
-											 (conc (string-intersperse res " ") " "))
-										     x " " (string-intersperse tal " "))
-									       myres))
-								       '() expanded-vals)))
-					    ;; (print "new-list-crons: " new-list-crons)
-					    ;; (fold (lambda (x res)
-					    ;; 	    (if (list? x)
-					    ;; 		(let ((newres (map common:cron-expand x)))
-					    ;; 		  (append x newres))
-					    ;; 		(cons x res)))
-					    ;; 	  '()
-					    (flatten (map common:cron-expand new-list-crons))))
-		;;					    (map common:cron-expand (map common:cron-expand new-list-crons))))
-		(else (if (null? tal)
-			  cron-str
-			  (loop (car tal)(cdr tal)(car type-tal)(cdr type-tal)(append res (list hed)))))))))))
-
-;;======================================================================
-;; given a cron string and the last time event was processed return #t to run or #f to not run
-;;
-;;  min    hour   dayofmonth month  dayofweek
-;; 0-59    0-23   1-31       1-12   0-6          ### NOTE: dayofweek does not include 7
-;;
-;;  #t => yes, run the job
-;;  #f => no, do not run the job
-;;
-(define (common:cron-event cron-str now-seconds-in last-done) ;; ref-seconds = #f is NOW.
-  (let* ((cron-items     (map string->number (string-split cron-str)))
-	 (now-seconds    (or now-seconds-in (current-seconds)))
-	 (now-time       (seconds->local-time now-seconds))
-	 (last-done-time (seconds->local-time last-done))
-	 (all-times      (make-hash-table)))
-    ;; (print "cron-items: " cron-items "(length cron-items): " (length cron-items))
-    (if (not (eq? (length cron-items) 5)) ;; don't even try to figure out junk strings
-	#f
-	(match-let (((     cmin chour cdayofmonth cmonth    cdayofweek)
-		     cron-items)
-		    ;; 0     1    2        3         4    5      6
-		    ((nsec nmin nhour ndayofmonth nmonth nyr ndayofweek n7 n8 n9)
-		     (vector->list now-time))
-		    ((lsec lmin lhour ldayofmonth lmonth lyr ldayofweek l7 l8 l9)
-		     (vector->list last-done-time)))
-	  ;; create all possible time slots
-	  ;; remove invalid slots due to (for example) day of week
-	  ;; get the start and end entries for the ref-seconds (current) time
-	  ;; if last-done > ref-seconds => this is an ERROR!
-	  ;; does the last-done time fall in the legit region?
-	  ;;    yes => #f  do not run again this command
-	  ;;    no  => #t  ok to run the command
-	  (for-each ;; month
-	   (lambda (month)
-	     (for-each ;; dayofmonth
-	      (lambda (dom)
-		(for-each
-		 (lambda (hr) ;; hour
-		   (for-each
-		    (lambda (minute) ;; minute
-		      (let ((copy-now (apply vector (vector->list now-time))))
-			(vector-set! copy-now 0 0) ;; force seconds to zero
-			(vector-set! copy-now 1 minute)
-			(vector-set! copy-now 2 hr)
-			(vector-set! copy-now 3 dom)  ;; dom is already corrected for zero referenced
-			(vector-set! copy-now 4 month)
-			(let* ((copy-now-secs (local-time->seconds copy-now))
-			       (new-copy      (seconds->local-time copy-now-secs))) ;; remake the time vector
-			  (if (or (not cdayofweek)
-				  (equal? (vector-ref new-copy 6)
-					  cdayofweek)) ;; if the day is specified and a match OR if the day is NOT specified
-			      (if (or (not cdayofmonth)
-				      (equal? (vector-ref new-copy 3)
-					      (+ 1 cdayofmonth))) ;; if the month is specified and a match OR if the month is NOT specified
-				  (hash-table-set! all-times copy-now-secs new-copy))))))
-		    (if cmin
-			`(,cmin)  ;; if given cmin, have to use it
-			(list (- nmin 1) nmin (+ nmin 1))))) ;; minute
-		 (if chour
-		     `(,chour)
-		     (list (- nhour 1) nhour (+ nhour 1))))) ;; hour
-	      (if cdayofmonth
-		  `(,cdayofmonth)
-		  (list (- ndayofmonth 1) ndayofmonth (+ ndayofmonth 1)))))
-	   (if cmonth
-	       `(,cmonth)
-	       (list (- nmonth 1) nmonth (+ nmonth 1))))
-	  (let ((before #f)
-		(is-in  #f))
-	    (for-each
-	     (lambda (moment)
-	       (if (and before
-			(<= before now-seconds)
-			(>= moment now-seconds))
-		   (begin
-		     ;; (print)
-		     ;; (print "Before: " (time->string (seconds->local-time before)))
-		     ;; (print "Now:    " (time->string (seconds->local-time now-seconds)))
-		     ;; (print "After:  " (time->string (seconds->local-time moment)))
-		     ;; (print "Last:   " (time->string (seconds->local-time last-done)))
-		     (if (<  last-done before)
-			 (set! is-in before))
-		     ))
-	       (set! before moment))
-	     (sort (hash-table-keys all-times) <))
-	    is-in)))))
-
-(define (common:extended-cron  cron-str now-seconds-in last-done)
-  (let ((expanded-cron (common:cron-expand cron-str)))
-    (if (string? expanded-cron)
-	(common:cron-event expanded-cron now-seconds-in last-done)
-	(let loop ((hed (car expanded-cron))
-		   (tal (cdr expanded-cron)))
-	  (if (common:cron-event hed now-seconds-in last-done)
-	      #t
-	      (if (null? tal)
-		  #f
-		  (loop (car tal)(cdr tal))))))))
-
-;;======================================================================
-;; C O L O R S
-;;======================================================================
-      
-(define (common:name->iup-color name)
-  (case (string->symbol (string-downcase name))
-    ((red)    "223 33 49")
-    ((grey)   "192 192 192")
-    ((orange) "255 172 13")
-    ((purple) "This is unfinished ...")))
-
-;;======================================================================
-;; (define (common:get-color-for-state-status state status)
-;;   (case (string->symbol state)
-;;     ((COMPLETED)
-;;      (case (string->symbol status)
-;;        ((PASS)        "70  249 73")
-;;        ((WARN WAIVED) "255 172 13")
-;;        ((SKIP)        "230 230 0")
-;;        (else "223 33 49")))
-;;     ((LAUNCHED)         "101 123 142")
-;;     ((CHECK)            "255 100 50")
-;;     ((REMOTEHOSTSTART)  "50  130 195")
-;;     ((RUNNING)          "9   131 232")
-;;     ((KILLREQ)          "39  82  206")
-;;     ((KILLED)           "234 101 17")
-;;     ((NOT_STARTED)      "240 240 240")
-;;     (else               "192 192 192")))
-
-(define (common:iup-color->rgb-hex instr)
-  (string-intersperse 
-   (map (lambda (x)
-          (number->string x 16))
-        (map string->number
-             (string-split instr)))
-   "/"))
-
-;;======================================================================
-;; L O C K I N G   M E C H A N I S M S 
-;;======================================================================
-
-;;======================================================================
-;; faux-lock is deprecated. Please use simple-lock below
-;;
-(define (common:faux-lock keyname #!key (wait-time 8)(allow-lock-steal #t))
-  (if (rmt:no-sync-get/default keyname #f) ;; do not be tempted to compare to pid. locking is a one-shot action, if already locked for this pid it doesn't actually count
-      (if (> wait-time 0)
-	  (begin
-	    (thread-sleep! 1)
-	    (if (eq? wait-time 1) ;; only one second left, steal the lock
-		(begin
-		  (debug:print-info 0 *default-log-port* "stealing lock for " keyname)
-		  (common:faux-unlock keyname force: #t)))
-	    (common:faux-lock keyname wait-time: (- wait-time 1)))
-	  #f)
-      (begin
-        (rmt:no-sync-set keyname (conc (current-process-id)))
-        (equal? (conc (current-process-id)) (conc (rmt:no-sync-get/default keyname #f))))))
-
-(define (common:faux-unlock keyname #!key (force #f))
-  (if (or force (equal? (conc (current-process-id)) (conc (rmt:no-sync-get/default keyname #f))))
-      (begin
-        (if (rmt:no-sync-get/default keyname #f) (rmt:no-sync-del! keyname))
-        #t)
-      #f))
-
-;;======================================================================
-;; simple lock. improve and converge on this one.
-;;
-(define (common:simple-lock keyname)
-  (rmt:no-sync-get-lock keyname))
-
-(define (common:simple-unlock keyname #!key (force #f))
-  (rmt:no-sync-del! keyname))
-
-;;======================================================================
-;;
-;;======================================================================
-
-(define (common:in-running-test?)
-  (and (args:get-arg "-execute") (get-environment-variable "MT_CMDINFO")))
-
-(define (common:get-color-from-status status)
-  (cond
-   ((equal? status "PASS")    "green")
-   ((equal? status "FAIL")    "red")
-   ((equal? status "WARN")    "orange")
-   ((equal? status "KILLED")  "orange")
-   ((equal? status "KILLREQ") "purple")
-   ((equal? status "RUNNING") "blue")
-   ((equal? status "ABORT")   "brown")
-   (else "black")))
-
-;;======================================================================
-;; N A N O M S G   C L I E N T
-;;======================================================================
-;; 
-;; 
-;; 
-;; (define (common:send-dboard-main-changed)
-;;   (let* ((dashboard-ips (mddb:get-dashboards)))
-;;     (for-each
-;;      (lambda (ipadr)
-;;        (let* ((soc (common:open-nm-req (conc "tcp://" ipadr)))
-;; 	      (msg (conc "main " *toppath*))
-;; 	      (res (common:nm-send-receive-timeout soc msg)))
-;; 	 (if (not res) ;; couldn't reach that dashboard - remove it from db
-;; 	     (print "ERROR: couldn't reach dashboard " ipadr))
-;; 	 res))
-;;      dashboard-ips)))
-;;     
-;;     
-;; ;;======================================================================
-;; ;; D A S H B O A R D   D B 
-;; ;;======================================================================
-;; 
-;; (define (mddb:open-db)
-;;   (let* ((db (open-database (conc (get-environment-variable "HOME") "/.dashboard.db"))))
-;;     (set-busy-handler! db (busy-timeout 10000))
-;;     (for-each
-;;      (lambda (qry)
-;;        (exec (sql db qry)))
-;;      (list 
-;;       "CREATE TABLE IF NOT EXISTS vars       (id INTEGER PRIMARY KEY,key TEXT, val TEXT, CONSTRAINT varsconstraint UNIQUE (key));"
-;;       "CREATE TABLE IF NOT EXISTS dashboards (
-;;           id         INTEGER PRIMARY KEY,
-;;           pid        INTEGER,
-;;           username   TEXT,
-;;           hostname   TEXT,
-;;           ipaddr     TEXT,
-;;           portnum    INTEGER,
-;;           start_time TIMESTAMP DEFAULT (strftime('%s','now')),
-;;              CONSTRAINT hostport UNIQUE (hostname,portnum)
-;;         );"
-;;       ))
-;;     db))
-;; 
-;; ;; register a dashboard 
-;; ;;
-;; (define (mddb:register-dashboard port)
-;;   (let* ((pid      (current-process-id))
-;; 	 (hostname (get-host-name))
-;; 	 (ipaddr   (server:get-best-guess-address hostname))
-;; 	 (username (current-user-name)) ;; (car userinfo)))
-;; 	 (db      (mddb:open-db)))
-;;     (print "Register monitor, pid: " pid ", hostname: " hostname ", port: " port ", username: " username)
-;;     (exec (sql db "INSERT OR REPLACE INTO dashboards (pid,username,hostname,ipaddr,portnum) VALUES (?,?,?,?,?);")
-;; 	   pid username hostname ipaddr port)
-;;     (close-database db)))
-;; 
-;; ;; unregister a monitor
-;; ;;
-;; (define (mddb:unregister-dashboard host port)
-;;   (let* ((db      (mddb:open-db)))
-;;     (print "Register unregister monitor, host:port=" host ":" port)
-;;     (exec (sql db "DELETE FROM dashboards WHERE hostname=? AND portnum=?;") host port)
-;;     (close-database db)))
-;; 
-;; ;; get registered dashboards
-;; ;;
-;; (define (mddb:get-dashboards)
-;;   (let ((db (mddb:open-db)))
-;;     (query fetch-column
-;; 	   (sql db "SELECT ipaddr || ':' || portnum FROM dashboards;"))))
-    
-;;======================================================================
-;;  T E S T   L A U N C H I N G   P E R   I T E M   W I T H   H O S T   T Y P E S
-;;======================================================================
-;; 
-;; [hosts]
-;; arm cubie01 cubie02
-;; x86_64 zeus xena myth01
-;; allhosts #{g hosts arm} #{g hosts x86_64}
-;; 
-;; [host-types]
-;; general #MTLOWESTLOAD #{g hosts allhosts}
-;; arm     #MTLOWESTLOAD #{g hosts arm}
-;; nbgeneral nbjob run JOBCOMMAND -log $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME.$MT_TESTNAME-$MT_ITEM_PATH.lgo
-;;
-;; [host-rules]
-;; # maxnload   => max normalized load
-;; # maxnjobs   => max jobs per cpu
-;; # maxjobrate => max jobs per second
-;; general maxnload=1.1; maxnjobs=1.2; maxjobrate=0.1 
-;; 
-;; [launchers]
-;; envsetup general
-;; xor/%/n 4C16G
-;; % nbgeneral
-;; 
-;; [jobtools]
-;; # if defined and not "no" flexi-launcher will bypass "launcher" unless no match.
-;; flexi-launcher yes  
-;; launcher nbfake
-;;
-(define (common:get-launcher configdat testname itempath)
-  (let ((fallback-launcher (configf:lookup configdat "jobtools" "launcher")))
-    (if (and (configf:lookup configdat "jobtools" "flexi-launcher") ;; overrides launcher
-	     (not (equal? (configf:lookup configdat "jobtools" "flexi-launcher") "no")))
-	(let* ((launchers         (hash-table-ref/default configdat "launchers" '())))
-	  (if (null? launchers)
-	      fallback-launcher
-	      (let loop ((hed (car launchers))
-			 (tal (cdr launchers)))
-		(let ((patt      (car hed))
-		      (host-type (cadr hed)))
-		  (if (tests:match patt testname itempath)
-		      (begin
-			(debug:print-info 2 *default-log-port* "Have flexi-launcher match for " testname "/" itempath " = " host-type)
-			(let ((launcher (configf:lookup configdat "host-types" host-type)))
-			  (if launcher
-			      (let* ((launcher-parts (string-split launcher))
-				     (launcher-exe   (car launcher-parts)))
-				(if (equal? launcher-exe "#MTLOWESTLOAD") ;; this is our special case, we will find the lowest load and craft a nbfake commandline
-				    (let host-loop ((targ-host (common:get-least-loaded-host (cdr launcher-parts) host-type configdat))
-						    (count     100))
-				      (if targ-host
-					  (conc "remrun " targ-host)
-					  (if (> count 0)
-					      (begin
-						(debug:print 0 *default-log-port* "INFO: Waiting for a host for host-type " host-type)
-						(thread-sleep! (- 101 count))
-						(host-loop (common:get-least-loaded-host (cdr launcher-parts) host-type configdat)
-							   (- count 1)))
-					      (begin
-						(debug:print 0 *default-log-port* "FATAL: Failed to find a host from #MTLOWESTLOAD for host-type " host-type)
-						(exit)))))
-				    launcher))
-			      (begin
-				(debug:print-info 0 *default-log-port* "WARNING: no launcher found for host-type " host-type)
-				(if (null? tal)
-				    fallback-launcher
-				    (loop (car tal)(cdr tal)))))))
-		      ;; no match, try again
-		      (if (null? tal)
-			  fallback-launcher
-			  (loop (car tal)(cdr tal))))))))
-	fallback-launcher)))
-
-;;======================================================================
-;; NMSG AND NEW API
-;;======================================================================
-;; 
-;; ;;======================================================================
-;; ;; nm based server experiment, keep around for now.
-;; ;;
-;; (define (nm:start-server dbconn #!key (given-host-name #f))
-;;   (let* ((srvdat    (start-raw-server given-host-name: given-host-name))
-;; 	 (host-name (srvdat-host srvdat))
-;; 	 (soc       (srvdat-soc srvdat)))
-;;     
-;;     ;; start the queue processor (save for second round of development)
-;;     ;;
-;;     (thread-start! (make-thread! (lambda ()(queue-processor dbconn) "Queue processor")))
-;;     ;; msg is an alist
-;;     ;;  'r host:port  <== where to return the data
-;;     ;;  'p params     <== data to apply the command to
-;;     ;;  'e j|s|l      <== encoding of the params. default is s (sexp), if not specified is assumed to be default
-;;     ;;  'c command    <== look up the function to call using this key
-;;     ;;
-;;     (let loop ((msg-in (nn-recv soc)))
-;;       (if (not (equal? msg-in "quit"))
-;; 	  (let* ((dat        (decode msg-in))
-;; 		 (host-port  (alist-ref 'r dat)) ;; this is for the reverse req rep where the server is a client of the original client
-;; 		 (params     (alist-ref 'p dat))
-;; 		 (command    (let ((c (alist-ref 'c dat)))(if c (string->symbol c) #f)))
-;; 		 (all-good   (and host-port params command (hash-table-exists? *commands* command))))
-;; 	    (if all-good
-;; 		(let ((cmddat (make-qitem
-;; 			       command:   command
-;; 			       host-port: host-port
-;; 			       params:    params)))
-;; 		  (queue-push cmddat) 		;; put request into the queue
-;; 		  (nn-send soc "queued"))         ;; reply with "queued"
-;; 		(print "ERROR: ["(common:human-time)"] BAD request " dat))
-;; 	    (loop (nn-recv soc)))))
-;;     (nn-close soc)))
-
-;;======================================================================
-;; D A S H B O A R D   U S E R   V I E W S
-;;======================================================================
-
-;;======================================================================
-;; first read ~/views.config if it exists, then read $MTRAH/views.config if it exists
-;;
-(define (common:load-views-config)
-  (let* ((view-cfgdat    (make-hash-table))
-	 (home-cfgfile   (conc (get-environment-variable "HOME") "/.mtviews.config"))
-	 (mthome-cfgfile (conc *toppath* "/.mtviews.config")))
-    (if (common:file-exists? mthome-cfgfile)
-	(read-config mthome-cfgfile view-cfgdat #t))
-    ;; we load the home dir file AFTER the MTRAH file so the user can clobber settings when running the dashboard in read-only areas
-    (if (common:file-exists? home-cfgfile)
-	(read-config home-cfgfile view-cfgdat #t))
-    view-cfgdat))
-
-;;======================================================================
-;; H I E R A R C H I C A L   H A S H   T A B L E S
-;;======================================================================
-;;
-;; Every element including top element is a vector:
-;;   <vector subhash value>
-
-(define (hh:make-hh #!key (ht #f)(value #f))
-  (vector (or ht    (make-hash-table)) value))
-
-;;======================================================================
-;; used internally
-(define-inline (hh:set-ht! hh ht)       (vector-set! hh 0 ht))
-(define-inline (hh:get-ht hh)           (vector-ref  hh 0))
-(define-inline (hh:set-value! hh value) (vector-set! hh 1 value))
-(define-inline (hh:get-value  hh value) (vector-ref  hh 1))
-
-;;======================================================================
-;; given a hierarchial hash and some keys look up the value ...
-;;
-(define (hh:get hh . keys)
-  (if (null? keys)
-      (vector-ref hh 1) ;; we have reached the end of the line, return the value sought
-      (let ((sub-ht (hh:get-ht hh)))
-	(if sub-ht ;; yes, there is more hierarchy
-	    (let ((sub-hh (hash-table-ref/default sub-ht (car keys) #f)))
-	      (if sub-hh
-		  (apply hh:get sub-hh (cdr keys))
-		  #f))
-	    #f))))
-
-;;======================================================================
-;; given a hierarchial hash, a value and some keys, add needed hierarcy and insert the value
-;;
-(define (hh:set! hh value . keys)
-  (if (null? keys)
-      (hh:set-value! hh value) ;; we have reached the end of the line, store the value
-      (let ((sub-ht (hh:get-ht hh)))
-	(if sub-ht ;; yes, there is more hierarchy
-	    (let ((sub-hh (hash-table-ref/default sub-ht (car keys) #f)))
-	      (if (not sub-hh) ;; we'll need to add the next level of hierarchy
-		  (let ((new-sub-hh (hh:make-hh)))
-		    (hash-table-set! sub-ht (car keys) new-sub-hh)
-		    (apply hh:set! new-sub-hh value (cdr keys)))
-		  (apply hh:set! sub-hh value (cdr keys))))    ;; call the sub-hierhash with remaining keys
-	    (begin
-	      (hh:set-ht! hh (make-hash-table))
-	      (apply hh:set! hh value keys))))))
-
-;;======================================================================
-;; Manage pkts, used in servers, tests and likely other contexts so put
-;; in common
-;;======================================================================
-
-(define common:pkts-spec
-  '((default . ((parent    . P)
-                (action    . a)
-                (filename  . f)))
-    (configf . ((parent    . P)
-                (action    . a)
-                (filename  . f)))
-    (server  . ((action    . a)
-		(pid       . d)
-		(ipaddr    . i)
-		(port      . p)
-		(parent    . P)))
-    			  
-    (test    . ((cpuuse    . c)
-		(diskuse   . d)
-		(item-path . i)
-		(runname   . r)
-		(state     . s)
-		(target    . t)
-		(status    . u)
-		(parent    . P)))))
-
-(define (common:get-pkts-dirs mtconf use-lt)
-  (let* ((pktsdirs-str (or (configf:lookup mtconf "setup"  "pktsdirs")
-			   (and use-lt
-				(conc (or *toppath*
-					  (current-directory))
-				      "/lt/.pkts"))))
-	 (pktsdirs  (if pktsdirs-str
-			(string-split pktsdirs-str " ")
-			#f)))
-    pktsdirs))
-
-;;======================================================================
-;; use-lt is use linktree "lt" link to find pkts dir
-(define (common:save-pkt pktalist-in mtconf use-lt #!key (add-only #f)) ;; add-only saves the pkt only if there is a parent already
-  (if (or add-only
-	  (hash-table-exists? *pkts-info* 'last-parent))
-      (let* ((parent   (hash-table-ref/default *pkts-info* 'last-parent #f))
-	     (pktalist (if parent
-			   (cons `(parent . ,parent)
-				 pktalist-in)
-			   pktalist-in)))
-	(let-values (((uuid pkt)
-		      (alist->pkt pktalist common:pkts-spec)))
-	  (hash-table-set! *pkts-info* 'last-parent uuid)
-	  (let ((pktsdir (or (hash-table-ref/default *pkts-info* 'pkts-dir #f)
-			     (let* ((pktsdirs (common:get-pkts-dirs mtconf use-lt))
-				    (pktsdir   (car pktsdirs))) ;; assume it is there
-			       (hash-table-set! *pkts-info* 'pkts-dir pktsdir)
-			       pktsdir))))
-            (handle-exceptions
-             exn
-             (debug:print-info 0 "failed to write out packet to " pktsdir ", exn=" exn) ;; don't care if this failed for now but MUST FIX - BUG!!
-             (if (not (file-exists? pktsdir))
-                 (create-directory pktsdir #t))
-             (with-output-to-file
-                 (conc pktsdir "/" uuid ".pkt")
-               (lambda ()
-                 (print pkt)))))))))
-	
-(define (common:with-queue-db mtconf proc #!key (use-lt #f)(toppath-in #f))
-  (let* ((pktsdirs (common:get-pkts-dirs mtconf use-lt))
-	 (pktsdir  (if pktsdirs (car pktsdirs) #f))
-	 (toppath  (or (configf:lookup mtconf "scratchdat" "toppath")
-		       toppath-in))
-	 (pdbpath  (or (configf:lookup mtconf "setup"  "pdbpath") pktsdir)))
-    (cond
-     ((not (and  pktsdir toppath pdbpath))
-      (debug:print 0 *default-log-port* "ERROR: settings are missing in your megatest.config for area management.")
-      (debug:print  0 *default-log-port* "  you need to have pktsdirs in the [setup] section."))
-     ((not (common:file-exists? pktsdir))
-      (debug:print 0 *default-log-port* "ERROR: pkts directory not found " pktsdir))
-     ((not (equal? (file-owner pktsdir)(current-effective-user-id)))
-      (debug:print 0 *default-log-port* "ERROR: directory " pktsdir " is not owned by " (current-effective-user-name)))
-     (else
-	(let* ((pdb  (open-queue-db pdbpath "pkts.db"
-				    schema: '("CREATE TABLE groups (id INTEGER PRIMARY KEY,groupname TEXT, CONSTRAINT group_constraint UNIQUE (groupname));"))))
-	  (proc pktsdirs pktsdir pdb)
-	  (dbi:close pdb))))))
+;; from metadat lookup MEGATEST_VERSION
+;;
+(define (common:get-last-run-version) ;; RADT => How does this work in send-receive function??; assume it is the value saved in some DB
+  (rmt:get-var "MEGATEST_VERSION"))
+
+(define (common:set-last-run-version)
+  (rmt:set-var "MEGATEST_VERSION" (common:version-signature)))
+
+(define (common:get-last-run-version-number)
+  (string->number 
+   (substring (common:get-last-run-version) 0 6)))
+
+;;======================================================================
+;; postive number if megatest version > db version
+;; negative number if megatest version < db version
+(define (common:version-db-delta)
+         (- megatest-version (common:get-last-run-version-number)))
+
+(define (common:version-changed?)
+  (not (equal? (common:get-last-run-version)
+               (common:version-signature))))
+
+(define (common:api-changed?)
+  (not (equal? (substring (->string megatest-version) 0 4)
+               (substring (conc (common:get-last-run-version)) 0 4))))
+
+;;======================================================================
+;; Move me elsewhere ...
+;; RADT => Why do we meed the version check here, this is called only if version misma
+;;
+(define (common:cleanup-db dbstruct #!key (full #f))
+  (apply db:multi-db-sync 
+   dbstruct
+   'schema
+   ;; 'new2old
+   'killservers
+   'adj-target
+   ;; 'old2new
+   'new2old
+   ;; (if full
+       '(dejunk)
+       ;; '())
+       )
+  (if (common:api-changed?)
+      (common:set-last-run-version)))
+
+;;======================================================================
+;; use to transition to area-name
+(define common:get-area-name common:get-testsuite-name)
 
 (define (common:load-pkts-to-db mtconf #!key (use-lt #f))
   (common:with-queue-db
    mtconf
    (lambda (pktsdirs pktsdir pdb)
@@ -3519,161 +1313,34 @@
 		     )))
 	     pkts)))))
       pktsdirs))
    use-lt: use-lt))
 
-(define (common:get-pkt-alists pkts)
-  (map (lambda (x)
-	 (alist-ref 'apkt x)) ;; 'pkta pulls out the alist from the read pkt
-       pkts))
-
-;;======================================================================
-;; given list of pkts (alist mode) return list of D cards as Unix epoch, sorted descending
-;; also delete duplicates by target i.e. (car pkt)
-;;
-(define (common:get-pkt-times pkts)
-  (delete-duplicates
-   (sort 
-    (map (lambda (x)
-	   `(,(alist-ref 't x) . ,(string->number (alist-ref 'D x))))
-	 pkts)
-    (lambda (a b)(> (cdr a)(cdr b))))      ;; sort descending
-   (lambda (a b)(equal? (car a)(car b))))) ;; remove duplicates by target
-
-;;======================================================================
-;; accept an alist or hash table containing envvar/env value pairs (value of #f causes unset) 
-;;   execute thunk in context of environment modified as per this list
-;;   restore env to prior state then return value of eval'd thunk.
-;;   ** this is not thread safe **
-(define (common:with-env-vars delta-env-alist-or-hash-table thunk)
-  (let* ((delta-env-alist (if (hash-table? delta-env-alist-or-hash-table)
-                              (hash-table->alist delta-env-alist-or-hash-table)
-                              delta-env-alist-or-hash-table))
-         (restore-thunks
-          (filter
-           identity
-           (map (lambda (env-pair)
-                  (let* ((env-var     (car env-pair))
-                         (new-val     (let ((tmp (cdr env-pair)))
-                                        (if (list? tmp) (car tmp) tmp)))
-                         (current-val (get-environment-variable env-var))
-                         (restore-thunk
-                          (cond
-                           ((not current-val) (lambda () (unsetenv env-var)))
-                           ((not (string? new-val)) #f)
-                           ((eq? current-val new-val) #f)
-                           (else 
-                            (lambda () (setenv env-var current-val))))))
-                    ;;(when (not (string? new-val))
-                    ;;    (debug:print 0 *default-log-port* " PROBLEM: not a string: "new-val"\n from env-alist:\n"delta-env-alist)
-                    ;;    (pp delta-env-alist)
-                    ;;    (exit 1))
-                        
-                    
-                    (cond
-                     ((not new-val)  ;; modify env here
-                      (unsetenv env-var))
-                     ((string? new-val)
-                      (setenv env-var new-val)))
-                    restore-thunk))
-                delta-env-alist))))
-    (let ((rv (thunk)))
-      (for-each (lambda (x) (x)) restore-thunks) ;; restore env to original state
-      rv)))
-
-(define *common:thread-punchlist* (make-hash-table))
-(define (common:send-thunk-to-background-thread thunk #!key (name #f))
-  ;;(BB> "launched thread " name)
-  ;; we need a unique name for the thread.
-  (let* ((realname (if name
-                       (if (not (hash-table-ref/default *common:thread-punchlist* name #f))
-                           name
-                           (conc name"-" (symbol->string (gensym))))
-                       (conc "anonymous-"(symbol->string (gensym)))))
-         (realthunk (lambda ()
-                      (let ((res (thunk)))
-                        (hash-table-delete! *common:thread-punchlist* realname)
-                        res)))
-         (thread   (make-thread realthunk realname)))
-    (hash-table-set! *common:thread-punchlist* realname thread)
-    (thread-start! thread)
-    ))
-
-(define (common:join-backgrounded-threads)
-  ;; may need to trap and ignore exceptions -- dunno how atomic threads are...
-  (for-each
-   (lambda (thread-name)
-     (let* ((thread (hash-table-ref/default *common:thread-punchlist* thread-name #f)))
-       (if thread
-           (handle-exceptions
-               exn
-	     (begin
-	       (debug:print 0 *default-log-port* "joining threads failed. exn=" exn)
-               #t) ;; just ignore it, it might have died in the meantime so joining it will throw an exception
-             (thread-join! thread))
-           )))
-   (hash-table-keys *common:thread-punchlist*)))
-
-;;======================================================================
-;; (define *common:telemetry-log-state* 'startup)
-;; (define *common:telemetry-log-socket* #f)
-;; 
-;; (define (common:telemetry-log-open)
-;;   (if (eq? *common:telemetry-log-state* 'startup)
-;;       (let* ((serverhost (configf:lookup *configdat* "telemetry" "host"))
-;;              (serverport (configf:lookup-number *configdat* "telemetry" "port"))
-;;              (user (or (get-environment-variable "USER") "unknown"))
-;;              (host (or (get-environment-variable "HOST") "unknown")))
-;;         (set! *common:telemetry-log-state*
-;;               (handle-exceptions
-;;                exn
-;;                (begin
-;;                  (debug:print-info 0 *default-log-port* "common-telemetry-log open udp port failure")
-;;                  'broken)
-;;                (if (and serverhost serverport user host)
-;;                    (let* ((s (udp-open-socket)))
-;;                      ;;(udp-bind! s #f 0)
-;;                      (udp-connect! s serverhost serverport)
-;;                      (set! *common:telemetry-log-socket* s)
-;;                      'open)
-;;                    'not-needed))))))
-;;   
-;; (define (common:telemetry-log event #!key (payload '()))
-;;   (if (eq? *common:telemetry-log-state* 'startup)
-;;       (common:telemetry-log-open))
-;; 
-;;   (if (eq? 'open *common:telemetry-log-state*)
-;;       (handle-exceptions
-;;        exn
-;;        (begin
-;;          (debug:print-info 0 *default-log-port* "common-telemetry-log comms failure ; disabled (no server?)")
-;;          ;;(define *common:telemetry-log-state* 'broken-or-no-server-preclose)
-;;          ;;(common:telemetry-log-close)
-;;          (define *common:telemetry-log-state* 'broken-or-no-server)
-;;          (set! *common:telemetry-log-socket* #f)
-;;          )
-;;        (if (and *common:telemetry-log-socket* event) ;; TODO - filter on event against telemetry.want-events
-;;            (let* ((user (or (get-environment-variable "USER") "unknown"))
-;;                   (host (or (get-environment-variable "HOST") "unknown"))
-;;                   (start (conc "[megatest "event"]"))
-;;                   (toppath (or *toppath* "/dev/null"))
-;;                   (payload-serialized
-;;                    (base64:base64-encode
-;;                     (z3:encode-buffer
-;;                      (with-output-to-string (lambda () (pp payload))))))
-;;                   (msg     (conc user":"host":"start":"(current-process-id)":"(car (argv))":"
-;;                                  toppath":"payload-serialized)))
-;;              (udp-send *common:telemetry-log-socket* msg))))))
-;;   
-;; (define (common:telemetry-log-close)
-;;   (when (or (member *common:telemetry-log-state* '(broken-or-no-server-preclose open)) *common:telemetry-log-socket*)
-;;     (handle-exceptions
-;;      exn
-;;      (begin
-;;        (define *common:telemetry-log-state* 'closed-fail)
-;;        (debug:print-info 0 *default-log-port* "common-telemetry-log closure failure")
-;;        )
-;;      (begin
-;;        (define *common:telemetry-log-state* 'closed)
-;;        (udp-close-socket *common:telemetry-log-socket*)
-;;        (set! *common:telemetry-log-socket* #f)))))
-
+;;======================================================================
+;; use-lt is use linktree "lt" link to find pkts dir
+(define (common:save-pkt pktalist-in mtconf use-lt #!key (add-only #f)) ;; add-only saves the pkt only if there is a parent already
+  (if (or add-only
+	  (hash-table-exists? *pkts-info* 'last-parent))
+      (let* ((parent   (hash-table-ref/default *pkts-info* 'last-parent #f))
+	     (pktalist (if parent
+			   (cons `(parent . ,parent)
+				 pktalist-in)
+			   pktalist-in)))
+	(let-values (((uuid pkt)
+		      (alist->pkt pktalist common:pkts-spec)))
+	  (hash-table-set! *pkts-info* 'last-parent uuid)
+	  (let ((pktsdir (or (hash-table-ref/default *pkts-info* 'pkts-dir #f)
+			     (let* ((pktsdirs (common:get-pkts-dirs mtconf use-lt))
+				    (pktsdir   (car pktsdirs))) ;; assume it is there
+			       (hash-table-set! *pkts-info* 'pkts-dir pktsdir)
+			       pktsdir))))
+            (handle-exceptions
+             exn
+             (debug:print-info 0 "failed to write out packet to " pktsdir ", exn=" exn) ;; don't care if this failed for now but MUST FIX - BUG!!
+             (if (not (file-exists? pktsdir))
+                 (create-directory pktsdir #t))
+             (with-output-to-file
+                 (conc pktsdir "/" uuid ".pkt")
+               (lambda ()
+                 (print pkt)))))))))
+;;        (set! *common:telemetry-log-socket* #f)))))
+	

Index: common_records.scm
==================================================================
--- common_records.scm
+++ common_records.scm
@@ -77,177 +77,176 @@
   (mutex-lock! mtx)
   (let ((res (apply accessor record val)))
     (mutex-unlock! mtx)
     res))
 
-;; this was cached based on results from profiling but it turned out the profiling
-;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching
-;; in for now but can probably take it out later.
-;;
-(define (debug:calc-verbosity vstr)
-  (or (hash-table-ref/default *verbosity-cache* vstr #f)
-      (let ((res (cond
-                  ((number? vstr) vstr)
-                  ((not (string?  vstr))   1)
-                  ;; ((string-match  "^\\s*$" vstr) 1)
-                  (vstr           (let ((debugvals  (filter number? (map string->number (string-split vstr ",")))))
-                                    (cond
-                                     ((> (length debugvals) 1) debugvals)
-                                     ((> (length debugvals) 0)(car debugvals))
-                                     (else 1))))
-                  ((args:get-arg "-v")   2)
-                  ((args:get-arg "-q")    0)
-                  (else                   1))))
-        (hash-table-set! *verbosity-cache* vstr res)
-        res)))
-
-;; check verbosity, #t is ok
-(define (debug:check-verbosity verbosity vstr)
-  (if (not (or (number? verbosity)
-	       (list?   verbosity)))
-      (begin
-	(print "ERROR: Invalid debug value \"" vstr "\"")
-	#f)
-      #t))
-
-(define (debug:debug-mode n)
-  (cond
-   ((and (number? *verbosity*)   ;; number number
-	 (number? n))
-    (<= n *verbosity*))
-   ((and (list? *verbosity*)     ;; list   number
-	 (number? n))
-    (member n *verbosity*))
-   ((and (list? *verbosity*)     ;; list   list
-	 (list? n))
-    (not (null? (lset-intersection! eq? *verbosity* n))))
-   ((and (number? *verbosity*)
-	 (list? n))
-    (member *verbosity* n))))
-
-(define (debug:setup)
-  (let ((debugstr (or (args:get-arg "-debug")
-		      (args:get-arg "-debug-noprop")
-		      (getenv "MT_DEBUG_MODE"))))
-    (set! *verbosity* (debug:calc-verbosity debugstr))
-    (debug:check-verbosity *verbosity* debugstr)
-    ;; if we were handed a bad verbosity rule then we will override it with 1 and continue
-    (if (not *verbosity*)(set! *verbosity* 1))
-    (if (and (not (args:get-arg "-debug-noprop"))
-	     (or (args:get-arg "-debug")
-		 (not (getenv "MT_DEBUG_MODE"))))
-	(setenv "MT_DEBUG_MODE" (if (list? *verbosity*)
-				    (string-intersperse (map conc *verbosity*) ",")
-				    (conc *verbosity*))))))
-  
-(define (debug:print n e . params)
-  (if (debug:debug-mode n)
-      (with-output-to-port (or e (current-error-port))
-	(lambda ()
-	  (if *logging*
-	      (db:log-event (apply conc params))
-	      (apply print params)
-	      )))))
-
-;; Brandon's debug printer shortcut (indulge me :)
-(define *BB-process-starttime* (current-milliseconds))
-(define (BB> . in-args)
-  (let* ((stack (get-call-chain))
-         (location "??"))
-    (for-each
-     (lambda (frame)
-       (let* ((this-loc (vector-ref frame 0))
-              (temp     (string-split (->string this-loc) " "))
-              (this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???")))
-         (if (equal? this-func "BB>")
-             (set! location this-loc))))
-     stack)
-    (let* ((color-on "\x1b[1m")
-           (color-off "\x1b[0m")
-           (dp-args
-            (append
-             (list 0 *default-log-port*
-                   (conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off "   ")  )
-             in-args)))
-      (apply debug:print dp-args))))
-
-(define *BBpp_custom_expanders_list* (make-hash-table))
-
-
-
-;; register hash tables with BBpp.
-(hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE:
-                 (cons hash-table? hash-table->alist))
-
-;; test name converter
-(define (BBpp_custom_converter arg)
-  (let ((res #f))
-    (for-each
-     (lambda (custom-type-name)
-       (let* ((custom-type-info      (hash-table-ref *BBpp_custom_expanders_list* custom-type-name))
-              (custom-type-test      (car custom-type-info))
-              (custom-type-converter (cdr custom-type-info)))
-         (when (and (not res) (custom-type-test arg))
-           (set! res (custom-type-converter arg)))))
-     (hash-table-keys *BBpp_custom_expanders_list*))
-    (if res (BBpp_ res) arg)))
-
-(define (BBpp_ arg)
-  (cond
-   ;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg)))
-   ;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg)))
-   ((hash-table? arg)
-    (let ((al (hash-table->alist arg)))
-      (BBpp_ (cons HASH_TABLE: al))))
-   ((null? arg) '())
-   ;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
-   ((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
-   (else (BBpp_custom_converter arg))))
-
-;; Brandon's pretty printer.  It expands hashes and custom types in addition to regular pp
-(define (BBpp arg)
-  (pp (BBpp_ arg)))
-
-;(use define-macro)
-(define-syntax inspect
-  (syntax-rules ()
-    [(_ x)
-    ;; (with-output-to-port (current-error-port)
-       (printf "~a is: ~a\n" 'x (with-output-to-string (lambda () (BBpp x))))
-     ;;  )
-     ]
-    [(_ x y ...) (begin (inspect x) (inspect y ...))]))
-
-(define (debug:print-error n e . params)
-  ;; normal print
-  (if (debug:debug-mode n)
-      (with-output-to-port (if (port? e) e (current-error-port))
-	(lambda ()
-	  (if *logging*
-	      (db:log-event (apply conc params))
-	      ;; (apply print "pid:" (current-process-id) " " params)
-	      (apply print "ERROR: " params)
-	      ))))
-  ;; pass important messages to stderr
-  (if (and (eq? n 0)(not (eq? e (current-error-port)))) 
-      (with-output-to-port (current-error-port)
-	(lambda ()
-	  (apply print "ERROR: " params)
-	  ))))
-
-(define (debug:print-info n e . params)
-  (if (debug:debug-mode n)
-      (with-output-to-port (if (port? e) e (current-error-port))
-	(lambda ()
-	  (if *logging*
-	      (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params))))
-		(db:log-event res))
-	      ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res)
-	      (apply print "INFO: (" n ") " params) ;; res)
-	      )))))
-
-
+;; ;; this was cached based on results from profiling but it turned out the profiling
+;; ;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching
+;; ;; in for now but can probably take it out later.
+;; ;;
+;; (define (debug:calc-verbosity vstr)
+;;   (or (hash-table-ref/default *verbosity-cache* vstr #f)
+;;       (let ((res (cond
+;;                   ((number? vstr) vstr)
+;;                   ((not (string?  vstr))   1)
+;;                   ;; ((string-match  "^\\s*$" vstr) 1)
+;;                   (vstr           (let ((debugvals  (filter number? (map string->number (string-split vstr ",")))))
+;;                                     (cond
+;;                                      ((> (length debugvals) 1) debugvals)
+;;                                      ((> (length debugvals) 0)(car debugvals))
+;;                                      (else 1))))
+;;                   ((args:get-arg "-v")   2)
+;;                   ((args:get-arg "-q")    0)
+;;                   (else                   1))))
+;;         (hash-table-set! *verbosity-cache* vstr res)
+;;         res)))
+;; 
+;; ;; check verbosity, #t is ok
+;; (define (debug:check-verbosity verbosity vstr)
+;;   (if (not (or (number? verbosity)
+;; 	       (list?   verbosity)))
+;;       (begin
+;; 	(print "ERROR: Invalid debug value \"" vstr "\"")
+;; 	#f)
+;;       #t))
+;; 
+;; (define (debug:debug-mode n)
+;;   (cond
+;;    ((and (number? *verbosity*)   ;; number number
+;; 	 (number? n))
+;;     (<= n *verbosity*))
+;;    ((and (list? *verbosity*)     ;; list   number
+;; 	 (number? n))
+;;     (member n *verbosity*))
+;;    ((and (list? *verbosity*)     ;; list   list
+;; 	 (list? n))
+;;     (not (null? (lset-intersection! eq? *verbosity* n))))
+;;    ((and (number? *verbosity*)
+;; 	 (list? n))
+;;     (member *verbosity* n))))
+;; 
+;; (define (debug:setup)
+;;   (let ((debugstr (or (args:get-arg "-debug")
+;; 		      (args:get-arg "-debug-noprop")
+;; 		      (getenv "MT_DEBUG_MODE"))))
+;;     (set! *verbosity* (debug:calc-verbosity debugstr))
+;;     (debug:check-verbosity *verbosity* debugstr)
+;;     ;; if we were handed a bad verbosity rule then we will override it with 1 and continue
+;;     (if (not *verbosity*)(set! *verbosity* 1))
+;;     (if (and (not (args:get-arg "-debug-noprop"))
+;; 	     (or (args:get-arg "-debug")
+;; 		 (not (getenv "MT_DEBUG_MODE"))))
+;; 	(setenv "MT_DEBUG_MODE" (if (list? *verbosity*)
+;; 				    (string-intersperse (map conc *verbosity*) ",")
+;; 				    (conc *verbosity*))))))
+;;   
+;; (define (debug:print n e . params)
+;;   (if (debug:debug-mode n)
+;;       (with-output-to-port (or e (current-error-port))
+;; 	(lambda ()
+;; 	  (if *logging*
+;; 	      (db:log-event (apply conc params))
+;; 	      (apply print params)
+;; 	      )))))
+;; 
+;; ;; Brandon's debug printer shortcut (indulge me :)
+;; (define *BB-process-starttime* (current-milliseconds))
+;; (define (BB> . in-args)
+;;   (let* ((stack (get-call-chain))
+;;          (location "??"))
+;;     (for-each
+;;      (lambda (frame)
+;;        (let* ((this-loc (vector-ref frame 0))
+;;               (temp     (string-split (->string this-loc) " "))
+;;               (this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???")))
+;;          (if (equal? this-func "BB>")
+;;              (set! location this-loc))))
+;;      stack)
+;;     (let* ((color-on "\x1b[1m")
+;;            (color-off "\x1b[0m")
+;;            (dp-args
+;;             (append
+;;              (list 0 *default-log-port*
+;;                    (conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off "   ")  )
+;;              in-args)))
+;;       (apply debug:print dp-args))))
+;; 
+;; (define *BBpp_custom_expanders_list* (make-hash-table))
+;; 
+;; 
+;; 
+;; ;; register hash tables with BBpp.
+;; (hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE:
+;;                  (cons hash-table? hash-table->alist))
+;; 
+;; ;; test name converter
+;; (define (BBpp_custom_converter arg)
+;;   (let ((res #f))
+;;     (for-each
+;;      (lambda (custom-type-name)
+;;        (let* ((custom-type-info      (hash-table-ref *BBpp_custom_expanders_list* custom-type-name))
+;;               (custom-type-test      (car custom-type-info))
+;;               (custom-type-converter (cdr custom-type-info)))
+;;          (when (and (not res) (custom-type-test arg))
+;;            (set! res (custom-type-converter arg)))))
+;;      (hash-table-keys *BBpp_custom_expanders_list*))
+;;     (if res (BBpp_ res) arg)))
+;; 
+;; (define (BBpp_ arg)
+;;   (cond
+;;    ;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg)))
+;;    ;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg)))
+;;    ((hash-table? arg)
+;;     (let ((al (hash-table->alist arg)))
+;;       (BBpp_ (cons HASH_TABLE: al))))
+;;    ((null? arg) '())
+;;    ;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
+;;    ((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
+;;    (else (BBpp_custom_converter arg))))
+;; 
+;; ;; Brandon's pretty printer.  It expands hashes and custom types in addition to regular pp
+;; (define (BBpp arg)
+;;   (pp (BBpp_ arg)))
+;; 
+;; ;(use define-macro)
+;; (define-syntax inspect
+;;   (syntax-rules ()
+;;     [(_ x)
+;;     ;; (with-output-to-port (current-error-port)
+;;        (printf "~a is: ~a\n" 'x (with-output-to-string (lambda () (BBpp x))))
+;;      ;;  )
+;;      ]
+;;     [(_ x y ...) (begin (inspect x) (inspect y ...))]))
+;; 
+;; (define (debug:print-error n e . params)
+;;   ;; normal print
+;;   (if (debug:debug-mode n)
+;;       (with-output-to-port (if (port? e) e (current-error-port))
+;; 	(lambda ()
+;; 	  (if *logging*
+;; 	      (db:log-event (apply conc params))
+;; 	      ;; (apply print "pid:" (current-process-id) " " params)
+;; 	      (apply print "ERROR: " params)
+;; 	      ))))
+;;   ;; pass important messages to stderr
+;;   (if (and (eq? n 0)(not (eq? e (current-error-port)))) 
+;;       (with-output-to-port (current-error-port)
+;; 	(lambda ()
+;; 	  (apply print "ERROR: " params)
+;; 	  ))))
+;; 
+;; (define (debug:print-info n e . params)
+;;   (if (debug:debug-mode n)
+;;       (with-output-to-port (if (port? e) e (current-error-port))
+;; 	(lambda ()
+;; 	  (if *logging*
+;; 	      (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params))))
+;; 		(db:log-event res))
+;; 	      ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res)
+;; 	      (apply print "INFO: (" n ") " params) ;; res)
+;; 	      )))))
+;; 
 
 ;; if a value is printable (i.e. string or number) return the value
 ;; else return an empty string
 (define-inline (printable val)
   (if (or (number? val)(string? val)) val ""))

Index: commonmod.scm
==================================================================
--- commonmod.scm
+++ commonmod.scm
@@ -21,14 +21,35 @@
 (declare (unit commonmod))
 
 (module commonmod
 	*
 	
-(import scheme chicken data-structures extras files)
-(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69
-	md5 message-digest
-	regex srfi-1)
+;;(import scheme chicken data-structures extras files ports)
+(import scheme chicken)
+(use data-structures extras files ports)
+(use 
+  (prefix base64 base64:)
+  (prefix sqlite3 sqlite3:) 
+  (srfi 18)
+  directory-utils
+  format
+  matchable
+  md5
+  message-digest
+  pkts
+  posix 
+  regex
+  regex-case
+  sparse-vectors
+  srfi-1
+  srfi-13
+  srfi-69
+  stack
+  typed-records 
+  z3
+ )
+	
 
 ;;======================================================================
 ;; CONTENTS
 ;;
 ;;  config file utils
@@ -38,16 +59,62 @@
 ;;======================================================================
 
 (include "megatest-version.scm")
 (include "megatest-fossil-hash.scm")
 
+;; Move globals here
+(define *default-log-port*  (current-error-port))
+(define *toppath*           #f)
+(define *configinfo*        #f)   ;; raw results from setup, includes toppath and table from megatest.config
+(define *db-with-db-mutex*  (make-mutex))
+(define *max-api-process-requests* 0)
+(define *common:denoise*    (make-hash-table)) ;; for low noise printing
+(define *api-process-request-count* 0)
+(define *db-keys*           #f)
+(define *db-cache-path*     #f)
+
+(define *number-of-writes* 0)
+(define *number-non-write-queries* 0)
+
+(define *glob-like-match-cache* (make-hash-table))
+(define *numcpus-cache* (make-hash-table))
+
 (define (get-full-version)
   (conc megatest-version "-" megatest-fossil-hash))
 
 (define (version-signature)
   (conc megatest-version "-" (substring megatest-fossil-hash 0 4)))
 
+(defstruct remote
+  (hh-dat            #f) ;; (common:get-homehost)) ;; homehost record ( addr . hhflag )
+  (server-url        #f) ;; (server:check-if-running *toppath*) #f))
+  (server-id         #f)
+  (server-info       #f) ;; (if *toppath* (server:check-if-running *toppath*) #f))
+  (last-server-check 0)  ;; last time we checked to see if the server was alive
+  (conndat           #f)
+  (transport         #f) ;; *transport-type*)
+  (server-timeout    #f) ;; (server:expiration-timeout))
+  (force-server      #f)
+  (ro-mode           #f)  
+  (ro-mode-checked   #f)) ;; flag that indicates we have checked for ro-mode
+
+;; launching and hosts
+(defstruct host
+  (reachable    #f)
+  (last-update  0)
+  (last-used    0)
+  (last-cpuload 1))
+
+;;======================================================================
+;; V E R S I O N
+;;======================================================================
+
+(define (common:get-full-version)
+  (conc megatest-version "-" megatest-fossil-hash))
+
+(define (common:version-signature)
+  (conc megatest-version "-" (substring megatest-fossil-hash 0 4)))
 
 ;;======================================================================
 ;; config file utils
 ;;======================================================================
 
@@ -77,16 +144,18 @@
 
 ;;======================================================================
 ;; misc conversion, data manipulation functions
 ;;======================================================================
 
+;;======================================================================
 ;; if it looks like a number -> convert it to a number, else return it
 ;;
 (define (lazy-convert inval)
   (let* ((as-num (if (string? inval)(string->number inval) #f)))
     (or as-num inval)))
 
+;;======================================================================
 ;; to '((a . 1)(b . 2)(c . "a silly thing")(d . ""))
 ;;
 (define (val->alist val #!key (convert #f))
   (let ((val-list (string-split-fields ";\\s*" val #:infix)))
     (if val-list
@@ -106,31 +175,17 @@
 
 ;;======================================================================
 ;; testsuite and area utilites
 ;;======================================================================
 
-(define (get-testsuite-name toppath configdat)
-  (or (lookup configdat "setup" "area-name")
-      (lookup configdat "setup" "testsuite")
-      (get-environment-variable "MT_TESTSUITE_NAME")
-      (if (string? toppath)
-          (pathname-file toppath)
-          #f)))
-
 (define (get-area-path-signature toppath #!optional (short #f))
   (let ((res (message-digest-string (md5-primitive) toppath)))
     (if short
 	(substring res 0 4)
 	res)))
 
-(define (get-area-name configdat toppath #!optional (short #f))
-  ;; look up my area name in areas table (future)
-  ;; generate auto name
-  (conc (get-area-path-signature toppath short)
-	"-"
-	(get-testsuite-name toppath configdat)))
-
+;;======================================================================
 ;; need generic find-record-with-var-nmatching-val
 ;;
 (define (path->area-record cfgdat path)
   (let* ((areadat (get-cfg-areas cfgdat))
 	 (all     (filter (lambda (x)
@@ -140,23 +195,3064 @@
 			  areadat)))
     (if (null? all)
 	#f
 	(car all)))) ;; return first match
 
+;;======================================================================
 ;; given a config return an alist of alists
 ;;   area-name => data
 ;;
 (define (get-cfg-areas cfgdat)
   (let ((adat (get-section cfgdat "areas")))
     (map (lambda (entry)
 	   `(,(car entry) . 
 	     ,(val->alist (cadr entry))))
 	 adat)))
+
+;;======================================================================
+;; debug stuff
+;;======================================================================
+
+(define verbosity (make-parameter '()))
 	 
+;;======================================================================
 ;; (define (debug:print . params) #f)
 ;; (define (debug:print-info . params) #f)
 ;; 
 ;; (define (set-functions dbgp dbgpinfo)
 ;;   (set! debug:print dbgp)
 ;;   (set! debug:print-info dbgpinfo))
 
+;;======================================================================
+;; this was cached based on results from profiling but it turned out the profiling
+;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching
+;; in for now but can probably take it out later.
+;;
+(define (debug:calc-verbosity vstr arg) ;; arg is 'v (verbose) or 'q (quiet)
+  (let* ((res (cond
+	       ((number? vstr) vstr)
+	       ((not (string?  vstr))   1)
+	       ;; ((string-match  "^\\s*$" vstr) 1)
+	       (vstr           (let ((debugvals  (filter number? (map string->number (string-split vstr ",")))))
+				 (cond
+				  ((> (length debugvals) 1) debugvals)
+				  ((> (length debugvals) 0)(car debugvals))
+				  (else 1))))
+	       ((eq? arg 'v)   2) ;; verbose
+	       ((eq? arg 'q)   0) ;; quiet
+	       (else                   1))))
+    (verbosity res)
+    res))
+
+;;======================================================================
+;; check verbosity, #t is ok
+#;(define (debug-check-verbosity verbosity vstr)
+  (if (not (or (number? verbosity)
+	       (list?   verbosity)))
+      (begin
+	(print "ERROR: Invalid debug value \"" vstr "\"")
+	#f)
+      #t))
+
+(define (debug:debug-mode n)
+  (let* ((vb (verbosity)))
+    (cond
+   ((and (number? vb)   ;; number number
+	 (number? n))
+    (<= n vb))
+   ((and (list? vb)     ;; list   number
+	 (number? n))
+    (member n vb))
+   ((and (list? vb)     ;; list   list
+	 (list? n))
+    (not (null? (lset-intersection! eq? vb n))))
+   ((and (number? vb)
+	 (list? n))
+    (member vb n)))))
+
+(define (debug:print n e . params)
+  (if (debug:debug-mode n)
+      (with-output-to-port (or e (current-error-port))
+	(lambda ()
+	  ;; (if *logging*
+	      ;; (db:log-event (apply conc params))
+	  (apply print params)
+	  )))) ;; )
+
+(define (debug:print-error n e . params)
+  ;; normal print
+  (if (debug:debug-mode n)
+      (with-output-to-port (if (port? e) e (current-error-port))
+	(lambda ()
+	  (apply print "ERROR: " params)
+	  )))
+  ;; pass important messages to stderr
+  (if (and (eq? n 0)(not (eq? e (current-error-port)))) 
+      (with-output-to-port (current-error-port)
+	(lambda ()
+	  (apply print "ERROR: " params)
+	  ))))
+
+(define (debug:print-info n e . params)
+  (if (debug:debug-mode n)
+      (with-output-to-port (if (port? e) e (current-error-port))
+	(lambda ()
+	  (apply print "INFO: (" n ") " params) ;; res)
+	  ))))
+
+;;======================================================================
+;; Safe utilities
+;;======================================================================
+
+(define (common:false-on-exception thunk #!key (message #f))
+  (handle-exceptions exn
+                     (begin
+                       (if message
+                           (debug:print-info 0 *default-log-port* message))
+                       #f) (thunk) ))
+
+(define (common:file-exists? path-string #!key (silent #f))
+  ;;;; TODO: catch permission denied exceptions and emit appropriate warnings. Might be able to get rid of with chicken 5?
+  (common:false-on-exception (lambda () (file-exists? path-string))
+                             message: (if (not silent)
+                                          (conc "Unable to access path: " path-string)
+                                          #f)
+                             ))
+
+(define (common:directory-exists? path-string)
+  ;;;; TODO: catch permission denied exceptions and emit appropriate warnings
+  (common:false-on-exception (lambda () (directory-exists? path-string))
+                             message: (conc "Unable to access path: " path-string)
+                             ))
+
+;;======================================================================
+;; does the directory exist and do we have write access?
+;;
+;;    returns the directory or #f
+;;
+(define (common:directory-writable? path-string)
+  (handle-exceptions
+      exn
+    (begin
+      (debug:print 0 *default-log-port* "Failed to identify access to " path-string ", exn=" exn)
+      #f)
+   (if (and (directory-exists? path-string)
+            (file-write-access? path-string))
+       path-string
+       #f)))
+
+;;======================================================================
+;; T I M E   A N D   D A T E
+;;======================================================================
+
+;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5
+(define (common:hms-string->seconds tstr)
+  (let ((parts     (string-split-fields "\\w+" tstr))
+	(time-secs 0)
+	;; s=seconds, m=minutes, h=hours, d=days, M=months, y=years, w=weeks
+	(trx       (regexp "(\\d+)([smhdMyw])")))
+    (for-each (lambda (part)
+		(let ((match  (string-match trx part)))
+		  (if match
+		      (let ((val (string->number (cadr match)))
+			    (unt (caddr match)))
+			(if val 
+			    (set! time-secs (+ time-secs (* val
+							    (case (string->symbol unt)
+							      ((s) 1)
+							      ((m) 60) ;; minutes
+							      ((h) 3600)
+							      ((d) 86400)
+							      ((w) 604800)
+							      ((M) 2628000) ;; aproximately one month
+							      ((y) 31536000)
+							      (else #f))))))))))
+	      parts)
+    time-secs))
+		       
+(define (seconds->hr-min-sec secs)
+  (let* ((hrs (quotient secs 3600))
+	 (min (quotient (- secs (* hrs 3600)) 60))
+	 (sec (- secs (* hrs 3600)(* min 60))))
+    (conc (if (> hrs 0)(conc hrs "hr ") "")
+	  (if (> min 0)(conc min "m ")  "")
+	  sec "s")))
+
+(define (seconds->time-string sec)
+  (time->string 
+   (seconds->local-time sec) "%H:%M:%S"))
+
+(define (seconds->work-week/day-time sec)
+  (time->string
+   (seconds->local-time sec) "ww%V.%u %H:%M"))
+
+(define (seconds->work-week/day sec)
+  (time->string
+   (seconds->local-time sec) "ww%V.%u"))
+
+(define (seconds->year-work-week/day sec)
+  (time->string
+   (seconds->local-time sec) "%yww%V.%w"))
+
+(define (seconds->year-work-week/day-time sec)
+  (time->string
+   (seconds->local-time sec) "%Yww%V.%w %H:%M"))
+
+(define (seconds->year-week/day-time sec)
+  (time->string
+   (seconds->local-time sec) "%Yw%V.%w %H:%M"))
+
+(define (seconds->quarter sec)
+  (case (string->number
+	 (time->string 
+	  (seconds->local-time sec)
+	  "%m"))
+    ((1 2 3) 1)
+    ((4 5 6) 2)
+    ((7 8 9) 3)
+    ((10 11 12) 4)
+    (else #f)))
+
+;;======================================================================
+;; basic ISO8601 format (e.g. "2017-02-28 06:02:54") date time => Unix epoch
+;;
+(define (common:date-time->seconds datetime)
+  (local-time->seconds (string->time datetime "%Y-%m-%d %H:%M:%S")))
+
+;;======================================================================
+;; given span of seconds tstart to tend
+;; find start time to mark and mark delta
+;;
+(define (common:find-start-mark-and-mark-delta tstart tend)
+  (let* ((deltat   (- (max tend (+ tend 10)) tstart)) ;; can't handle runs of less than 4 seconds. Pad it to 10 seconds ...
+	 (result   #f)
+	 (min      60)
+	 (hr       (* 60 60))
+	 (day      (* 24 hr))
+	 (yr       (* 365 day)) ;; year
+	 (mo       (/ yr 12))
+	 (wk       (* day 7)))
+    (for-each
+     (lambda (max-blks)
+       (for-each
+	(lambda (span) ;; 5 2 1
+	  (if (not result)
+	      (for-each 
+	       (lambda (timeunit timesym) ;; year month day hr min sec
+		 (if (not result)
+		     (let* ((time-blk (* span timeunit))
+			    (num-blks (quotient deltat time-blk)))
+		       (if (and (> num-blks 4)(< num-blks max-blks))
+			   (let ((first (* (quotient tstart time-blk) time-blk)))
+			     (set! result (list span timeunit time-blk first timesym))
+			     )))))
+	       (list yr mo wk day hr min 1)
+	       '(     y  mo w  d   h  m   s))))
+	(list 8 6 5 2 1)))
+     '(5 10 15 20 30 40 50 500))
+    (if values
+	(apply values result)
+	(values 0 day 1 0 'd))))
+
+;;======================================================================
+;; given x y lim return the cron expansion
+;;
+(define (common:expand-cron-slash x y lim)
+  (let loop ((curr x)
+	     (res  `()))
+    (if (< curr lim)
+	(loop (+ curr y) (cons curr res))
+	(reverse res))))
+
+;;======================================================================
+;; expand a complex cron string to a list of cron strings
+;;
+;;  x/y   => x, x+y, x+2y, x+3y while x+Ny<max_for_field
+;;  a,b,c => a, b ,c
+;;
+;;   NOTE: with flatten a lot of the crud below can be factored down.
+;;
+(define (common:cron-expand cron-str)
+  (if (list? cron-str)
+      (flatten
+       (fold (lambda (x res)
+	       (if (list? x)
+		   (let ((newres (map common:cron-expand x)))
+		     (append x newres))
+		   (cons x res)))
+	     '()
+	     cron-str)) ;; (map common:cron-expand cron-str))
+      (let ((cron-items (string-split cron-str))
+	    (slash-rx   (regexp "(\\d+)/(\\d+)"))
+	    (comma-rx   (regexp ".*,.*"))
+	    (max-vals   '((min        . 60)
+			  (hour       . 24)
+			  (dayofmonth . 28) ;;; BUG!!!! This will be a bug for some combinations
+			  (month      . 12)
+			  (dayofweek  . 7))))
+	(if (< (length cron-items) 5) ;; bad spec
+	    cron-str ;; `(,cron-str)              ;; just return the string, something downstream will fix it
+	    (let loop ((hed  (car cron-items))
+		       (tal  (cdr cron-items))
+		       (type 'min)
+		       (type-tal '(hour dayofmonth month dayofweek))
+		       (res  '()))
+	      (regex-case
+		  hed
+		(slash-rx ( _ base incr ) (let* ((basen          (string->number base))
+						 (incrn          (string->number incr))
+						 (expanded-vals  (common:expand-cron-slash basen incrn (alist-ref type max-vals)))
+						 (new-list-crons (fold (lambda (x myres)
+									 (cons (conc (if (null? res)
+											 ""
+											 (conc (string-intersperse res " ") " "))
+										     x " " (string-intersperse tal " "))
+									       myres))
+								       '() expanded-vals)))
+					    ;; (print "new-list-crons: " new-list-crons)
+					    ;; (fold (lambda (x res)
+					    ;; 	    (if (list? x)
+					    ;; 		(let ((newres (map common:cron-expand x)))
+					    ;; 		  (append x newres))
+					    ;; 		(cons x res)))
+					    ;; 	  '()
+					    (flatten (map common:cron-expand new-list-crons))))
+		;;					    (map common:cron-expand (map common:cron-expand new-list-crons))))
+		(else (if (null? tal)
+			  cron-str
+			  (loop (car tal)(cdr tal)(car type-tal)(cdr type-tal)(append res (list hed)))))))))))
+
+;;======================================================================
+;; given a cron string and the last time event was processed return #t to run or #f to not run
+;;
+;;  min    hour   dayofmonth month  dayofweek
+;; 0-59    0-23   1-31       1-12   0-6          ### NOTE: dayofweek does not include 7
+;;
+;;  #t => yes, run the job
+;;  #f => no, do not run the job
+;;
+(define (common:cron-event cron-str now-seconds-in last-done) ;; ref-seconds = #f is NOW.
+  (let* ((cron-items     (map string->number (string-split cron-str)))
+	 (now-seconds    (or now-seconds-in (current-seconds)))
+	 (now-time       (seconds->local-time now-seconds))
+	 (last-done-time (seconds->local-time last-done))
+	 (all-times      (make-hash-table)))
+    ;; (print "cron-items: " cron-items "(length cron-items): " (length cron-items))
+    (if (not (eq? (length cron-items) 5)) ;; don't even try to figure out junk strings
+	#f
+	(match-let (((     cmin chour cdayofmonth cmonth    cdayofweek)
+		     cron-items)
+		    ;; 0     1    2        3         4    5      6
+		    ((nsec nmin nhour ndayofmonth nmonth nyr ndayofweek n7 n8 n9)
+		     (vector->list now-time))
+		    ((lsec lmin lhour ldayofmonth lmonth lyr ldayofweek l7 l8 l9)
+		     (vector->list last-done-time)))
+	  ;; create all possible time slots
+	  ;; remove invalid slots due to (for example) day of week
+	  ;; get the start and end entries for the ref-seconds (current) time
+	  ;; if last-done > ref-seconds => this is an ERROR!
+	  ;; does the last-done time fall in the legit region?
+	  ;;    yes => #f  do not run again this command
+	  ;;    no  => #t  ok to run the command
+	  (for-each ;; month
+	   (lambda (month)
+	     (for-each ;; dayofmonth
+	      (lambda (dom)
+		(for-each
+		 (lambda (hr) ;; hour
+		   (for-each
+		    (lambda (minute) ;; minute
+		      (let ((copy-now (apply vector (vector->list now-time))))
+			(vector-set! copy-now 0 0) ;; force seconds to zero
+			(vector-set! copy-now 1 minute)
+			(vector-set! copy-now 2 hr)
+			(vector-set! copy-now 3 dom)  ;; dom is already corrected for zero referenced
+			(vector-set! copy-now 4 month)
+			(let* ((copy-now-secs (local-time->seconds copy-now))
+			       (new-copy      (seconds->local-time copy-now-secs))) ;; remake the time vector
+			  (if (or (not cdayofweek)
+				  (equal? (vector-ref new-copy 6)
+					  cdayofweek)) ;; if the day is specified and a match OR if the day is NOT specified
+			      (if (or (not cdayofmonth)
+				      (equal? (vector-ref new-copy 3)
+					      (+ 1 cdayofmonth))) ;; if the month is specified and a match OR if the month is NOT specified
+				  (hash-table-set! all-times copy-now-secs new-copy))))))
+		    (if cmin
+			`(,cmin)  ;; if given cmin, have to use it
+			(list (- nmin 1) nmin (+ nmin 1))))) ;; minute
+		 (if chour
+		     `(,chour)
+		     (list (- nhour 1) nhour (+ nhour 1))))) ;; hour
+	      (if cdayofmonth
+		  `(,cdayofmonth)
+		  (list (- ndayofmonth 1) ndayofmonth (+ ndayofmonth 1)))))
+	   (if cmonth
+	       `(,cmonth)
+	       (list (- nmonth 1) nmonth (+ nmonth 1))))
+	  (let ((before #f)
+		(is-in  #f))
+	    (for-each
+	     (lambda (moment)
+	       (if (and before
+			(<= before now-seconds)
+			(>= moment now-seconds))
+		   (begin
+		     ;; (print)
+		     ;; (print "Before: " (time->string (seconds->local-time before)))
+		     ;; (print "Now:    " (time->string (seconds->local-time now-seconds)))
+		     ;; (print "After:  " (time->string (seconds->local-time moment)))
+		     ;; (print "Last:   " (time->string (seconds->local-time last-done)))
+		     (if (<  last-done before)
+			 (set! is-in before))
+		     ))
+	       (set! before moment))
+	     (sort (hash-table-keys all-times) <))
+	    is-in)))))
+
+(define (common:extended-cron  cron-str now-seconds-in last-done)
+  (let ((expanded-cron (common:cron-expand cron-str)))
+    (if (string? expanded-cron)
+	(common:cron-event expanded-cron now-seconds-in last-done)
+	(let loop ((hed (car expanded-cron))
+		   (tal (cdr expanded-cron)))
+	  (if (common:cron-event hed now-seconds-in last-done)
+	      #t
+	      (if (null? tal)
+		  #f
+		  (loop (car tal)(cdr tal))))))))
+
+;;======================================================================
+;; Keys
+;;======================================================================
+
+(define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ...
+  (string-intersperse keys ","))
+
+(define (args:usage . a) #f)
+
+;;======================================================================
+;; key <=> target routines
+;;======================================================================
+
+;;======================================================================
+;; This invalidates using "/" in item names. Every key will be
+;; available via args:get-arg as :keyfield. Since this only needs to
+;; be called once let's use it to set the environment vars
+;;
+;; The setting of :keyfield in args should be turned off ASAP
+;;
+(define (keys:target-set-args keys target ht)
+  (if target
+      (let ((vals (string-split target "/")))
+	(if (eq? (length vals)(length keys))
+	    (for-each (lambda (key val)
+			(setenv key val)
+			(if ht (hash-table-set! ht (conc ":" key) val)))
+		      keys
+		      vals)
+	    (debug:print-error 0 *default-log-port* "wrong number of values in " target ", should match " keys))
+	vals)
+      (debug:print 4 *default-log-port* "ERROR: keys:target-set-args called with no target.")))
+
+;;======================================================================
+;; given the keys (a list of vectors <key field> or a list of keys) and a target return a keyval list
+;; keyval list ( (key1 val1) (key2 val2) ...)
+(define (keys:target->keyval keys target)
+  (let* ((targlist (string-split target "/"))
+	 (numkeys  (length keys))
+	 (numtarg  (length targlist))
+	 (targtweaked (if (> numkeys numtarg)
+			  (append targlist (make-list (- numkeys numtarg) ""))
+			  targlist)))
+    (map (lambda (key targ)
+	   (list key targ))
+	 keys targtweaked)))
+
+(define (keys:make-key/field-string keys)
+  (string-join
+   (map (lambda (key)(conc key " TEXT"))
+	keys)
+   ","))
+
+;;======================================================================
+;; (define keys:config-get-fields common:get-fields)
+
+(define (common:get-area-path-signature)
+  (message-digest-string (md5-primitive) *toppath*))
+
+(define (common:get-signature str)
+  (message-digest-string (md5-primitive) str))
+
+;;======================================================================
+;; S Y S T E M   S T U F F
+;;======================================================================
+
+;;======================================================================
+;; lazy-safe get file mod time. on any error (file not existing etc.) return 0
+;;
+(define (common:lazy-modification-time fpath)
+  (handle-exceptions
+      exn
+    (begin
+      (debug:print 0 *default-log-port* "Failed to get modifcation time for " fpath ", treating it as zero. exn=" exn)
+      0)
+    (if (file-exists? fpath)
+	(file-modification-time fpath)
+	0)))
+
+;;======================================================================
+;; find timestamp of newest file associated with a sqlite db file
+(define (common:lazy-sqlite-db-modification-time fpath)
+  (let* ((glob-list (handle-exceptions
+			exn
+		      (begin
+			(debug:print 0 *default-log-port* "Failed to glob " fpath "*, exn=" exn)
+			`(,(conc "/no/such/file, message: " ((condition-property-accessor 'exn 'message) exn))))
+		      (glob (conc fpath "*"))))
+         (file-list (if (eq? 0 (length glob-list))
+			'("/no/such/file")
+			glob-list)))
+  (apply max
+	 (map
+	  common:lazy-modification-time 
+	  file-list))))
+
+;;======================================================================
+;; execute thunk, return value.  If exception thrown, trap exception, return #f, and emit nonfatal condition note to *default-log-port* .
+;; arguments - thunk, message
+(define (common:fail-safe thunk warning-message-on-exception)
+  (handle-exceptions
+   exn
+   (begin
+     (debug:print-info 0 *default-log-port* "notable but nonfatal condition - "warning-message-on-exception", exn=" exn)
+     (debug:print-info 0 *default-log-port*
+                       (string-substitute "\n?Error:" "nonfatal condition:"
+                                          (with-output-to-string
+                                            (lambda ()
+                                              (print-error-message exn) ))))
+     (debug:print-info 0 *default-log-port* "    -- continuing after nonfatal condition...")
+     #f)
+   (thunk)))
+
+(define getenv get-environment-variable)
+(define (safe-setenv key val)
+  (if (or (substring-index "!" key)
+	  (substring-index ":" key)  ;; variables containing : are for internal use and cannot be environment variables.
+	  (substring-index "." key)) ;; periods are not allowed in environment variables
+      (debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\" or starting with \"!\"")
+      (if (and (string? val)
+	       (string? key))
+	  (handle-exceptions
+	      exn
+	      (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val ", exn=" exn)
+	    (setenv key val))
+	  (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val))))
+
+(define home (getenv "HOME"))
+(define user (getenv "USER"))
+
+
+;;======================================================================
+;; returns list of fd count, socket count
+(define (get-file-descriptor-count #!key  (pid (current-process-id )))
+  (list
+    (length (glob (conc "/proc/" pid "/fd/*")))
+    (length  (filter identity (map socket? (glob (conc "/proc/" pid "/fd/*")))))
+  )
+)
+
+  
+
+;;======================================================================
+;; GLOBALS
+
+;; CONTEXTS
+(defstruct cxt
+  (taskdb #f)
+  (cmutex (make-mutex)))
+;; (define *contexts* (make-hash-table))
+;; (define *context-mutex* (make-mutex))
+
+;; ;; safe method for accessing a context given a toppath
+;; ;;
+;; (define (common:with-cxt toppath proc)
+;;   (mutex-lock! *context-mutex*)
+;;   (let ((cxt (hash-table-ref/default *contexts* toppath #f)))
+;;     (if (not cxt)
+;;         (set! cxt (let ((x (make-cxt)))(hash-table-set! *contexts* toppath x) x)))
+;;     (let ((cxt-mutex (cxt-mutex cxt)))
+;;       (mutex-unlock! *context-mutex*)
+;;       (mutex-lock! cxt-mutex)
+;;       (let ((res (proc cxt)))
+;;         (mutex-unlock! cxt-mutex)
+;;         res))))
+        
+;;======================================================================
+;; A hash table that can be accessed by #{scheme ...} calls in
+;; config files. Allows communicating between confgs
+;;
+(define *user-hash-data* (make-hash-table))
+
+(define *pkts-info*    (make-hash-table)) ;; store stuff like the last parent here
+
+(define *runconfigdat* #f)   ;; run configs data
+(define *configdat*    #f)   ;; megatest.config data
+(define *configstatus* #f)   ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done
+
+(define *already-seen-runconfig-info* #f)
+
+(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 *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.
+;; db stats
+(define *db-stats*            (make-hash-table)) ;; hash of vectors < count duration-total >
+(define *db-stats-mutex*      (make-mutex))
+;; db access
+(define *db-last-access*      (current-seconds)) ;; last db access, used in server
+(define *db-write-access*     #t)
+;; db sync
+(define *db-last-sync*        0)                 ;; last time the sync to megatest.db happened
+(define *db-sync-in-progress* #f)                ;; if there is a sync in progress do not try to start another
+(define *db-multi-sync-mutex* (make-mutex))      ;; protect access to *db-sync-in-progress*, *db-last-sync*
+;; task db
+(define *task-db*             #f) ;; (vector db path-to-db)
+(define *db-access-allowed*   #t) ;; flag to allow access
+(define *db-access-mutex*     (make-mutex))
+(define *db-transaction-mutex* (make-mutex))
+
+(define *db-api-call-time*    (make-hash-table)) ;; hash of command => (list of times)
+;; no sync db
+(define *no-sync-db*          #f)
+
+;; SERVER
+(define *my-client-signature* #f)
+(define *transport-type*    'http)             ;; override with [server] transport http|rpc|nmsg
+(define *runremote*         #f)                ;; if set up for server communication this will hold <host port>
+;; (define *max-cache-size*    0)
+(define *logged-in-clients* (make-hash-table))
+(define *server-id*         #f)
+(define *server-info*       #f)  ;; good candidate for easily convert to non-global
+(define *time-to-exit*      #f)
+(define *server-run*        #t)
+(define *run-id*            #f)
+(define *server-kind-run*   (make-hash-table))
+(define *home-host*         #f)
+;; (define *total-non-write-delay* 0)
+(define *heartbeat-mutex*   (make-mutex))
+
+(define *server-overloaded*  #f)
+(define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id
+
+;; client
+(define *rmt-mutex*         (make-mutex))     ;; remote access calls mutex 
+
+;; RPC transport
+(define *rpc:listener*      #f)
+
+;; KEY info
+(define *target*            (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN
+(define *keys*              (make-hash-table)) ;; cache the keys here
+(define *keyvals*           (make-hash-table))
+(define *toptest-paths*     (make-hash-table)) ;; cache toptest path settings here
+(define *test-paths*        (make-hash-table)) ;; cache test-id to test run paths here
+(define *test-ids*          (make-hash-table)) ;; cache run-id, testname, and item-path => test-id
+(define *test-info*         (make-hash-table)) ;; cache the test info records, update the state, status, run_duration etc. from testdat.db
+
+(define *run-info-cache*     (make-hash-table)) ;; run info is stable, no need to reget
+(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
+
+(define *host-loads*         (make-hash-table))
+
+;;======================================================================
+;; cache environment vars for each run here
+(define *env-vars-by-run-id* (make-hash-table))
+
+;;======================================================================
+;; Testconfig and runconfig caches. 
+(define *testconfigs*        (make-hash-table)) ;; test-name => testconfig
+(define *runconfigs*         (make-hash-table)) ;; target    => runconfig
+
+;; 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))
+
+(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*))
+
+;;======================================================================
+;; when called from a wrapper I need sometimes to find the calling
+;; wrapper, this is for dashboard to find the correct megatest.
+;;
+(define (common:find-local-megatest #!optional (progname "megatest"))
+  (let ((res (filter file-exists?
+		     (map (lambda (updir)
+			    (let* ((lm  (car (argv)))
+				   (dir (pathname-directory lm))
+				   (exe (pathname-strip-directory lm)))
+			      (conc (if dir (conc dir "/") "")
+				    (case (string->symbol exe)
+				      ((dboard)    (conc updir progname))
+				      ((mtest)     (conc updir progname))
+				      ((dashboard) progname)
+				      (else exe)))))
+			  '("../../" "../")))))
+    (if (null? res)
+	(begin
+	  (debug:print 0 *default-log-port* "Failed to find this executable! Using what can be found on the path")
+	  progname)
+	(car res))))
+
+(define *common:logpro-exit-code->status-sym-alist*
+  '( ( 0 . pass )
+     ( 1 . fail )
+     ( 2 . warn )
+     ( 3 . check )
+     ( 4 . waived )
+     ( 5 . abort )
+     ( 6 . skip )))
+
+(define (common:logpro-exit-code->status-sym exit-code)
+  (or (alist-ref exit-code *common:logpro-exit-code->status-sym-alist*) 'fail))
+
+(define (common:worse-status-sym ss1 ss2)
+  (let loop ((status-syms-remaining '(abort fail check skip warn waived pass)))
+    (cond
+     ((null? status-syms-remaining)
+      'fail)
+     ((eq? (car status-syms-remaining) ss1)
+      ss1)
+     ((eq? (car status-syms-remaining) ss2)
+      ss2)
+     (else
+      (loop (cdr status-syms-remaining))))))
+
+(define (common:steps-can-proceed-given-status-sym status-sym)
+  (if (member status-sym '(warn waived pass))
+      #t
+      #f))
+
+(define (status-sym->string status-sym)
+  (case status-sym
+      ((pass) "PASS")
+    ((fail) "FAIL")
+    ((warn) "WARN")
+    ((check) "CHECK")
+    ((waived) "WAIVED")
+    ((abort) "ABORT")
+    ((skip) "SKIP")
+    (else "FAIL")))
+
+(define (common:logpro-exit-code->test-status exit-code)
+  (status-sym->string (common:logpro-exit-code->status-sym exit-code)))
+
+(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))
+  (set! *test-paths*         (make-hash-table))
+  (set! *test-ids*           (make-hash-table))
+  (set! *test-info*          (make-hash-table))
+  (set! *run-info-cache*     (make-hash-table))
+  (set! *env-vars-by-run-id* (make-hash-table))
+  (set! *test-id-cache*      (make-hash-table)))
+
+;; Generic string database
+(define sdb:qry #f) ;; (make-sdb:qry)) ;;  'init #f)
+;; Generic path database
+(define *fdb* #f)
+
+(define *last-launch* (current-seconds)) ;; use for throttling the launch rate. Would be better to use the db and last time of a test in LAUNCHED state.
+
+(define (common:snapshot-file filepath #!key (subdir  ".") )
+  (if (file-exists? filepath)
+      (let* ((age-sec  (lambda (file)
+                         (if (file-exists? file)
+                             (- (current-seconds) (file-modification-time file))
+                             1000000000))) ;; return really old value if file doesn't exist.  we want to clobber it if old or not exist.
+             (ok-flag  #t)
+             (age-mins (lambda (file) (/ (age-sec   file) 60)))
+             (age-hrs  (lambda (file) (/ (age-mins file) 60)))
+             (age-days (lambda (file) (/ (age-hrs   file) 24)))
+             (age-wks  (lambda (file) (/ (age-days  file) 7)))
+             (docmd    (lambda (cmd)
+                         (cond
+                          (ok-flag
+                           (let ((res (system cmd)))
+                             (cond
+                              ((eq? 0 res)
+                               #t)
+                              (else
+                               (set! ok-flag #f)
+                               (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Command failed with exit code "
+                                            (if (< res 0)
+                                                res
+                                                (/ res 8)) " ["cmd"]" )
+                               #f))))
+                          (else
+                           (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Not runnining command due to prior error. ["cmd"]")
+                           #f))))
+             (copy     (lambda (src dest) (docmd (conc "/bin/cp '"src"' '"dest"'"))))
+             (copy+zip (lambda (src dest) (docmd (conc "gzip -c - < '"src"' > '"dest"'"))))
+             (fullpath (realpath filepath))
+             (basedir  (pathname-directory fullpath))
+             (basefile (pathname-strip-directory fullpath))
+             ;;(prevfile (conc filepath ".prev.gz"))
+             (minsfile (conc basedir "/" subdir "/" basefile ".mins.gz"))
+             (hrsfile  (conc basedir "/" subdir "/" basefile ".hrs.gz"))
+             (daysfile (conc basedir "/" subdir "/" basefile ".days.gz"))
+             (wksfile  (conc basedir "/" subdir "/" basefile ".weeks.gz")))
+
+        ;; create subdir it not exists
+        (if (not (directory-exists? (conc basedir "/" subdir)))
+            (docmd (conc "/bin/mkdir -p '"(conc basedir "/" subdir)"'")))
+        
+        ;; copy&zip <file> to <file>.mins if not exists
+        (if (not (file-exists? minsfile))
+            (copy+zip filepath minsfile))
+        ;; copy <file>.mins to <file>.hrs if not exists
+        (if (not (file-exists? hrsfile))
+            (copy minsfile hrsfile))
+        ;; copy <file>.hrs to <file>.days if not exists
+        (if (not (file-exists? daysfile))
+            (copy hrsfile daysfile))
+        ;; copy <file>.days to <file>.weeks if not exists
+        (if (not (file-exists? wksfile))
+            (copy daysfile wksfile))
+
+
+        ;; if age(<file>.mins.gz) >= 1h:
+        ;;     copy <file>.mins.gz <file>.hrs.gz
+        ;;     copy <prev file> <file>.mins.gz
+        (when (>= (age-mins minsfile) 1)
+          (copy minsfile hrsfile)
+          (copy+zip filepath  minsfile))
+        
+        ;; if age(<file>.hrs.gz) >= 1d:
+        ;;     copy <file>.hrs.gz <file>.days.gz
+        ;;     copy <file>.mins.gz <file>.hrs.gz
+        (when (>= (age-days hrsfile) 1)
+          (copy hrsfile daysfile)
+          (copy minsfile hrsfile))
+        
+        ;; if age(<file>.days.gz) >= 1w:
+        ;;     copy <file>.days.gz <file>.weeks.gz
+        ;;     copy <file>.hrs.gz <file>.days.gz
+        (when (>= (age-wks daysfile) 1)
+          (copy daysfile wksfile)
+          (copy hrsfile daysfile))
+        #t)
+      #f))
+  
+        
+;;======================================================================
+;; S P A R S E   A R R A Y S
+;;======================================================================
+
+(define (make-sparse-array)
+  (let ((a (make-sparse-vector)))
+    (sparse-vector-set! a 0 (make-sparse-vector))
+    a))
+
+(define (sparse-array? a)
+  (and (sparse-vector? a)
+       (sparse-vector? (sparse-vector-ref a 0))))
+
+(define (sparse-array-ref a x y)
+  (let ((row (sparse-vector-ref a x)))
+    (if row
+	(sparse-vector-ref row y)
+	#f)))
+
+(define (sparse-array-set! a x y val)
+  (let ((row (sparse-vector-ref a x)))
+    (if row
+	(sparse-vector-set! row y val)
+	(let ((new-row (make-sparse-vector)))
+	  (sparse-vector-set! a x new-row)
+	  (sparse-vector-set! new-row y val)))))
+
+;;======================================================================
+;; L O C K E R S   A N D   B L O C K E R S 
+;;======================================================================
+
+;;======================================================================
+;; block further accesses to databases. Call this before shutting db down
+(define (common:db-block-further-queries)
+  (mutex-lock! *db-access-mutex*)
+  (set! *db-access-allowed* #f)
+  (mutex-unlock! *db-access-mutex*))
+
+(define (common:db-access-allowed?)
+  (let ((val (begin
+	       (mutex-lock! *db-access-mutex*)
+	       *db-access-allowed*
+	       (mutex-unlock! *db-access-mutex*))))
+    val))
+
+;;======================================================================
+;; File locking
+;;======================================================================
+
+;;======================================================================
+;; dot-locking egg seems not to work, using this for now
+;; if lock is older than expire-time then remove it and try again
+;; to get the lock
+;;
+(define (common:simple-file-lock fname #!key (expire-time 300))
+  (let ((fmod-time (handle-exceptions
+		       ext
+		     (current-seconds)
+		     (file-modification-time fname))))
+    (if (common:file-exists? fname)
+	(if (> (- (current-seconds) fmod-time) expire-time)
+	    (begin
+	      (handle-exceptions exn #f (delete-file* fname))	
+	      (common:simple-file-lock fname expire-time: expire-time))
+	    #f)
+	(let ((key-string (conc (get-host-name) "-" (current-process-id))))
+	  (with-output-to-file fname
+	    (lambda ()
+	      (print key-string)))
+	  (thread-sleep! 0.25)
+	  (if (common:file-exists? fname)
+	      (handle-exceptions exn
+                #f 
+                (with-input-from-file fname
+	  	  (lambda ()
+		    (equal? key-string (read-line)))))
+	      #f)))))
+
+(define (common:simple-file-lock-and-wait fname #!key (expire-time 300))
+  (let ((end-time (+ expire-time (current-seconds))))
+    (let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time)))
+      (if got-lock
+	  #t
+	  (if (> end-time (current-seconds))
+	      (begin
+		(thread-sleep! 3)
+		(loop (common:simple-file-lock fname expire-time: expire-time)))
+	      #f)))))
+
+(define (common:simple-file-release-lock fname)
+  (handle-exceptions
+      exn
+      #f ;; I don't really care why this failed (at least for now)
+    (delete-file* fname)))
+
+;;======================================================================
+;; U S E F U L   S T U F F
+;;======================================================================
+
+;;======================================================================
+;; convert things to an alist or assoc list, #f gets converted to ""
+;;
+(define (common:to-alist dat)
+  (cond
+   ((list? dat)   (map common:to-alist dat))
+   ((vector? dat)
+    (map common:to-alist (vector->list dat)))
+   ((pair? dat)
+    (cons (common:to-alist (car dat))
+	  (common:to-alist (cdr dat))))
+   ((hash-table? dat)
+    (map common:to-alist (hash-table->alist dat)))
+   (else
+    (if dat
+	dat
+	""))))
+
+(define (common:alist-ref/default key alist default)
+  (or (alist-ref key alist) default))
+
+(define (common:low-noise-print waitval . keys)
+  (let* ((key      (string-intersperse (map conc keys) "-" ))
+	 (lasttime (hash-table-ref/default *common:denoise* key 0))
+	 (currtime (current-seconds)))
+    (if (> (- currtime lasttime) waitval)
+	(begin
+	  (hash-table-set! *common:denoise* key currtime)
+	  #t)
+	#f)))
+
+(define (common:get-megatest-exe)
+  (or (getenv "MT_MEGATEST") "megatest"))
+
+(define (common:read-encoded-string instr)
+  (handle-exceptions
+   exn
+   (handle-exceptions
+    exn
+    (begin
+      (debug:print-error 0 *default-log-port* "received bad encoded string \"" instr "\", message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
+      (print-call-chain (current-error-port))
+      #f)
+    (read (open-input-string (base64:base64-decode instr))))
+   (read (open-input-string (z3:decode-buffer (base64:base64-decode instr))))))
+
+;;======================================================================
+;; S T A T E S   A N D   S T A T U S E S
+;;======================================================================
+
+;; BBnote: *common:std-states* - dashboard filter control and test control state buttons defined here; used in set-fields-panel and dboard:make-controls
+(define *common:std-states*   ;; for toggle buttons in dashboard
+  '(
+    (0 "ARCHIVED")
+    (1 "STUCK")
+    (2 "KILLREQ")
+    (3 "KILLED")
+    (4 "NOT_STARTED")
+    (5 "COMPLETED")
+    (6 "LAUNCHED")
+    (7 "REMOTEHOSTSTART")
+    (8 "RUNNING")
+    ))
+
+(define *common:dont-roll-up-states*
+  '("DELETED"
+    "REMOVING"
+    "CLEANING"
+    "ARCHIVE_REMOVING"
+    ))
+
+;; BBnote: *common:std-statuses* dashboard filter control and test control status buttons defined here; used in set-fields-panel and dboard:make-controls
+;; note these statuses are sorted from better to worse.
+;; This sort order is important to dcommon:status-compare3 and db:set-state-status-and-roll-up-items
+(define *common:std-statuses*
+  '(;; (0 "DELETED")  
+    (1 "n/a")
+    (2 "PASS")
+    (3 "SKIP")
+    (4 "WARN")
+    (5 "WAIVED")
+    (6 "CHECK")
+    (7 "STUCK/DEAD")
+    (8 "DEAD")
+    (9 "FAIL")
+    (10 "PREQ_FAIL")
+    (11 "PREQ_DISCARDED")
+    (12 "ABORT")))
+
+(define (common:status>? s1 s2)
+  (let* ((munged (map (lambda (x) `(,(cadr x) . ,(car x))) *common:std-statuses*))
+	 (v1     (alist-ref s1 munged equal?))
+	 (v2     (alist-ref s2 munged equal?)))
+    (> v1 v2)))
+
+(define *common:ended-states*       ;; states which indicate the test is stopped and will not proceed
+  '("COMPLETED" "ARCHIVED" "KILLED" "KILLREQ" "STUCK" "INCOMPLETE" ))
+
+(define *common:badly-ended-states* ;; these roll up as CHECK, i.e. results need to be checked
+  '("KILLED" "KILLREQ" "STUCK" "INCOMPLETE" "DEAD"))
+
+(define *common:well-ended-states* ;; an item's prereq in this state allows item to proceed
+  '("PASS" "WARN" "CHECK" "WAIVED" "SKIP"))
+
+;; BBnote: *common:running-states* used from db:set-state-status-and-roll-up-items
+(define *common:running-states*     ;; test is either running or can be run
+  '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "STARTED"))
+
+(define *common:cant-run-states*    ;; These are stopping conditions that prevent a test from being run
+  '("COMPLETED" "KILLED" "UNKNOWN" "INCOMPLETE" "ARCHIVED"))
+
+(define *common:not-started-ok-statuses* ;; if not one of these statuses when in not_started state treat as dead
+  '("n/a" "na" "PASS" "FAIL" "WARN" "CHECK" "WAIVED" "DEAD" "SKIP"))
+
+;; group tests into buckets corresponding to rollup
+;;; Running, completed-pass,  completed-non-pass + worst status, not started.
+;; filter out 
+;(define (common:categorize-items-for-rollup in-tests)
+;  (
+
+(define (common:special-sort items order comp)
+  (let ((items-order (map reverse order))
+        (acomp       (or comp >)))
+    (sort items
+        (lambda (a b)
+          (let ((a-num (cadr (or (assoc a items-order) '(0 0))))
+                (b-num (cadr (or (assoc b items-order) '(0 0)))))
+            (acomp a-num b-num))))))
+
+;;======================================================================
+;; ;; given a toplevel with currstate, currstatus apply state and status
+;; ;;  => (newstate . newstatus)
+;; (define (common:apply-state-status currstate currstatus state status)
+;;   (let* ((cstate  (string->symbol (string-downcase currstate)))
+;;          (cstatus (string->symbol (string-downcase currstatus)))
+;;          (sstate  (string->symbol (string-downcase state)))
+;;          (sstatus (string->symbol (string-downcase status)))
+;;          (nstate  #f)
+;;          (nstatus #f))
+;;     (set! nstate
+;;           (case cstate
+;;             ((completed not_started killed killreq stuck archived) 
+;;              (case sstate ;; completed -> sstate
+;;                ((completed killed killreq stuck archived) completed)
+;;                ((running remotehoststart launched)        running)
+;;                (else                                      unknown-error-1)))
+;;             ((running remotehoststart launched)
+;;              (case sstate
+;;                ((completed killed killreq stuck archived) #f) ;; need to look at all items
+;;                ((running remotehoststart launched)        running)
+;;                (else                                      unknown-error-2)))
+;;             (else unknown-error-3)))
+;;     (set! nstatus
+;;           (case sstatus
+;;             ((pass)
+;;              (case nstate
+;;                ((pass n/a deleted)     pass)
+;;                ((warn)                 warn)
+;;                ((fail)                 fail)
+;;                ((check)               check)
+;;                ((waived)             waived)
+;;                ((skip)                 skip)
+;;                ((stuck/dead)          stuck)
+;;                ((abort)               abort)
+;;                (else        unknown-error-4)))
+;;             ((warn)
+;;              (case nstate
+;;                ((pass warn n/a skip deleted)   warn)
+;;                ((fail)                         fail)
+;;                ((check)                       check)
+;;                ((waived)                     waived)
+;;                ((stuck/dead)                  stuck)
+;;                (else                unknown-error-5)))
+;;             ((fail)
+;;              (case nstate
+;;                ((pass warn fail check n/a waived skip deleted stuck/dead stuck)  fail)
+;;                ((abort)                                                         abort)
+;;                (else                                                  unknown-error-6)))
+;;             (else    unknown-error-7)))
+;;     (cons 
+;;      (if nstate  (symbol->string nstate)  nstate)
+;;      (if nstatus (symbol->string nstatus) nstatus))))
+               
+;;======================================================================
+;; D E B U G G I N G   S T U F F 
+;;======================================================================
+
+(define *verbosity*         1)
+(define *logging*           #f)
+
+(define (assoc/default key lst . default)
+  (let ((res (assoc key lst)))
+    (if res (cadr res)(if (null? default) #f (car default)))))
+
+;;======================================================================
+;; safe getting of toppath
+(define (common:get-toppath areapath)
+  (or *toppath*
+      (if areapath
+	  (begin
+	    (set! *toppath* areapath)
+	    (setenv "MT_RUN_AREA_HOME" areapath)
+	    areapath)
+	  #f)
+      (if (getenv "MT_RUN_AREA_HOME")
+	  (begin
+	    (set! *toppath* (getenv "MT_RUN_AREA_HOME"))
+	    *toppath*)
+	  #f)
+      ;; last resort, look for megatest.config
+      (let loop ((thepath (realpath ".")))
+	(if (file-exists? (conc thepath "/megatest.config"))
+	    thepath
+	    (if (equal? thepath "/")
+		(begin
+		  (debug:print-error 0 *default-log-port* "Unable to find megatest home directory.")
+		  #f)
+		(loop (pathname-directory thepath)))))
+      ))
+
+;;======================================================================
+;; E X I T   H A N D L I N G
+;;======================================================================
+
+;;   (let ((ohh (common:on-homehost?))
+;; 	(srv (args:get-arg "-server")))
+;;     (and ohh srv)))
+    ;; (debug:print-info 0 *default-log-port* "common:run-sync? ohh=" ohh ", srv=" srv)
+
+
+
+(define *wdnum* 0)
+(define *wdnum*mutex (make-mutex))
+
+
+(define (common:human-time)
+  (time->string (seconds->local-time (current-seconds)) "%Y-%m-%d %H:%M:%S"))
+
+(define (std-signal-handler signum)
+  ;; (signal-mask! signum)
+  (set! *time-to-exit* #t) 
+  ;;(debug:print-info 13 *default-log-port* "got signal "signum)
+  (debug:print-error 0 *default-log-port* "Received signal " signum " aaa exiting promptly")
+  ;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway
+  (exit))
+
+(define (special-signal-handler signum)
+  ;; (signal-mask! signum)
+  (set! *time-to-exit* #t)
+  ;;(debug:print-info 13 *default-log-port* "got signal "signum)
+  (debug:print-error 0 *default-log-port* "Received signal " signum " sending email befor exiting!!")
+  ;;TODO send email to notify admin contact listed in the config that the lisner got killed
+  ;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway
+  (exit))
+
+
+(set-signal-handler! signal/int  std-signal-handler)  ;; ^C
+(set-signal-handler! signal/term std-signal-handler)
+
+;; (set-signal-handler! signal/stop std-signal-handler)  ;; ^Z NO, do NOT handle ^Z!
+
+;;======================================================================
+;; M I S C   U T I L S
+;;======================================================================
+
+;;======================================================================
+;; convert stuff to a number if possible
+(define (any->number val)
+  (cond 
+   ((number? val) val)
+   ((string? val) (string->number val))
+   ((symbol? val) (any->number (symbol->string val)))
+   (else #f)))
+
+(define (any->number-if-possible val)
+  (let ((num (any->number val)))
+    (if num num val)))
+
+(define (patt-list-match item patts)
+  (debug:print-info 8 *default-log-port* "patt-list-match item=" item " patts=" patts)
+  (if (and item patts)  ;; here we are filtering for matches with item patterns
+      (let ((res #f))   ;; look through all the item-patts if defined, format is patt1,patt2,patt3 ... wildcard is %
+	(for-each 
+	 (lambda (patt)
+	   (let ((modpatt (string-substitute "%" ".*" patt #t)))
+	     (debug:print-info 10 *default-log-port* "patt " patt " modpatt " modpatt)
+	     (if (string-match (regexp modpatt) item)
+		 (set! res #t))))
+	 (string-split patts ","))
+	res)
+      #t))
+
+;;======================================================================
+;; return first command that exists, else #f
+;;
+(define (common:which cmds)
+  (if (null? cmds)
+      #f
+      (let loop ((hed (car cmds))
+		 (tal (cdr cmds)))
+	(let ((res (with-input-from-pipe (conc "which " hed) read-line)))
+	  (if (and (string? res)
+		   (common:file-exists? res))
+	      res
+	      (if (null? tal)
+		  #f
+		  (loop (car tal)(cdr tal))))))))
+  
+(define (common:get-install-area)
+  (let ((exe-path (car (argv))))
+    (if (common:file-exists? exe-path)
+	(handle-exceptions
+	 exn
+	 #f
+	 (pathname-directory
+	  (pathname-directory 
+	   (pathname-directory exe-path))))
+	#f)))
+
+;;======================================================================
+;; return first path that can be created or already exists and is writable
+;;
+(define (common:get-create-writeable-dir dirs)
+  (if (null? dirs)
+      #f
+      (let loop ((hed (car dirs))
+		 (tal (cdr dirs)))
+	(let ((res (or (and (directory? hed)
+			    (file-write-access? hed)
+			    hed)
+		       (handle-exceptions
+			   exn
+			   (begin
+			     (debug:print-info 0 *default-log-port* "could not create " hed
+					       ", this might cause problems down the road. exn=" exn)
+			     #f)
+			(create-directory hed #t)))))
+	  (if (and (string? res)
+		   (directory? res))
+	      res
+	      (if (null? tal)
+		  #f
+		  (loop (car tal)(cdr tal))))))))
+
+;;======================================================================
+;; return the youngest timestamp . filename
+;;
+(define (common:get-youngest glob-list)
+  (let ((all-files (apply append
+			  (map (lambda (patt)
+				 (handle-exceptions
+				     exn
+				     '()
+				   (glob patt)))
+			       glob-list))))
+    (fold (lambda (fname res)
+	    (let ((last-mod (car res))
+		  (curmod   (handle-exceptions
+				exn
+				0
+			      (file-modification-time fname))))
+	      (if (> curmod last-mod)
+		  (list curmod fname)
+		  res)))
+	  '(0 "n/a")
+	  all-files)))
+
+;;======================================================================
+;; use bash to expand a glob. Does NOT handle paths with spaces!
+;;
+(define (common:bash-glob instr)
+  (string-split
+   (with-input-from-pipe
+       (conc "/bin/bash -c \"echo " instr "\"")
+       read-line)))
+
+;;======================================================================
+;; Some safety net stuff
+;;======================================================================
+
+;;======================================================================
+;; return input if it is a list or return null
+(define (common:list-or-null inlst #!key (ovrd #f)(message #f))
+  (if (list? inlst)
+      inlst
+      (begin
+	(if message (debug:print-error 0 *default-log-port* message))
+	(or ovrd '()))))
+  
+(define (common:get-fields cfgdat)
+  (let ((fields (hash-table-ref/default cfgdat "fields" '())))
+    (map car fields)))
+
+(define keys:config-get-fields common:get-fields)
+
+;;======================================================================
+;; looking only (at least for now) at the MT_ variables craft the full testname
+;;
+(define (common:get-full-test-name)
+  (if (getenv "MT_TEST_NAME")
+      (if (and (getenv "MT_ITEMPATH")
+               (not (equal? (getenv "MT_ITEMPATH") "")))
+          (getenv "MT_TEST_NAME")
+          (conc (getenv "MT_TEST_NAME") "/" (getenv "MT_ITEMPATH")))
+      #f))
+
+;;======================================================================
+;; M I S C   L I S T S
+;;======================================================================
+
+;;======================================================================
+;; items in lista are matched value and position in listb
+;; return the remaining items in listb or #f
+;;
+(define (common:list-is-sublist lista listb)
+  (if (null? lista)
+      listb ;; all items in listb are "remaining"
+      (if (> (length lista)(length listb)) 
+	  #f
+	  (let loop ((heda (car lista))
+		     (tala (cdr lista))
+		     (hedb (car listb))
+		     (talb (cdr listb)))
+	    (if (equal? heda hedb)
+		(if (null? tala) ;; we are done
+		    talb
+		    (loop (car tala)
+			  (cdr tala)
+			  (car talb)
+			  
+			  (cdr talb)))
+		#f)))))
+
+;;======================================================================
+;; Needed for long lists to be sorted where (apply max ... ) dies
+;;
+(define (common:max inlst)
+  (let loop ((max-val (car inlst))
+	     (hed     (car inlst))
+	     (tal     (cdr inlst)))
+    (if (not (null? tal))
+	(loop (max hed max-val)
+	      (car tal)
+	      (cdr tal))
+	(max hed max-val))))
+
+;; get min or max, use > for max and < for min, this works around the limits on apply
+;;
+(define (common:min-max comp lst)
+  (if (null? lst)
+      #f ;; better than an exception for my needs
+      (fold (lambda (a b)
+	      (if (comp a b) a b))
+	    (car lst)
+	    lst)))
+
+;;======================================================================
+;; get min or max, use > for max and < for min, this works around the limits on apply
+;;
+(define (common:sum lst)
+  (if (null? lst)
+      0
+      (fold (lambda (a b)
+	      (+ a b))
+	    (car lst)
+	    lst)))
+
+;;======================================================================
+;; path list to hash-table tree
+;;   ((a b c)(a b d)(e b c)) => ((a (b (d) (c))) (e (b (c))))
+;;
+(define (common:list->htree lst)
+  (let ((resh (make-hash-table)))
+    (for-each
+     (lambda (inlst)
+       (let loop ((ht  resh)
+		  (hed (car inlst))
+		  (tal (cdr inlst)))
+	 (if (hash-table-ref/default ht hed #f)
+	     (if (not (null? tal))
+		 (loop (hash-table-ref ht hed)
+		       (car tal)
+		       (cdr tal)))
+	     (begin
+	       (hash-table-set! ht hed (make-hash-table))
+	       (loop ht hed tal)))))
+     lst)
+    resh))
+
+;;======================================================================
+;; hash-table tree to alist tree
+;;
+(define (common:htree->atree ht)
+  (map (lambda (x)
+	 (cons (car x)
+	       (let ((y (cdr x)))
+		 (if (hash-table? y)
+		     (common:htree->atree y)
+		     y))))
+       (hash-table->alist ht)))
+
+;;======================================================================
+;; M U N G E   D A T A   I N T O   N I C E   F O R M S
+;;======================================================================
+
+;;======================================================================
+;; Generate an index for a sparse list of key values
+;;   ( (rowname1 colname1 val1)(rowname2 colname2 val2) )
+;;
+;; => 
+;;
+;;   ( (rowname1 0)(rowname2 1))    ;; rownames -> num
+;;     (colname1 0)(colname2 1)) )  ;; colnames -> num
+;; 
+;; optional apply proc to rownum colnum value
+(define (common:sparse-list-generate-index data #!key (proc #f))
+  (if (null? data)
+      (list '() '())
+      (let loop ((hed (car data))
+		 (tal (cdr data))
+		 (rownames '())
+		 (colnames '())
+		 (rownum   0)
+		 (colnum   0))
+	(let* ((rowkey          (car   hed))
+	       (colkey          (cadr  hed))
+	       (value           (caddr hed))
+	       (existing-rowdat (assoc rowkey rownames))
+	       (existing-coldat (assoc colkey colnames))
+	       (curr-rownum     (if existing-rowdat rownum (+ rownum 1)))
+	       (curr-colnum     (if existing-coldat colnum (+ colnum 1)))
+	       (new-rownames    (if existing-rowdat rownames (cons (list rowkey curr-rownum) rownames)))
+	       (new-colnames    (if existing-coldat colnames (cons (list colkey curr-colnum) colnames))))
+	  ;; (debug:print-info 0 *default-log-port* "Processing record: " hed )
+	  (if proc (proc curr-rownum curr-colnum rowkey colkey value))
+	  (if (null? tal)
+	      (list new-rownames new-colnames)
+	      (loop (car tal)
+		    (cdr tal)
+		    new-rownames
+		    new-colnames
+		    (if (> curr-rownum rownum) curr-rownum rownum)
+		    (if (> curr-colnum colnum) curr-colnum colnum)
+		    ))))))
+
+;;======================================================================
+;; if it looks like a number -> convert it to a number, else return it
+;;
+(define (common:lazy-convert inval)
+  (let* ((as-num (if (string? inval)(string->number inval) #f)))
+    (or as-num inval)))
+
+;;======================================================================
+;; convert string a=1; b=2; c=a silly thing; d=
+;; to '((a . 1)(b . 2)(c . "a silly thing")(d . ""))
+;;
+(define (common:val->alist val #!key (convert #f))
+  (let ((val-list (string-split-fields ";\\s*" val #:infix)))
+    (if val-list
+	(map (lambda (x)
+	       (let ((f (string-split-fields "\\s*=\\s*" x #:infix)))
+		 (case (length f)
+		   ((0) `(,#f))  ;; null string case
+		   ((1) `(,(string->symbol (car f))))
+		   ((2) `(,(string->symbol (car f)) . ,(let ((inval (cadr f)))
+							 (if convert (common:lazy-convert inval) inval))))
+		   (else f))))
+	     val-list)
+	'())))
+
+;;======================================================================
+;; S Y S T E M   S T U F F
+;;======================================================================
+
+;; return a nice clean pathname made absolute
+(define (common:nice-path dir)
+  (let ((match (string-match "^(~[^\\/]*)(\\/.*|)$" dir)))
+    (if match ;; using ~ for home?
+	(common:nice-path (conc (common:read-link-f (cadr match)) "/" (caddr match)))
+	(normalize-pathname (if (absolute-pathname? dir)
+				dir
+				(conc (current-directory) "/" dir))))))
+
+;; make "nice-path" available in config files and the repl
+(define nice-path common:nice-path)
+
+(define (common:read-link-f path)
+  (handle-exceptions
+      exn
+      (begin
+	(debug:print-error 0 *default-log-port* "command \"/bin/readlink -f " path "\" failed. exn=" exn)
+	path) ;; just give up
+    (with-input-from-pipe
+	(conc "/bin/readlink -f " path)
+      (lambda ()
+	(read-line)))))
+
+;;======================================================================
+;; returns *effective load* (not normalized)
+;;
+(define (common:get-intercept onemin fivemin)
+  (if (< onemin fivemin) ;; load is decreasing, just use the onemin load
+      onemin
+      (let* ((load-change (- onemin fivemin))
+	     (tchange     (- 300 60)))
+	(max (+ onemin (* 60 (/ load-change tchange))) 0))))
+
+(define (get-cpu-load #!key (remote-host #f))
+  (car (common:get-cpu-load remote-host)))
+
+;;======================================================================
+;;   (let* ((load-res (process:cmd-run->list "uptime"))
+;; 	 (load-rx  (regexp "load average:\\s+(\\d+)"))
+;; 	 (cpu-load #f))
+;;     (for-each (lambda (l)
+;; 		(let ((match (string-search load-rx l)))
+;; 		  (if match
+;; 		      (let ((newval (string->number (cadr match))))
+;; 			(if (number? newval)
+;; 			    (set! cpu-load newval))))))
+;; 	      (car load-res))
+;;     cpu-load))
+
+;;======================================================================
+;; get values from cached info from dropping file in logs dir
+;;  e.g. key is host and dtype is normalized-load
+;;
+(define (common:get-cached-info key dtype #!key (age 10))
+  (if *toppath*
+      (let* ((fullpath (conc *toppath* "/.sysdata/" key "-" dtype ".log"))
+	     (delfile  (lambda (exn)
+			 (debug:print-info 1 *default-log-port* " removing bad file " fullpath ", exn=" exn)
+			 (delete-file* fullpath)
+			 #f)))
+	(if (and (file-exists? fullpath)
+		 (file-read-access? fullpath))
+	    (handle-exceptions
+		exn
+	      (begin
+		(debug:print 0 *default-log-port* "failed to get cached info from " fullpath ", exn=" exn)
+		#f)
+	     (debug:print 2 *default-log-port* "reading file " fullpath)
+	     (let ((real-age (- (current-seconds)
+				(handle-exceptions
+				    exn
+				  (begin
+				    (debug:print 1 *default-log-port* "Failed to read mod time on file "
+						 fullpath ", using 0, exn=" exn)
+				    0)
+				  (file-change-time fullpath)))))
+	       (if (< real-age age)
+		   (handle-exceptions
+		       exn
+		     (delfile exn)
+		     (let* ((res (with-input-from-file fullpath read)))
+		       (if (eof-object? res)
+			   (begin
+			     (delfile "n/a")
+			     #f)
+			   res)))
+		   (begin
+		     (debug:print-info 2 *default-log-port* "file " fullpath
+				       " is too old (" real-age" seconds) to trust, skipping reading it")
+		     #f))))
+	    (begin
+	      (debug:print 2 *default-log-port* "not reading file " fullpath)
+	      #f)))
+      #f))
+ 
+(define (common:write-cached-info key dtype dat)
+  (if *toppath*
+      (let* ((fulldir  (conc *toppath* "/.sysdata"))
+	     (fullpath (conc fulldir "/" key "-" dtype ".log")))
+	(if (not (file-exists? fulldir))(create-directory fulldir #t))
+	(handle-exceptions
+	    exn
+	  (begin
+	    (debug:print 0 *default-log-port* "failed to write file " fullpath ", exn=" exn)
+	    #f)
+	  (with-output-to-file fullpath (lambda ()(pp dat)))))
+      #f))
+
+(define (common:raw-get-remote-host-load remote-host)
+  (handle-exceptions
+      exn
+    (begin
+      (debug:print 0 *default-log-port* "failed to ssh to " remote-host " and get loadavg. exn=" exn)
+      #f) ;; more specific handling of errors needed
+    (with-input-from-pipe 
+     (conc "ssh " remote-host " cat /proc/loadavg")
+     (lambda ()(list (read)(read)(read))))))
+
+;;======================================================================
+;; get cpu load by reading from /proc/loadavg, return all three values
+;;
+(define (common:get-cpu-load remote-host)
+  ;; (handle-exceptions
+  ;;     exn
+  ;;   (begin
+  ;;     (debug:print 0 *default-log-port* "failed to ssh or read loadavg from host " remote-host ", exn=" exn)
+  ;;     '(-99 -99 -99))
+    (let* ((actual-hostname (or remote-host (get-host-name) "localhost")))
+      (or (common:get-cached-info actual-hostname "cpu-load")
+	  (let ((result (if remote-host
+			    (map (lambda (res)
+				   (if (eof-object? res) 9e99 res))
+			         (with-input-from-pipe 
+				  (conc "ssh " remote-host " cat /proc/loadavg")
+				  (lambda ()(list (read)(read)(read)))))
+			    (with-input-from-file "/proc/loadavg" 
+			      (lambda ()(list (read)(read)(read)))))))
+	    (match
+		result
+	      ((l1 l2 l3)
+	       (if (and (number? l1)
+		      (number? l2)
+		      (number? l3))
+		   (begin
+		     (common:write-cached-info actual-hostname "cpu-load" result)
+		     result)
+		   '(-1 -1 -1))) ;; -1 is bad result
+	      (else '(-2 -2 -2))))))) ;; )
+
+;;======================================================================
+;; get normalized cpu load by reading from /proc/loadavg and /proc/cpuinfo return all three values and the number of real cpus and the number of threads
+;; returns alist '((adj-cpu-load . normalized-proc-load) ... etc.
+;;  keys: adj-proc-load, adj-core-load, 1m-load, 5m-load, 15m-load
+;;
+(define (common:get-normalized-cpu-load remote-host)
+  (let ((res (common:get-normalized-cpu-load-raw remote-host))
+	(default `((adj-proc-load . 2) ;; there is no right answer
+		   (adj-core-load . 2)
+		   (1m-load       . 2)
+		   (5m-load       . 0) ;; causes a large delta - thus causing default of throttling if stuff goes wrong
+		   (15m-load      . 0)
+		   (proc          . 1)
+		   (core          . 1)
+		   (phys          . 1)
+		   (error         . #t))))
+    (cond
+     ((and (list? res)
+	   (> (length res) 2))
+      res)
+     ((eq? res #f)   default) ;; add messages?
+     ((eq? res #f) default)   ;; this would be the #eof
+     (else default))))
+
+(define (common:get-normalized-cpu-load-raw remote-host)
+  (let* ((actual-host (or remote-host (get-host-name)))) ;; #f is localhost
+    (or (common:get-cached-info actual-host "normalized-load")
+	(let ((data (if remote-host
+			(with-input-from-pipe 
+			    (conc "ssh " remote-host " \"cat /proc/loadavg;cat /proc/cpuinfo;echo end\"")
+			  read-lines)
+			(append 
+			 (with-input-from-file "/proc/loadavg" 
+			   read-lines)
+			 (with-input-from-file "/proc/cpuinfo"
+			   read-lines)
+			 (list "end"))))
+	      (load-rx  (regexp "^([\\d\\.]+)\\s+([\\d\\.]+)\\s+([\\d\\.]+)\\s+.*$"))
+	      (proc-rx  (regexp "^processor\\s+:\\s+(\\d+)\\s*$"))
+	      (core-rx  (regexp "^core id\\s+:\\s+(\\d+)\\s*$"))
+	      (phys-rx  (regexp "^physical id\\s+:\\s+(\\d+)\\s*$"))
+	      (max-num  (lambda (p n)(max (string->number p) n))))
+	  ;; (print "data=" data)
+	  (if (null? data) ;; something went wrong
+	      #f
+	      (let loop ((hed      (car data))
+			 (tal      (cdr data))
+			 (loads    #f)
+			 (proc-num 0)  ;; processor includes threads
+			 (phys-num 0)  ;; physical chip on motherboard
+			 (core-num 0)) ;; core
+		;;; (print hed ", " loads ", " proc-num ", " phys-num ", " core-num)
+		(if (null? tal) ;; have all our data, calculate normalized load and return result
+		    (let* ((act-proc (+ proc-num 1))
+			   (act-phys (+ phys-num 1))
+			   (act-core (+ core-num 1))
+			   (adj-proc-load (/ (car loads) act-proc))
+			   (adj-core-load (/ (car loads) act-core))
+			   (result
+			    (append (list (cons 'adj-proc-load adj-proc-load)
+					  (cons 'adj-core-load adj-core-load))
+				    (list (cons '1m-load (car loads))
+					  (cons '5m-load (cadr loads))
+					  (cons '15m-load (caddr loads)))
+				    (list (cons 'proc act-proc)
+					  (cons 'core act-core)
+					  (cons 'phys act-phys)))))
+		      (common:write-cached-info actual-host "normalized-load" result)
+		      result)
+		  (regex-case
+		   hed
+		   (load-rx  ( x l1 l5 l15 ) (loop (car tal)(cdr tal)(map string->number (list l1 l5 l15)) proc-num phys-num core-num))
+		   (proc-rx  ( x p         ) (loop (car tal)(cdr tal) loads           (max-num p proc-num) phys-num core-num))
+		   (phys-rx  ( x p         ) (loop (car tal)(cdr tal) loads           proc-num (max-num p phys-num) core-num))
+		   (core-rx  ( x c         ) (loop (car tal)(cdr tal) loads           proc-num phys-num (max-num c core-num)))
+		   (else 
+		    (begin
+		      ;; (print "NO MATCH: " hed)
+		      (loop (car tal)(cdr tal) loads proc-num phys-num core-num)))))))))))
+
+(define (common:unix-ping hostname)
+  (let ((res (system (conc "ping -c 1 " hostname " > /dev/null"))))
+    (eq? res 0)))
+
+(define (common:get-num-cpus remote-host)
+  (let* ((actual-host (or remote-host (get-host-name))))
+    ;; hosts had better not be changing the number of cpus too often!
+    (or (hash-table-ref/default *numcpus-cache* actual-host #f)
+	(let* ((numcpus (or (common:get-cached-info actual-host "num-cpus" age: (+ 2592000 (random 3600)))
+			    (let* ((proc   (lambda ()
+					     (let loop ((numcpu 0)
+							(inl    (read-line)))
+					       (if (eof-object? inl)
+						   (if (> numcpu 0)
+						       numcpu
+						       #f) ;; if zero return #f so caller knows that things are not working
+						   (loop (if (string-match "^processor\\s+:\\s+\\d+$" inl)
+							     (+ numcpu 1)
+							     numcpu)
+							 (read-line))))))
+				   (result (if remote-host
+					       (with-input-from-pipe 
+						(conc "ssh " remote-host " cat /proc/cpuinfo")
+						proc)
+					       (with-input-from-file "/proc/cpuinfo" proc))))
+			      (if (and (number? result)
+				       (> result 0))
+				  (common:write-cached-info actual-host "num-cpus" result))
+			      result))))
+	  (hash-table-set! *numcpus-cache* actual-host numcpus)
+	  numcpus))))
+
+;;======================================================================
+;; DO NOT CALL THIS DIRECTLY. It is called from common:wait-for-normalized-load
+;;
+;; (define (common:wait-for-cpuload maxload-in numcpus-in waitdelay #!key (count 1000) (msg #f)(remote-host #f)(force-maxload #f)(num-tries 5))
+;;   (let* ((loadavg (common:get-cpu-load remote-host))
+;; 	 (numcpus (if (<= 1 numcpus-in) ;; not possible to have zero.  If we get 1, it's possible that we got the previous default, and we should check again
+;; 		      (common:get-num-cpus remote-host)
+;; 		      numcpus-in))
+;; 	 (maxload (if force-maxload
+;; 		      maxload-in
+;; 		      (if (number? maxload-in)
+;; 			  (max maxload-in 0.5)
+;; 			  0.5))) ;; so maxload must be greater than 0.5 for now BUG - FIXME?
+;; 	 (first   (car loadavg))
+;; 	 (next    (cadr loadavg))
+;; 	 (adjmaxload (* maxload (max 1 numcpus))) ;; possible bug where
+;; 					       ;; numcpus (or could be
+;; 					       ;; maxload) is zero,
+;; 					       ;; crude fallback is to
+;; 					       ;; at least use 1
+;; 	 (loadjmp (- first (if (> next (* numcpus 0.7)) ;; could do something with average of first and next?
+;; 			       0
+;; 			       next))) ;; we will force a conservative calculation any time next is large.
+;; 	 (first-next-avg    (/ (+ first next) 2))
+;; 	 ;; add some randomness to the time to break any alignment
+;; 	 ;; where netbatch dumps many jobs to machines simultaneously
+;;          (adjwait           (min (+ 300 (random 10)) (abs (* (+ (random 10)
+;; 								(/ (- 1000 count) 10)
+;; 								waitdelay)
+;; 							     (- first adjmaxload) ))))
+;; 	 (load-jump-limit   (configf:lookup-number *configdat* "setup" "load-jump-limit"))
+;; 	 ;; effective load accounts for load jumps, this should elminate all the first-next-avg, adjwait, load-jump-limit
+;; 	 ;; etc.
+;; 	 (effective-load    (common:get-intercept first next))
+;; 	 (effective-host    (or remote-host "localhost"))
+;; 	 (normalized-effective-load (/ effective-load numcpus))
+;; 	 (will-wait                 (> normalized-effective-load maxload)))
+;; 	 
+;;     ;; let's let the user know once in a long while that load checking
+;;     ;; is happening but not constantly report it
+;;     #;(if (common:low-noise-print 30 (conc "cpuload" (or remote-host "localhost"))) ;; (> (random 100) 75) ;; about 25% of the time
+;; 	(debug:print-info 1 *default-log-port* "Checking cpuload on " (or remote-host "localhost") ", maxload: " maxload
+;;     ", load: " first ", adjmaxload: " adjmaxload ", loadjmp: " loadjmp))
+;; 
+;;     (debug:print-info 1 *default-log-port*
+;; 		      "On host: " effective-host
+;; 		      ", effective load: " effective-load
+;; 		      ", numcpus: " numcpus
+;; 		      ", normalized effective load: " normalized-effective-load
+;; 		      )
+;;     
+;;     (cond
+;;      ;; bad data, try again to get the data
+;;      ((and (< first 0) ;; this indicates the loadavg data is bad - machine may not be reachable
+;; 	   (> num-tries 0))
+;;       (debug:print 0 *default-log-port* "WARNING: received bad data from get-cpu-load " first ", we'll sleep 10s and try " num-tries " more times.")
+;;       (thread-sleep! 10)
+;;       (common:wait-for-cpuload maxload-in numcpus-in waitdelay
+;; 			       count: count remote-host: remote-host force-maxload: force-maxload num-tries: (- num-tries 1)))
+;;      ;; need to wait for load to drop
+;;      ((and will-wait ;; (> first adjmaxload)
+;; 	   (> count 0))
+;;       (debug:print-info 0 *default-log-port*
+;; 			"Delaying " 15 ;; adjwait
+;; 			" seconds due to normalized effective load " normalized-effective-load ;; first
+;; 			" exceeding max of " adjmaxload
+;; 			" on server " (or remote-host (get-host-name))
+;; 			" (normalized load-limit: " maxload ") " (if msg msg ""))
+;;       (thread-sleep! 15) ;; adjwait)
+;;       (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host))
+;;      ((and (> loadjmp (cond
+;; 		       (load-jump-limit load-jump-limit)
+;; 		       ((> numcpus 8)(/ numcpus 2))
+;; 		       ((> numcpus 4)(/ numcpus 1.2))
+;; 		       (else 0.5)))
+;; 	   (> count 0))
+;;       (debug:print-info 0 *default-log-port* "waiting " adjwait " seconds due to possible load jump " loadjmp ". "
+;; 			(if msg msg ""))
+;;       (thread-sleep! adjwait)
+;;       (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host))
+;;      (else
+;;       (if (> num-tries 0)
+;; 	  (if (common:low-noise-print 30 (conc (round first) "-load-acceptable-" (or remote-host "localhost")))
+;; 	      (debug:print 0 *default-log-port* "Load on " (or remote-host "localhost") " is acceptable at " first " continuing."))
+;; 	  (debug:print 0 *default-log-port* "Load on " (or remote-host "localhost") ", "first" could not be retrieved. Giving up and continuing."))))))
+;; 
+(define (get-uname . params)
+  (let* ((uname-res (process:cmd-run->list (conc "uname " (if (null? params) "-a" (car params)))))
+	 (uname #f))
+    (if (null? (car uname-res))
+	"unknown"
+	(caar uname-res))))
+
+;;======================================================================
+;; for reasons I don't understand multiple calls to real-path in parallel threads
+;; must be protected by mutexes
+;;
+(define (common:real-path inpath)
+  ;; (process:cmd-run-with-stderr->list "readlink" "-f" inpath)) ;; cmd . params)
+  ;; (let-values 
+  ;;  (((inp oup pid) (process "readlink" (list "-f" inpath))))
+  ;;  (with-input-from-port inp
+  ;;    (let loop ((inl (read-line))
+  ;;       	(res #f))
+  ;;      (print "inl=" inl)
+  ;;      (if (eof-object? inl)
+  ;;          (begin
+  ;;            (close-input-port inp)
+  ;;            (close-output-port oup)
+  ;;            ;; (process-wait pid)
+  ;;            res)
+  ;;          (loop (read-line) inl))))))
+  (with-input-from-pipe (conc "readlink -f " inpath) read-line))
+
+;;======================================================================
+;; D I S K   S P A C E 
+;;======================================================================
+
+(define (common:get-disk-space-used fpath)
+  (with-input-from-pipe (conc "/usr/bin/du -s " fpath) read))
+
+(define (get-unix-df path)
+  (let* ((df-results (process:cmd-run->list (conc "df " path)))
+	 (space-rx   (regexp "([0-9]+)\\s+([0-9]+)%"))
+	 (freespc    #f))
+    ;; (write df-results)
+    (for-each (lambda (l)
+		(let ((match (string-search space-rx l)))
+		  (if match 
+		      (let ((newval (string->number (cadr match))))
+			(if (number? newval)
+			    (set! freespc newval))))))
+	      (car df-results))
+    freespc))
+
+(define (get-unix-inodes path)
+  (let* ((df-results (process:cmd-run->list (conc "df -i " path)))
+	 (space-rx   (regexp "([0-9]+)\\s+([0-9]+)%"))
+	 (freenodes    0)) ;; 0 is a better failsafe than #f here.
+    ;; (write df-results)
+    (for-each (lambda (l)
+		(let ((match (string-search space-rx l)))
+		  (if match 
+		      (let ((newval (string->number (cadr match))))
+			(if (number? newval)
+			    (set! freenodes newval))))))
+	      (car df-results))
+    freenodes))
+
+;;======================================================================
+;; convert a spec string to a list of vectors #( rx  action rx-string )
+(define (common:spec-string->list-of-specs spec-string actions)
+  (let ((spec-strings  (string-split-fields "\\s*;\\s*" spec-string #:infix))
+	(actions-regex (regexp (conc "^(.*)\\s+(" (string-intersperse (map conc actions) "|") ")"))))
+    (filter
+     (lambda (x) x)
+     (map (lambda (s)
+	    (let ((m (string-match actions-regex s)))
+	      (if m
+		  (vector (regexp (cadr m))(string->symbol (caddr m))(cadr m))
+		  (begin
+		    (debug:print 0 *default-log-port* "WARNING: Unrecognised rule \"" s "\" in clean-up specification.")
+		    #f))))
+	  spec-strings))))
+  
+;;======================================================================
+;; given a list of specs rx . rule and a file return the first matching rule
+;; 
+(define (common:file-find-rule fname rules) ;; rule is vector #( rx action rx-string)
+  (let loop ((rule   (car rules))
+	     (tail   (cdr rules)))
+    (let ((rx (vector-ref rule 0))
+	  (rn (vector-ref rule 1))) ;; rule name
+      (if (string-match rx fname)
+	  rule ;; return the whole rule so regex can be printed etc.
+	  (if (null? tail)
+	      #f
+	      (loop (car tail)(cdr tail)))))))
+
+;;======================================================================
+;; given a spec apply some rules to a directory
+;;
+;;  WARNING: This function will REMOVE files - be sure your spec and path is correct!
+;;
+;; spec format:
+;;   file-regex1 action; file-regex2 action; ...
+;; e.g.
+;;   .*\.log$ keep; .* remove
+;;   --> keep all .log files, remove everything else
+;; limitations:
+;;   cannot have a rule with ; as part of the spec
+;;   not very flexible, would be nice to return binned file names?
+;; supported rules:
+;;   keep     - keep this file
+;;   remove   - remove this file
+;;   compress - compress this file
+;;
+(define (common:dir-clean-up path spec-string #!key (compress "gzip")(actions '(keep remove compress))(remove-empty #f))
+  (let* ((specs         (common:spec-string->list-of-specs spec-string actions))
+	 (keepers       (make-hash-table))
+	 (directories   (make-hash-table)))
+    (find-files 
+     path
+     action: (lambda (p res)
+	       (let ((rule  (common:file-find-rule p specs)))
+		 (cond
+		  ((directory? p)(hash-table-set! directories p #t))
+		  (else
+		   (case (vector-ref rule 1)
+		     ((keep)(hash-table-set! keepers p rule))
+		     ((remove)
+		      (print "Removing file " p)
+		      (delete-file p))
+		     ((compress)
+		      (print "Compressing file " p)
+		      (system (conc compress " " p)))
+		     (else
+		      (print "No match for file " p))))))))
+    (if remove-empty
+	(for-each
+	 (lambda (d)
+	   (if (null? (glob (conc d "/.*")(conc d "/*")))
+	       (begin
+		 (print "Removing empty directory " d)
+		 (delete-directory d))))
+	 (sort (hash-table-keys directories) (lambda (a b)(> (string-length a)(string-length b))))))
+    ))
+
+;;======================================================================
+;; E N V I R O N M E N T   V A R S
+;;======================================================================
+(define (bb-check-path #!key (msg "check-path: "))
+  (let ((path (or (get-environment-variable "PATH") "none")))
+    (debug:print-info 0 *default-log-port* (conc msg" : $PATH="path))
+    (if (string-match "^.*/isoenv-core/.*" path)
+        (debug:print-error 0 *default-log-port* (conc msg" : !!ISOENV PRESENT!!")) ;; remove for prod
+        (debug:print-info 1 *default-log-port* (conc msg" : **no isoenv present**")))))
+
+	      
+(define (save-environment-as-files fname #!key (ignorevars (list "USER" "HOME" "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR" "MAKEFLAGS" "MAKEF" "MAKEOVERRIDES")))
+  ;;(bb-check-path msg: "save-environment-as-files entry")
+  (let ((envvars (get-environment-variables))
+        (whitesp (regexp "[^a-zA-Z0-9_\\-:,\\.\\/%$]"))
+	(mungeval (lambda (val)
+		    (cond
+		     ((eq? val #t) "") ;; convert #t to empty string
+		     ((eq? val #f) #f) ;; convert #f to itself (still thinking about this one
+		     (else val)))))
+    (with-output-to-file (conc fname ".csh")
+       (lambda ()
+          (for-each (lambda (keyval)
+		      (let* ((key   (car keyval))
+			     (val   (cdr keyval))
+			     (delim (if (string-search whitesp val) 
+					"\""
+					"")))
+			(print (if (or (member key ignorevars)
+				       (string-search whitesp key))
+				   "# setenv "
+				   "setenv ")
+			       key " " delim (mungeval val) delim)))
+		    envvars)))
+     (with-output-to-file (conc fname ".sh")
+       (lambda ()
+          (for-each (lambda (keyval)
+		      (let* ((key (car keyval))
+			     (val (cdr keyval))
+			     (delim (if (string-search whitesp val) 
+					"\""
+					"")))
+			(print (if (or (member key ignorevars)
+				       (string-search whitesp key)
+				       (string-search ":" key)) ;; internal only values to be skipped.
+				   "# export "
+				   "export ")
+			       key "=" delim (mungeval val) delim)))
+                    envvars)))))
+
+;;======================================================================
+;;
+(define (common:propogate-mt-vars-to-subrun proc propogate-vars)
+  (let ((vars      (make-hash-table))
+        (var-patt  "^MT_.*"))
+    (for-each
+     (lambda (vardat) ;; each env var
+       ;(for-each
+      ;(lambda (var-patt)
+          (if (string-match var-patt (car vardat))
+              (let ((var (car vardat))
+                    (val (cdr vardat)))
+                (hash-table-set! vars var val)
+                 (if (member var propogate-vars)
+                  (begin
+                  (print var "  " (string-substitute "MT_" "PARENT_" var))
+                  (setenv (string-substitute "MT_" "PARENT_"  var) val)))
+                (unsetenv var))))
+;       var-patts))
+     (get-environment-variables))
+    (cond
+     ((string? proc)(system proc))
+     (proc          (proc)))
+    (hash-table-for-each
+     vars
+     (lambda (var val)
+         (if (member var propogate-vars)
+         (unsetenv (string-substitute "MT_" "PARENT_" var)))  
+       (setenv var val)))
+    vars))
+
+
+(define (common:get-param-mapping #!key (flavor #f))
+  "returns alist mapping string keys in testconfig/subrun to megatest command line switches; if flavor is switch-symbol, maps tcmt symbolic switches to megatest switches"
+  (let ((default '(("tag-expr"  . "-tagexpr")
+                   ("mode-patt" . "-modepatt")
+                   ("run-name"  . "-runname")
+                   ("contour"   . "-contour")
+                   ("target"    . "-target")
+                   ("test-patt" . "-testpatt")
+		   ("rerun"     . "-rerun")
+		   ("setvars"   . "-setvars")
+                   ("msg"       . "-m")
+                   ("log"       . "-log")
+                   ("start-dir" . "-start-dir")
+                   ("new"       . "-set-state-status"))))
+    (if (eq? flavor 'switch-symbol)
+        (map (lambda (x)
+               (cons (string->symbol (conc "-" (car x))) (cdr x)))
+             default)
+        default)))
+
+;;======================================================================
+;; set some env vars from an alist, return an alist with original values
+;; (("VAR" "value") ...)
+;; a value of #f means "unset this var"
+;;
+(define (alist->env-vars lst)
+  (if (list? lst)
+      (let ((res '()))
+	(for-each (lambda (p)
+		    (let* ((var (car  p))
+			   (val (cadr p))
+			   (prv (get-environment-variable var)))
+		      (set! res (cons (list var prv) res))
+		      (if val 
+			  (safe-setenv var (->string val))
+			  (unsetenv var))))
+		  lst)
+	res)
+      '()))
+
+;;======================================================================
+;; clear vars matching pattern, run proc, set vars back
+;; if proc is a string run that string as a command with
+;; system.
+;;
+(define *common:orig-env*
+  (let ((envvars (get-environment-variables)))
+    (if (get-environment-variable "MT_ORIG_ENV")
+        (with-input-from-string
+            (z3:decode-buffer (base64:base64-decode (get-environment-variable "MT_ORIG_ENV")))
+          read)
+        (filter-map (lambda (x)
+                      (if (string-match "^MT_.*" (car x))
+                          #f
+                          x))
+                    envvars))))
+
+(define (common:with-orig-env proc)
+  (let  ((current-env (get-environment-variables)))
+    (for-each (lambda (x) (unsetenv (car x)))             current-env)
+    (for-each (lambda (x) (setenv (car x) (cdr x))) *common:orig-env*)
+    (let ((rv (cond
+               ((string? proc)(system proc))
+               (proc          (proc)))))
+      (for-each (lambda (x) (unsetenv (car x))) *common:orig-env*)
+      (for-each (lambda (x) (setenv (car x) (cdr x))) current-env)
+      rv)))
+
+(define (common:without-vars proc . var-patts)
+  (let ((vars (make-hash-table)))
+    (for-each
+     (lambda (vardat) ;; each env var
+       (for-each
+	(lambda (var-patt)
+	  (if (string-match var-patt (car vardat))
+	      (let ((var (car vardat))
+		    (val (cdr vardat)))
+		(hash-table-set! vars var val)
+		(unsetenv var))))
+	var-patts))
+     (get-environment-variables))
+    (cond
+     ((string? proc)(system proc))
+     (proc          (proc)))
+    (hash-table-for-each
+     vars
+     (lambda (var val)
+       (setenv var val)))
+    vars))
+
+;;======================================================================
+;; C O L O R S
+;;======================================================================
+      
+(define (common:name->iup-color name)
+  (case (string->symbol (string-downcase name))
+    ((red)    "223 33 49")
+    ((grey)   "192 192 192")
+    ((orange) "255 172 13")
+    ((purple) "This is unfinished ...")))
+
+;;======================================================================
+;; (define (common:get-color-for-state-status state status)
+;;   (case (string->symbol state)
+;;     ((COMPLETED)
+;;      (case (string->symbol status)
+;;        ((PASS)        "70  249 73")
+;;        ((WARN WAIVED) "255 172 13")
+;;        ((SKIP)        "230 230 0")
+;;        (else "223 33 49")))
+;;     ((LAUNCHED)         "101 123 142")
+;;     ((CHECK)            "255 100 50")
+;;     ((REMOTEHOSTSTART)  "50  130 195")
+;;     ((RUNNING)          "9   131 232")
+;;     ((KILLREQ)          "39  82  206")
+;;     ((KILLED)           "234 101 17")
+;;     ((NOT_STARTED)      "240 240 240")
+;;     (else               "192 192 192")))
+
+(define (common:iup-color->rgb-hex instr)
+  (string-intersperse 
+   (map (lambda (x)
+          (number->string x 16))
+        (map string->number
+             (string-split instr)))
+   "/"))
+
+
+;;======================================================================
+;;
+;;======================================================================
+
+(define (common:get-color-from-status status)
+  (cond
+   ((equal? status "PASS")    "green")
+   ((equal? status "FAIL")    "red")
+   ((equal? status "WARN")    "orange")
+   ((equal? status "KILLED")  "orange")
+   ((equal? status "KILLREQ") "purple")
+   ((equal? status "RUNNING") "blue")
+   ((equal? status "ABORT")   "brown")
+   (else "black")))
+
+(define (tests:cache-regexp str-in flag)
+  (let* ((key (conc str-in flag)))
+    (or (hash-table-ref/default *glob-like-match-cache* key #f)
+	(let* ((newrx (regexp str-in flag)))
+	  (hash-table-set! *glob-like-match-cache* key newrx)
+	  newrx))))
+
+;;======================================================================
+;; tests:glob-like-match 
+(define (tests:glob-like-match patt str) 
+  (let* ((like     (substring-index "%" patt))
+	 (notpatt  (equal? (substring-index "~" patt) 0))
+	 (newpatt  (if notpatt (substring patt 1) patt))
+	 (finpatt  (if like
+		       (string-substitute (regexp "%") ".*" newpatt #f)
+		       (string-substitute (regexp "\\*") ".*" newpatt #f)))
+	 (rx       (tests:cache-regexp finpatt (if like #t #f)))
+	 (res      (string-match rx str)))
+    (if notpatt (not res) res)))
+
+;;======================================================================
+;; if itempath is #f then look only at the testname part
+;;
+(define (tests:match patterns testname itempath #!key (required '()))
+  (if (string? patterns)
+      (let ((patts (append (string-split patterns ",") required)))
+	(if (null? patts) ;;; no pattern(s) means no match
+	    #f
+	    (let loop ((patt (car patts))
+		       (tal  (cdr patts)))
+	      ;; (print "loop: patt: " patt ", tal " tal)
+	      (if (string=? patt "")
+		  #f ;; nothing ever matches empty string - policy
+		  (let* ((patt-parts (string-match (regexp "^([^\\/]*)(\\/(.*)|)$") patt))
+			 (test-patt  (cadr patt-parts))
+			 (item-patt  (cadddr patt-parts)))
+		    ;; special case: test vs. test/
+		    ;;   test  => "test" "%"
+		    ;;   test/ => "test" ""
+		    (if (and (not (substring-index "/" patt)) ;; no slash in the original
+			     (or (not item-patt)
+				 (equal? item-patt "")))      ;; should always be true that item-patt is ""
+			(set! item-patt "%"))
+		    ;; (print "tests:match => patt-parts: " patt-parts ", test-patt: " test-patt ", item-patt: " item-patt)
+		    (if (and (tests:glob-like-match test-patt testname)
+			     (or (not itempath)
+				 (tests:glob-like-match (if item-patt item-patt "") itempath)))
+			#t
+			(if (null? tal)
+			    #f
+			    (loop (car tal)(cdr tal)))))))))))
+
+;;======================================================================
+;; make a query (fieldname like 'patt1' OR fieldname 
+(define (db:patt->like fieldname pattstr #!key (comparator " OR "))
+  (let ((patts (if (string? pattstr)
+		   (string-split pattstr ",")
+		   '("%"))))
+    (string-intersperse (map (lambda (patt)
+			       (let ((wildtype (if (substring-index "%" patt) "LIKE" "GLOB")))
+				 (conc fieldname " " wildtype " '" patt "'")))
+			     (if (null? patts)
+				 '("")
+				 patts))
+			comparator)))
+
+;;======================================================================
+;; if itempath is #f then look only at the testname part
+;;
+(define (tests:match->sqlqry patterns)
+  (if (string? patterns)
+      (let ((patts (string-split patterns ",")))
+	(if (null? patts) ;;; no pattern(s) means no match, we will do no query
+	    #f
+	    (let loop ((patt (car patts))
+		       (tal  (cdr patts))
+		       (res  '()))
+	      ;; (print "loop: patt: " patt ", tal " tal)
+	      (let* ((patt-parts (string-match (regexp "^([^\\/]*)(\\/(.*)|)$") patt))
+		     (test-patt  (cadr patt-parts))
+		     (item-patt  (cadddr patt-parts))
+		     (test-qry   (db:patt->like "testname" test-patt))
+		     (item-qry   (db:patt->like "item_path" item-patt))
+		     (qry        (conc "(" test-qry " AND " item-qry ")")))
+		;; (print "tests:match => patt-parts: " patt-parts ", test-patt: " test-patt ", item-patt: " item-patt)
+		(if (null? tal)
+		    (string-intersperse (append (reverse res)(list qry)) " OR ")
+		    (loop (car tal)(cdr tal)(cons qry res)))))))
+      #f))
+
+;;======================================================================
+;; A routine to map itempaths using a itemmap
+;; patha and pathb must be strings or this will fail
+;;
+;; path-b is waiting on path-a
+;;
+(define (db:compare-itempaths test-b-name path-a path-b itemmaps )
+  (debug:print-info 6 *default-log-port* "ITEMMAPS: " itemmaps)
+  (let* ((itemmap    (tests:lookup-itemmap itemmaps test-b-name)))
+    (if itemmap
+	(let ((path-b-mapped (db:multi-pattern-apply path-b itemmap)))
+	  (debug:print-info 6 *default-log-port* "ITEMMAP is " itemmap ", path: " path-b ", mapped path: " path-b-mapped)
+	  (equal? path-a path-b-mapped))
+	(equal? path-b path-a))))
+
+;;======================================================================
+;; A routine to convert test/itempath using a itemmap
+;; NOTE: to process only an itempath (i.e. no prepended testname)
+;;       just call db:multi-pattern-apply
+;;
+(define (db:convert-test-itempath path-in itemmap)
+  (debug:print-info 6 *default-log-port* "ITEMMAP is " itemmap)
+  (let* ((path-parts  (string-split path-in "/"))
+	 (test-name   (if (null? path-parts) "" (car path-parts)))
+	 (item-path   (string-intersperse (if (null? path-parts) '() (cdr path-parts)) "/")))
+    (conc test-name "/" 
+	  (db:multi-pattern-apply item-path itemmap))))
+
+;;======================================================================
+;; patterns are:
+;;    "rx1"  "replacement1"\n
+;;    "rx2"  "replacement2"
+;; etc.
+;;
+(define (db:multi-pattern-apply item-path itemmap)
+  (let ((all-patts (string-split itemmap "\n")))
+    (if (null? all-patts)
+	item-path
+	(let loop ((hed (car all-patts))
+		   (tal (cdr all-patts))
+		   (res item-path))
+	  (let* ((parts (string-split hed))
+		 (patt  (car parts))
+
+		 (repl  (if (> (length parts) 1)(cadr parts) ""))
+
+		 (newr  (if (and patt repl)
+			    (begin
+                              (handle-exceptions
+                               exn
+                               (begin
+                                  (debug:print 0 *default-log-port*
+                                  "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl ", exn=" exn)
+                                 res)
+                              (string-substitute patt repl res))
+
+
+                              )
+			    (begin
+                              (debug:print 0 *default-log-port*
+                               "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl)
+			      res))))
+	    (if (null? tal)
+		newr
+		(loop (car tal)(cdr tal) newr)))))))
+
+
+(define (keys->valslots keys) ;; => ?,?,? ....
+  (string-intersperse (map (lambda (x) "?") keys) ","))
+
+;;======================================================================
+;; (define-inline (keys->key/field keys . additional)
+;;   (string-join (map (lambda (k)(conc k " TEXT"))
+;; 		    (append keys additional)) ","))
+
+(define (item-list->path itemdat)
+  (if (list? itemdat)
+      (string-intersperse  (map cadr itemdat) "/")
+      ""))
+
+(define (launch:is-test-alive host pid)
+  (if (and host pid (not (equal? host "n/a")))
+      (let* ((is-local (equal? host (get-host-name)))
+	     (ssh-cmd   (if is-local " " (conc "ssh " host " ")))
+	     (cmd (conc ssh-cmd "pstree -A " pid))
+	     (output (with-input-from-pipe cmd read-lines)))
+	(debug:print 2 *default-log-port* "Running " cmd " received " output)
+	(if (eq? (length output) 0)
+	   #f
+	   #t))
+      #t))
+ 
+;;======================================================================
+;; N A N O M S G   C L I E N T
+;;======================================================================
+;; 
+;; 
+;; 
+;; (define (common:send-dboard-main-changed)
+;;   (let* ((dashboard-ips (mddb:get-dashboards)))
+;;     (for-each
+;;      (lambda (ipadr)
+;;        (let* ((soc (common:open-nm-req (conc "tcp://" ipadr)))
+;; 	      (msg (conc "main " *toppath*))
+;; 	      (res (common:nm-send-receive-timeout soc msg)))
+;; 	 (if (not res) ;; couldn't reach that dashboard - remove it from db
+;; 	     (print "ERROR: couldn't reach dashboard " ipadr))
+;; 	 res))
+;;      dashboard-ips)))
+;;     
+;;     
+;; ;;======================================================================
+;; ;; D A S H B O A R D   D B 
+;; ;;======================================================================
+;; 
+;; (define (mddb:open-db)
+;;   (let* ((db (open-database (conc (get-environment-variable "HOME") "/.dashboard.db"))))
+;;     (set-busy-handler! db (busy-timeout 10000))
+;;     (for-each
+;;      (lambda (qry)
+;;        (exec (sql db qry)))
+;;      (list 
+;;       "CREATE TABLE IF NOT EXISTS vars       (id INTEGER PRIMARY KEY,key TEXT, val TEXT, CONSTRAINT varsconstraint UNIQUE (key));"
+;;       "CREATE TABLE IF NOT EXISTS dashboards (
+;;           id         INTEGER PRIMARY KEY,
+;;           pid        INTEGER,
+;;           username   TEXT,
+;;           hostname   TEXT,
+;;           ipaddr     TEXT,
+;;           portnum    INTEGER,
+;;           start_time TIMESTAMP DEFAULT (strftime('%s','now')),
+;;              CONSTRAINT hostport UNIQUE (hostname,portnum)
+;;         );"
+;;       ))
+;;     db))
+;; 
+;; ;; register a dashboard 
+;; ;;
+;; (define (mddb:register-dashboard port)
+;;   (let* ((pid      (current-process-id))
+;; 	 (hostname (get-host-name))
+;; 	 (ipaddr   (server:get-best-guess-address hostname))
+;; 	 (username (current-user-name)) ;; (car userinfo)))
+;; 	 (db      (mddb:open-db)))
+;;     (print "Register monitor, pid: " pid ", hostname: " hostname ", port: " port ", username: " username)
+;;     (exec (sql db "INSERT OR REPLACE INTO dashboards (pid,username,hostname,ipaddr,portnum) VALUES (?,?,?,?,?);")
+;; 	   pid username hostname ipaddr port)
+;;     (close-database db)))
+;; 
+;; ;; unregister a monitor
+;; ;;
+;; (define (mddb:unregister-dashboard host port)
+;;   (let* ((db      (mddb:open-db)))
+;;     (print "Register unregister monitor, host:port=" host ":" port)
+;;     (exec (sql db "DELETE FROM dashboards WHERE hostname=? AND portnum=?;") host port)
+;;     (close-database db)))
+;; 
+;; ;; get registered dashboards
+;; ;;
+;; (define (mddb:get-dashboards)
+;;   (let ((db (mddb:open-db)))
+;;     (query fetch-column
+;; 	   (sql db "SELECT ipaddr || ':' || portnum FROM dashboards;"))))
+    
+;;======================================================================
+;; NMSG AND NEW API
+;;======================================================================
+
+;; nm based server experiment, keep around for now.
+;;
+#;(define (nm:start-server dbconn #!key (given-host-name #f))
+  (let* ((srvdat    (start-raw-server given-host-name: given-host-name))
+	 (host-name (srvdat-host srvdat))
+	 (soc       (srvdat-soc srvdat)))
+    
+    ;; start the queue processor (save for second round of development)
+    ;;
+    (thread-start! (make-thread! (lambda ()(queue-processor dbconn) "Queue processor")))
+    ;; msg is an alist
+    ;;  'r host:port  <== where to return the data
+    ;;  'p params     <== data to apply the command to
+    ;;  'e j|s|l      <== encoding of the params. default is s (sexp), if not specified is assumed to be default
+    ;;  'c command    <== look up the function to call using this key
+    ;;
+    (let loop ((msg-in (nn-recv soc)))
+      (if (not (equal? msg-in "quit"))
+	  (let* ((dat        (decode msg-in))
+		 (host-port  (alist-ref 'r dat)) ;; this is for the reverse req rep where the server is a client of the original client
+		 (params     (alist-ref 'p dat))
+		 (command    (let ((c (alist-ref 'c dat)))(if c (string->symbol c) #f)))
+		 (all-good   (and host-port params command (hash-table-exists? *commands* command))))
+	    (if all-good
+		(let ((cmddat (make-qitem
+			       command:   command
+			       host-port: host-port
+			       params:    params)))
+		  (queue-push cmddat) 		;; put request into the queue
+		  (nn-send soc "queued"))         ;; reply with "queued"
+		(print "ERROR: ["(common:human-time)"] BAD request " dat))
+	    (loop (nn-recv soc)))))
+    (nn-close soc)))
+
+;;======================================================================
+;; H I E R A R C H I C A L   H A S H   T A B L E S
+;;======================================================================
+
+;;======================================================================
+;; Every element including top element is a vector:
+;;   <vector subhash value>
+
+(define (hh:make-hh #!key (ht #f)(value #f))
+  (vector (or ht    (make-hash-table)) value))
+
+;; used internally
+(define-inline (hh:set-ht! hh ht)       (vector-set! hh 0 ht))
+(define-inline (hh:get-ht hh)           (vector-ref  hh 0))
+(define-inline (hh:set-value! hh value) (vector-set! hh 1 value))
+(define-inline (hh:get-value  hh value) (vector-ref  hh 1))
+
+;;======================================================================
+;; given a hierarchial hash and some keys look up the value ...
+;;
+(define (hh:get hh . keys)
+  (if (null? keys)
+      (vector-ref hh 1) ;; we have reached the end of the line, return the value sought
+      (let ((sub-ht (hh:get-ht hh)))
+	(if sub-ht ;; yes, there is more hierarchy
+	    (let ((sub-hh (hash-table-ref/default sub-ht (car keys) #f)))
+	      (if sub-hh
+		  (apply hh:get sub-hh (cdr keys))
+		  #f))
+	    #f))))
+
+;;======================================================================
+;; given a hierarchial hash, a value and some keys, add needed hierarcy and insert the value
+;;
+(define (hh:set! hh value . keys)
+  (if (null? keys)
+      (hh:set-value! hh value) ;; we have reached the end of the line, store the value
+      (let ((sub-ht (hh:get-ht hh)))
+	(if sub-ht ;; yes, there is more hierarchy
+	    (let ((sub-hh (hash-table-ref/default sub-ht (car keys) #f)))
+	      (if (not sub-hh) ;; we'll need to add the next level of hierarchy
+		  (let ((new-sub-hh (hh:make-hh)))
+		    (hash-table-set! sub-ht (car keys) new-sub-hh)
+		    (apply hh:set! new-sub-hh value (cdr keys)))
+		  (apply hh:set! sub-hh value (cdr keys))))    ;; call the sub-hierhash with remaining keys
+	    (begin
+	      (hh:set-ht! hh (make-hash-table))
+	      (apply hh:set! hh value keys))))))
+  
+;;======================================================================
+;; Manage pkts, used in servers, tests and likely other contexts so put
+;; in common
+;;======================================================================
+
+(define common:pkts-spec
+  '((default . ((parent    . P)
+                (action    . a)
+                (filename  . f)))
+    (configf . ((parent    . P)
+                (action    . a)
+                (filename  . f)))
+    (server  . ((action    . a)
+		(pid       . d)
+		(ipaddr    . i)
+		(port      . p)
+		(parent    . P)))
+    			  
+    (test    . ((cpuuse    . c)
+		(diskuse   . d)
+		(item-path . i)
+		(runname   . r)
+		(state     . s)
+		(target    . t)
+		(status    . u)
+		(parent    . P)))))
+
+(define (common:get-pkt-alists pkts)
+  (map (lambda (x)
+	 (alist-ref 'apkt x)) ;; 'pkta pulls out the alist from the read pkt
+       pkts))
+
+;;======================================================================
+;; given list of pkts (alist mode) return list of D cards as Unix epoch, sorted descending
+;; also delete duplicates by target i.e. (car pkt)
+;;
+(define (common:get-pkt-times pkts)
+  (delete-duplicates
+   (sort 
+    (map (lambda (x)
+	   `(,(alist-ref 't x) . ,(string->number (alist-ref 'D x))))
+	 pkts)
+    (lambda (a b)(> (cdr a)(cdr b))))      ;; sort descending
+   (lambda (a b)(equal? (car a)(car b))))) ;; remove duplicates by target
+
+;;======================================================================
+;; accept an alist or hash table containing envvar/env value pairs (value of #f causes unset) 
+;;   execute thunk in context of environment modified as per this list
+;;   restore env to prior state then return value of eval'd thunk.
+;;   ** this is not thread safe **
+(define (common:with-env-vars delta-env-alist-or-hash-table thunk)
+  (let* ((delta-env-alist (if (hash-table? delta-env-alist-or-hash-table)
+                              (hash-table->alist delta-env-alist-or-hash-table)
+                              delta-env-alist-or-hash-table))
+         (restore-thunks
+          (filter
+           identity
+           (map (lambda (env-pair)
+                  (let* ((env-var     (car env-pair))
+                         (new-val     (let ((tmp (cdr env-pair)))
+                                        (if (list? tmp) (car tmp) tmp)))
+                         (current-val (get-environment-variable env-var))
+                         (restore-thunk
+                          (cond
+                           ((not current-val) (lambda () (unsetenv env-var)))
+                           ((not (string? new-val)) #f)
+                           ((eq? current-val new-val) #f)
+                           (else 
+                            (lambda () (setenv env-var current-val))))))
+                    ;;(when (not (string? new-val))
+                    ;;    (debug:print 0 *default-log-port* " PROBLEM: not a string: "new-val"\n from env-alist:\n"delta-env-alist)
+                    ;;    (pp delta-env-alist)
+                    ;;    (exit 1))
+                        
+                    
+                    (cond
+                     ((not new-val)  ;; modify env here
+                      (unsetenv env-var))
+                     ((string? new-val)
+                      (setenv env-var new-val)))
+                    restore-thunk))
+                delta-env-alist))))
+    (let ((rv (thunk)))
+      (for-each (lambda (x) (x)) restore-thunks) ;; restore env to original state
+      rv)))
+
+(define *common:thread-punchlist* (make-hash-table))
+(define (common:send-thunk-to-background-thread thunk #!key (name #f))
+  ;;(BB> "launched thread " name)
+
+  ;; we need a unique name for the thread.
+  (let* ((realname (if name
+                       (if (not (hash-table-ref/default *common:thread-punchlist* name #f))
+                           name
+                           (conc name"-" (symbol->string (gensym))))
+                       (conc "anonymous-"(symbol->string (gensym)))))
+         (realthunk (lambda ()
+                      (let ((res (thunk)))
+                        (hash-table-delete! *common:thread-punchlist* realname)
+                        res)))
+         (thread   (make-thread realthunk realname)))
+    (hash-table-set! *common:thread-punchlist* realname thread)
+    (thread-start! thread)
+    ))
+
+(define (common:join-backgrounded-threads)
+  ;; may need to trap and ignore exceptions -- dunno how atomic threads are...
+  (for-each
+   (lambda (thread-name)
+     (let* ((thread (hash-table-ref/default *common:thread-punchlist* thread-name #f)))
+       (if thread
+           (handle-exceptions
+               exn
+	     (begin
+	       (debug:print 0 *default-log-port* "joining threads failed. exn=" exn)
+               #t) ;; just ignore it, it might have died in the meantime so joining it will throw an exception
+             (thread-join! thread))
+           )))
+   (hash-table-keys *common:thread-punchlist*)))
+
+;;======================================================================
+;; (define *common:telemetry-log-state* 'startup)
+;; (define *common:telemetry-log-socket* #f)
+;; 
+;; (define (common:telemetry-log-open)
+;;   (if (eq? *common:telemetry-log-state* 'startup)
+;;       (let* ((serverhost (configf:lookup *configdat* "telemetry" "host"))
+;;              (serverport (configf:lookup-number *configdat* "telemetry" "port"))
+;;              (user (or (get-environment-variable "USER") "unknown"))
+;;              (host (or (get-environment-variable "HOST") "unknown")))
+;;         (set! *common:telemetry-log-state*
+;;               (handle-exceptions
+;;                exn
+;;                (begin
+;;                  (debug:print-info 0 *default-log-port* "common-telemetry-log open udp port failure")
+;;                  'broken)
+;;                (if (and serverhost serverport user host)
+;;                    (let* ((s (udp-open-socket)))
+;;                      ;;(udp-bind! s #f 0)
+;;                      (udp-connect! s serverhost serverport)
+;;                      (set! *common:telemetry-log-socket* s)
+;;                      'open)
+;;                    'not-needed))))))
+;;   
+;; (define (common:telemetry-log event #!key (payload '()))
+;;   (if (eq? *common:telemetry-log-state* 'startup)
+;;       (common:telemetry-log-open))
+;; 
+;;   (if (eq? 'open *common:telemetry-log-state*)
+;;       (handle-exceptions
+;;        exn
+;;        (begin
+;;          (debug:print-info 0 *default-log-port* "common-telemetry-log comms failure ; disabled (no server?)")
+;;          ;;(define *common:telemetry-log-state* 'broken-or-no-server-preclose)
+;;          ;;(common:telemetry-log-close)
+;;          (define *common:telemetry-log-state* 'broken-or-no-server)
+;;          (set! *common:telemetry-log-socket* #f)
+;;          )
+;;        (if (and *common:telemetry-log-socket* event) ;; TODO - filter on event against telemetry.want-events
+;;            (let* ((user (or (get-environment-variable "USER") "unknown"))
+;;                   (host (or (get-environment-variable "HOST") "unknown"))
+;;                   (start (conc "[megatest "event"]"))
+;;                   (toppath (or *toppath* "/dev/null"))
+;;                   (payload-serialized
+;;                    (base64:base64-encode
+;;                     (z3:encode-buffer
+;;                      (with-output-to-string (lambda () (pp payload))))))
+;;                   (msg     (conc user":"host":"start":"(current-process-id)":"(car (argv))":"
+;;                                  toppath":"payload-serialized)))
+;;              (udp-send *common:telemetry-log-socket* msg))))))
+;;   
+;; (define (common:telemetry-log-close)
+;;   (when (or (member *common:telemetry-log-state* '(broken-or-no-server-preclose open)) *common:telemetry-log-socket*)
+;;     (handle-exceptions
+;;      exn
+;;      (begin
+;;        (define *common:telemetry-log-state* 'closed-fail)
+;;        (debug:print-info 0 *default-log-port* "common-telemetry-log closure failure")
+;;        )
+;;      (begin
+;;        (define *common:telemetry-log-state* 'closed)
+;;        (udp-close-socket *common:telemetry-log-socket*)
+;;        (set! *common:telemetry-log-socket* #f)))))
+
+(define (process:conservative-read port)
+  (let loop ((res ""))
+    (if (not (eof-object? (peek-char port)))
+	(loop (conc res (read-char port)))
+	res)))
+
+(define (process:cmd-run-with-stderr->list cmd . params)
+  ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params)
+;;  (handle-exceptions
+;;   exn
+;;   (begin
+;;     (print "ERROR:  Failed to run command: " cmd " " (string-intersperse params " "))
+;;     (print "       " ((condition-property-accessor 'exn 'message) exn))
+;;     #f)
+   (let-values (((fh fho pid fhe) (if (null? params)
+				      (process* cmd)
+				      (process* cmd params))))
+       (let loop ((curr (read-line fh))
+		  (result  '()))
+	 (let ((errstr (process:conservative-read fhe)))
+	   (if (not (string=? errstr ""))
+	       (set! result (append result (list errstr)))))
+       (if (not (eof-object? curr))
+	   (loop (read-line fh)
+		 (append result (list curr)))
+	   (begin
+	     (close-input-port fh)
+	     (close-input-port fhe)
+	     (close-output-port fho)
+	     result))))) ;; )
+
+(define (process:cmd-run-with-stderr-and-exitcode->list cmd . params)
+  ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params)
+;;  (handle-exceptions
+;;   exn
+;;   (begin
+;;     (print "ERROR:  Failed to run command: " cmd " " (string-intersperse params " "))
+;;     (print "       " ((condition-property-accessor 'exn 'message) exn))
+;;     #f)
+   (let-values (((fh fho pid fhe) (if (null? params)
+				      (process* cmd)
+				      (process* cmd params))))
+       (let loop ((curr (read-line fh))
+		  (result  '()))
+	 (let ((errstr (process:conservative-read fhe)))
+	   (if (not (string=? errstr ""))
+	       (set! result (append result (list errstr)))))
+       (if (not (eof-object? curr))
+	   (loop (read-line fh)
+		 (append result (list curr)))
+	   (begin
+             (let-values (((anotherpid normalexit? exitstatus)  (process-wait pid)))
+	     (close-input-port fh)
+	     (close-input-port fhe)
+	     (close-output-port fho)
+               (list result (if normalexit? exitstatus -1))))))))
+
+(define (process:cmd-run-proc-each-line cmd proc . params)
+  ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params)
+  (handle-exceptions
+   exn
+   (begin
+     (print "ERROR:  Failed to run command: " cmd " " (string-intersperse params " "))
+     (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+     (debug:print 5 *default-log-port* "exn=" (condition->list exn))
+     #f)
+   (let-values (((fh fho pid) (if (null? params)
+				  (process cmd)
+				  (process cmd params))))
+       (let loop ((curr (read-line fh))
+		(result  '()))
+       (if (not (eof-object? curr))
+	   (loop (read-line fh)
+		 (append result (list (proc curr))))
+	   (begin
+	     (close-input-port fh)
+	     ;;(close-input-port fhe)
+	     (close-output-port fho)
+	     result))))))
+
+(define (process:cmd-run-proc-each-line-alt cmd proc)
+  (let* ((fh (open-input-pipe cmd))
+         (res (port-proc->list fh proc))
+         (status (close-input-pipe fh)))
+    (if (eq? status 0) res #f)))
+
+(define (process:cmd-run->list cmd #!key (delta-env-alist-or-hash-table '()))
+  (common:with-env-vars
+   delta-env-alist-or-hash-table
+   (lambda ()
+     (let* ((fh (open-input-pipe cmd))
+            (res (port->list fh))
+            (status (close-input-pipe fh)))
+       (list res status)))))
+   
+(define (port->list fh)
+  (if (eof-object? fh) #f
+      (let loop ((curr (read-line fh))
+                 (result '()))
+        (if (not (eof-object? curr))
+            (loop (read-line fh)
+                  (append result (list curr)))
+            result))))
+
+(define (port-proc->list fh proc)
+  (if (eof-object? fh) #f
+      (let loop ((curr (proc (read-line fh)))
+                 (result '()))
+        (if (not (eof-object? curr))
+            (loop (let ((l (read-line fh)))
+                    (if (eof-object? l) l (proc l)))
+                  (append result (list curr)))
+            result))))
+
+;;======================================================================
+;; here is an example line where the shell is sh or bash
+;; "find / -print 2&>1 > findall.log"
+(define (run-n-wait cmdline #!key (params #f)(print-cmd #f)(run-dir #f))
+  (if print-cmd 
+      (debug:print 0 *default-log-port* 
+		   (if (string? print-cmd)
+		       print-cmd
+		       "")
+		   (if run-dir (conc "Run in " run-dir ";") "")
+		   cmdline
+		   (if params
+		       (conc " " (string-intersperse params " "))
+		       "")))
+  (if (and run-dir
+	   (directory-exists? run-dir))
+      (push-directory run-dir))
+  (let ((pid (if params
+		 (process-run cmdline params)
+		 (process-run cmdline))))
+    (let loop ((i 0))
+      (let-values (((pid-val exit-status exit-code) (process-wait pid #t)))
+         (if (eq? pid-val 0)
+	     (begin
+	       (thread-sleep! 2)
+	       (loop (+ i 1)))
+	     (begin
+	       (if (and run-dir
+			(directory-exists? run-dir))
+		   (pop-directory))
+	       (values pid-val exit-status exit-code)))))))
+  
+;;======================================================================
+;; MISC PROCESS RELATED STUFF
+;;======================================================================
+
+(define (process:children proc)
+  (with-input-from-pipe
+   (conc "ps h --ppid " (current-process-id) " -o pid")
+   (lambda ()
+     (let loop ((inl (read-line))
+		(res '()))
+       (if (eof-object? inl)
+	   (reverse res)
+	   (let ((pid (string->number inl)))
+	     (if proc (proc pid))
+	     (loop (read-line) (cons pid res))))))))
+
+(define (process:alive? pid)
+  (handle-exceptions
+   exn
+   ;; possibly pid is a process not a child, look in /proc to see if it is running still
+   (common:file-exists? (conc "/proc/" pid))
+   (let-values (((rpid exit-type exit-signal)(process-wait pid #t)))
+       (and (number? rpid)
+	    (equal? rpid pid)))))
+
+(define (process:alive-on-host? host pid)
+  (let ((cmd (conc "ssh " host " ps -o pid= -p " pid)))
+    (handle-exceptions
+	exn
+      (begin
+	(debug:print 0 *default-log-port* "failed to identify if process " pid ", on host " host " is alive. exn=" exn)
+	#f) ;; anything goes wrong - assume the process in NOT running.
+     (with-input-from-pipe 
+      cmd
+      (lambda ()
+	(let loop ((inl (read-line)))
+	  (if (eof-object? inl)
+	      #f
+	      (let* ((clean-str (string-substitute "^[^\\d]*([0-9]+)[^\\d]*$" "\\1" inl))
+		     (innum     (string->number clean-str)))
+		(and innum
+		     (eq? pid innum))))))))))
+
+(define (process:get-sub-pids pid)
+  (with-input-from-pipe
+   (conc "pstree -A -p " pid) ;; | tr 'a-z\\-+`()\\.' ' ' " pid)
+   (lambda ()
+     (let loop ((inl (read-line))
+		(res '()))
+       (if (eof-object? inl)
+	   (reverse res)
+	   (let ((nums (map string->number
+			    (string-split-fields "\\d+" inl))))
+	     (loop (read-line)
+		   (append res nums))))))))
+
+;;======================================================================
+;; stuff from tests.scm
+;;======================================================================
+
+;;======================================================================
+;; given a list of itemmaps (testname . map), return the first match
+;;
+(define (tests:lookup-itemmap itemmaps testname)
+  (let ((best-matches (filter (lambda (itemmap)
+				(tests:match (car itemmap) testname #f))
+			      itemmaps)))
+    (if (null? best-matches)
+	#f
+	(let ((res (car best-matches)))
+	  ;; (debug:print 0 *default-log-port* "res=" res)
+	  (cond
+	   ((string? res) res) ;;; FIX THE ROOT CAUSE HERE ....
+	   ((null? res)   #f)
+	   ((string? (cdr res)) (cdr res))  ;; it is a pair
+	   ((string? (cadr res))(cadr res)) ;; it is a list
+	   (else cadr res))))))
+
+;;======================================================================
+;; stuff from tasks.scm
+;;======================================================================
+
+;;======================================================================
+;; no elegance here ...
+;;
+(define (tasks:kill-server hostname pid #!key (kill-switch ""))
+  (debug:print-info 0 *default-log-port* "Attempting to kill server process " pid " on host " hostname)
+  (setenv "TARGETHOST" hostname)
+  (let* ((logdir (if (directory-exists? "logs")
+                    "logs/"
+                    ""))
+         (logfile (if logdir (conc "logs/server-"pid"-"hostname".log") #f))
+         (gzfile  (if logfile (conc logfile ".gz"))))
+    (setenv "TARGETHOST_LOGF" (conc logdir "server-kills.log"))
+
+    (system (conc "nbfake kill "kill-switch" "pid))
+
+    (when logfile
+      (thread-sleep! 0.5)
+      (if (common:file-exists? gzfile) (delete-file gzfile))
+      (system (conc "gzip " logfile))
+      
+      (unsetenv "TARGETHOST_LOGF")
+      (unsetenv "TARGETHOST"))))
+    
+
+;;======================================================================the end
 )

Index: configf.scm
==================================================================
--- configf.scm
+++ configf.scm
@@ -24,11 +24,16 @@
 
 (use regex regex-case matchable) ;;  directory-utils)
 (declare (unit configf))
 (declare (uses process))
 (declare (uses env))
-(declare (uses keys))
+
+(declare (uses commonmod))
+(import commonmod)
+
+(declare (uses configfmod))
+(import configfmod)
 
 (include "common_records.scm")
 
 ;; return list (path fullpath configname)
 (define (find-config configname #!key (toppath #f))
@@ -46,22 +51,10 @@
 		(let ((remcwd (take dir (- (length dir) 1))))
 		  (if (null? remcwd)
 		      (list #f #f #f) ;;  #f #f) 
 		  (loop remcwd)))))))))
 
-(define (configf:assoc-safe-add alist key val #!key (metadata #f))
-  (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist)))
-    (append newalist (list (if metadata
-			       (list key val metadata)
-			       (list key val))))))
-
-(define (configf:section-var-set! cfgdat section-name var value #!key (metadata #f))
-  (hash-table-set! cfgdat section-name
-		   (configf:assoc-safe-add
-		    (hash-table-ref/default cfgdat section-name '())
-		    var value metadata: metadata)))
-
 (define (configf:eval-string-in-environment str)
   ;; (if (or (string-null? str)
   ;;	  (equal? "!" (substring str 0 1))) ;; null string or starts with ! are preserved but NOT set in the environment
       str
       (handle-exceptions
@@ -119,11 +112,11 @@
 						    "       (conc (or *toppath* (get-environment-variable \"MT_RUN_AREA_HOME\"))"
 						    "             (if (string-null? extra) \"\" \"/\")"
 						    "             extra)))"))
 				((get g)   
 				 (match (string-split cmd)
-					((sect var)(conc "(lambda (ht)(configf:lookup ht \"" sect "\" \"" var "\"))"))
+					((sect var)(conc "(lambda (ht)(configfmod#configf:lookup ht \"" sect "\" \"" var "\"))"))
 					(else
 					 (debug:print-error 0 *default-log-port* "#{get ...} used with only one parameter, \"" cmd "\", two needed.")
 					 "(lambda (ht) #f)")))
 				((runconfigs-get rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
 				;; ((rget)           (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
@@ -503,65 +496,84 @@
     (let ((configdat  (if configfile 
 			  (read-config configfile #f #t environ-patt: environ-patt post-section-procs: (list (cons "^fields$" set-fields)) #f))))
       (if toppath (change-directory curr-dir))
       (list configdat toppath configfile fname))))
 
-(define (configf:lookup cfgdat section var)
-  (if (hash-table? cfgdat)
-      (let ((sectdat (hash-table-ref/default cfgdat section '())))
-	(if (null? sectdat)
-	    #f
-	    (let ((match (assoc var sectdat)))
-	      (if match ;; (and match (list? match)(> (length match) 1))
-		  (cadr match)
-		  #f))
-	    ))
-      #f))
-
-;; use to have definitive setting:
-;;  [foo]
-;;  var yes
-;;
-;;  (configf:var-is? cfgdat "foo" "var" "yes") => #t
-;;
-(define (configf:var-is? cfgdat section var expected-val)
-  (equal? (configf:lookup cfgdat section var) expected-val))
-
-;; redefines
-(define config-lookup configf:lookup)
+;;======================================================================
+;; lookup and manipulation routines
+;;======================================================================
+
+;; (define (configf:assoc-safe-add alist key val #!key (metadata #f))
+;;   (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist)))
+;;     (append newalist (list (if metadata
+;; 			       (list key val metadata)
+;; 			       (list key val))))))
+;; 
+;; (define (configf:section-var-set! cfgdat section-name var value #!key (metadata #f))
+;;   (hash-table-set! cfgdat section-name
+;; 		   (configf:assoc-safe-add
+;; 		    (hash-table-ref/default cfgdat section-name '())
+;; 		    var value metadata: metadata)))
+;; 
+;; (define (configf:lookup cfgdat section var)
+;;   (if (hash-table? cfgdat)
+;;       (let ((sectdat (hash-table-ref/default cfgdat section '())))
+;; 	(if (null? sectdat)
+;; 	    #f
+;; 	    (let ((match (assoc var sectdat)))
+;; 	      (if match ;; (and match (list? match)(> (length match) 1))
+;; 		  (cadr match)
+;; 		  #f))
+;; 	    ))
+;;       #f))
+;; 
+;; ;; use to have definitive setting:
+;; ;;  [foo]
+;; ;;  var yes
+;; ;;
+;; ;;  (configf:var-is? cfgdat "foo" "var" "yes") => #t
+;; ;;
+;; (define (configf:var-is? cfgdat section var expected-val)
+;;   (equal? (configf:lookup cfgdat section var) expected-val))
+;; 
+;; (define config-lookup configf:lookup)
 (define configf:read-file read-config)
 
-;; safely look up a value that is expected to be a number, return
-;; a default (#f unless provided)
-;;
-(define (configf:lookup-number cfdat section varname #!key (default #f))
-  (let* ((val (configf:lookup *configdat* section varname))
-         (res (if val
-                  (string->number (string-substitute "\\s+" "" val #t))
-                  #f)))
-    (cond
-     (res  res)
-     (val  (debug:print 0 *default-log-port* "ERROR: no number found for [" section "], " varname ", got: " val))
-     (else default))))
-
-(define (configf:section-vars cfgdat section)
-  (let ((sectdat (hash-table-ref/default cfgdat section '())))
-    (if (null? sectdat)
-	'()
-	(map car sectdat))))
-
-(define (configf:get-section cfgdat section)
-  (hash-table-ref/default cfgdat section '()))
-
-(define (configf:set-section-var cfgdat section var val)
-  (let ((sectdat (configf:get-section cfgdat section)))
-    (hash-table-set! cfgdat section
-                     (configf:assoc-safe-add sectdat var val))))
-
+;; ;; safely look up a value that is expected to be a number, return
+;; ;; a default (#f unless provided)
+;; ;;
+;; (define (configf:lookup-number cfdat section varname #!key (default #f))
+;;   (let* ((val (configf:lookup *configdat* section varname))
+;;          (res (if val
+;;                   (string->number (string-substitute "\\s+" "" val #t))
+;;                   #f)))
+;;     (cond
+;;      (res  res)
+;;      (val  (debug:print 0 *default-log-port* "ERROR: no number found for [" section "], " varname ", got: " val))
+;;      (else default))))
+;; 
+;; (define (configf:section-vars cfgdat section)
+;;   (let ((sectdat (hash-table-ref/default cfgdat section '())))
+;;     (if (null? sectdat)
+;; 	'()
+;; 	(map car sectdat))))
+;; 
+;; (define (configf:get-section cfgdat section)
+;;   (hash-table-ref/default cfgdat section '()))
+;; 
+;; (define (configf:set-section-var cfgdat section var val)
+;;   (let ((sectdat (configf:get-section cfgdat section)))
+;;     (hash-table-set! cfgdat section
+;;                      (configf:assoc-safe-add sectdat var val))))
+;; 
+;;     ;;(append (filter (lambda (x)(not (assoc var sectdat))) sectdat)
+;;     ;;	    (list var val))))
+;; 
+;;======================================================================
+;; setup
 ;;======================================================================
-;;(append (filter (lambda (x)(not (assoc var sectdat))) sectdat)
-;;	    (list var val))))
+;;======================================================================
 
 (define (setup)
   (let* ((configf (find-config "megatest.config"))
 	 (config  (if configf (read-config configf #f #t) #f)))
     (if config

ADDED   configfmod.scm
Index: configfmod.scm
==================================================================
--- /dev/null
+++ configfmod.scm
@@ -0,0 +1,173 @@
+;;======================================================================
+;; Copyright 2017, Matthew Welland.
+;; 
+;; This file is part of Megatest.
+;; 
+;;     Megatest is free software: you can redistribute it and/or modify
+;;     it under the terms of the GNU General Public License as published by
+;;     the Free Software Foundation, either version 3 of the License, or
+;;     (at your option) any later version.
+;; 
+;;     Megatest is distributed in the hope that it will be useful,
+;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;     GNU General Public License for more details.
+;; 
+;;     You should have received a copy of the GNU General Public License
+;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
+
+;;======================================================================
+
+(declare (unit configfmod))
+(declare (uses commonmod))
+
+(module configfmod
+	*
+	
+(import scheme chicken data-structures extras files ports)
+(use
+ (prefix base64 base64:)
+ (prefix dbi dbi:)
+ (prefix sqlite3 sqlite3:)
+ (srfi 18)
+ format
+ matchable
+ md5
+ message-digest
+ pkts
+ posix
+ regex
+ regex-case
+ sparse-vectors
+ srfi-1
+ srfi-13
+ srfi-69
+ stack
+ typed-records
+ directory-utils
+ z3
+ )
+
+(import commonmod)
+
+;;======================================================================
+;; move debug stuff to separate module then put these back where they belong
+;;======================================================================
+
+(define (common:get-testsuite-name)
+  (or (configf:lookup *configdat* "setup" "area-name") ;; megatest is a flexible tool, testsuite is too limiting a description.
+      (configf:lookup *configdat* "setup" "testsuite" )
+      (getenv "MT_TESTSUITE_NAME")
+      (pathname-file (or (if (string? *toppath* )
+			     (pathname-file *toppath*)
+			     #f)
+			 (common:get-toppath #f)))
+      "please-set-setup-area-name")) ;; (pathname-file (current-directory)))))
+
+(define (get-area-name configdat toppath #!optional (short #f))
+  ;; look up my area name in areas table (future)
+  ;; generate auto name
+  (conc (get-area-path-signature toppath short)
+	"-"
+	(common:get-testsuite-name toppath configdat)))
+
+(define (common:get-db-tmp-area . junk)
+  (if *db-cache-path*
+      *db-cache-path*
+      (if *toppath* ;; common:get-create-writeable-dir
+	  (handle-exceptions
+	      exn
+	      (begin
+		(debug:print-error 0 *default-log-port* "Couldn't create path to " *db-cache-path* ", exn=" exn)
+		(exit 1))
+	      (let* ((tsname (common:get-testsuite-name))
+		     (dbpath (common:get-create-writeable-dir
+			      (list (conc "/tmp/" (current-user-name)
+					  "/megatest_localdb/"
+					  tsname "/"
+					  (string-translate *toppath* "/" "."))
+				    (conc "/tmp/" (current-process-id) ;; just in case we have an issue with the dir by own user name
+					  "/megatest_localdb/"
+					  tsname
+					  (string-translate *toppath* "/" "."))
+				    ))))
+		(set! *db-cache-path* dbpath)
+		dbpath))
+	  #f)))
+
+(define (common:get-sync-lock-filepath)
+  (let* ((tmp-area     (common:get-db-tmp-area))
+         (lockfile     (conc tmp-area "/megatest.db.sync-lock")))
+    lockfile))
+    
+
+;;======================================================================
+;; lookup routines - replicated from configf
+;;======================================================================
+
+(define (configf:assoc-safe-add alist key val #!key (metadata #f))
+  (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist)))
+    (append newalist (list (if metadata
+			       (list key val metadata)
+			       (list key val))))))
+
+(define (configf:section-var-set! cfgdat section-name var value #!key (metadata #f))
+  (hash-table-set! cfgdat section-name
+		   (configf:assoc-safe-add
+		    (hash-table-ref/default cfgdat section-name '())
+		    var value metadata: metadata)))
+
+(define (configf:lookup cfgdat section var)
+  (if (hash-table? cfgdat)
+      (let ((sectdat (hash-table-ref/default cfgdat section '())))
+	(if (null? sectdat)
+	    #f
+	    (let ((match (assoc var sectdat)))
+	      (if match ;; (and match (list? match)(> (length match) 1))
+		  (cadr match)
+		  #f))
+	    ))
+      #f))
+
+;; use to have definitive setting:
+;;  [foo]
+;;  var yes
+;;
+;;  (configf:var-is? cfgdat "foo" "var" "yes") => #t
+;;
+(define (configf:var-is? cfgdat section var expected-val)
+  (equal? (configf:lookup cfgdat section var) expected-val))
+
+;; redefines
+(define config-lookup configf:lookup)
+
+;; safely look up a value that is expected to be a number, return
+;; a default (#f unless provided)
+;;
+(define (configf:lookup-number cfdat section varname #!key (default #f))
+  (let* ((val (configf:lookup *configdat* section varname))
+         (res (if val
+                  (string->number (string-substitute "\\s+" "" val #t))
+                  #f)))
+    (cond
+     (res  res)
+     (val  (debug:print 0 *default-log-port* "ERROR: no number found for [" section "], " varname ", got: " val))
+     (else default))))
+
+(define (configf:section-vars cfgdat section)
+  (let ((sectdat (hash-table-ref/default cfgdat section '())))
+    (if (null? sectdat)
+	'()
+	(map car sectdat))))
+
+(define (configf:get-section cfgdat section)
+  (hash-table-ref/default cfgdat section '()))
+
+(define (configf:set-section-var cfgdat section var val)
+  (let ((sectdat (configf:get-section cfgdat section)))
+    (hash-table-set! cfgdat section
+                     (configf:assoc-safe-add sectdat var val))))
+
+;;======================================================================the end
+
+)

Index: dashboard-context-menu.scm
==================================================================
--- dashboard-context-menu.scm
+++ dashboard-context-menu.scm
@@ -39,10 +39,19 @@
 (declare (uses rmt))
 (declare (uses ezsteps))
 ;; (declare (uses sdb))
 ;; (declare (uses filedb))
 (declare (uses subrun))
+
+(declare (uses commonmod))
+(import commonmod)
+
+(declare (uses configfmod))
+(import configfmod)
+
+(declare (uses dbmod))
+(import dbmod)
 
 (include "common_records.scm")
 (include "db_records.scm")
 (include "run_records.scm")
 

Index: dashboard-guimonitor.scm
==================================================================
--- dashboard-guimonitor.scm
+++ dashboard-guimonitor.scm
@@ -31,13 +31,18 @@
 (use sqlite3 srfi-1 posix regex regex-case srfi-69)
 (import (prefix sqlite3 sqlite3:))
 
 (declare (unit dashboard-guimonitor))
 (declare (uses common))
-(declare (uses keys))
 (declare (uses db))
 (declare (uses tasks))
+
+(declare (uses commonmod))
+(import commonmod)
+
+(declare (uses dbmod))
+(import dbmod)
 
 (include "common_records.scm")
 (include "db_records.scm")
 (include "run_records.scm")
 (include "task_records.scm")

ADDED   dashboard-new-runs-view.scm
Index: dashboard-new-runs-view.scm
==================================================================
--- /dev/null
+++ dashboard-new-runs-view.scm
@@ -0,0 +1,364 @@
+;;======================================================================
+;; Extracting the data to display for runs
+;;
+;; This needs to be re-entrant such that it does one column per call
+;; on the zeroeth call update runs data
+;; on each subsequent call update one run (configurable - could do two, three ... or update until tdelta exceeded
+;; on last run reset to zeroeth
+;;
+;;   1. select with run filters; area, target, runname, runstate, runstatus, starttime, duration
+;;       - put this information into two data structures:
+;;         a. hash of area/target/runname => runstruct #< ordernun, id, area, target, runname, state,
+;;                                                        status, starttime, duration, non-deleted testcount>
+;;            ordernum reflects order as received from sql query
+;;         b. sparsevec of id => runstruct
+;;   2. for each run in runshash ordered by ordernum do:
+;;         retrieve data since last update for that run
+;;         if there is a deleted test - retrieve full data
+;;         if there are non-deleted tests register this run in the columns sparsevec
+;;         if this is the zeroeth column regenerate the rows sparsevec
+;;         if this column is in the visible zone update visible cells
+;;
+;; Other factors:
+;;   1. left index handling:
+;;       - add test/itempaths to left index as discovered, re-order and
+;;         update row -> test/itempath mapping on each read run
+;;======================================================================
+
+;; runs is <vec header runs>
+;;   get ALL runs info
+;;   update rdat-targ-run-id
+;;   update rdat-runs
+;;
+(define (dashboard:update-runs-data rdat)
+  (let* ((tb               (dboard:rdat-runs-tree rdat))
+	 (targ-sql-filt    (dboard:rdat-targ-sql-filt    rdat))
+	 (runname-sql-filt (dboard:rdat-runname-sql-filt rdat))
+	 (state-sql-filt   (dboard:rdat-run-state-sql-filt   rdat))
+	 (status-sql-filt  (dboard:rdat-run-status-sql-filt  rdat))
+	 ;; Use (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
+	 (data             (rmt:simple-get-runs runname-sql-filt #f #f targ-sql-filt #f))
+	 (numruns          (length data)))
+    ;; store in the runsbynum vector
+    (dboard:rdat-runsbynum-set! rdat (list->vector data))
+    ;; update runs       id              => runrec
+    ;; update targ-runid target/runname  => run-id
+    (for-each
+     (lambda (runrec)
+       (let* ((run-id (simple-run-id runrec))
+	      (full-targ-runname (conc (simple-run-target runrec) "/"
+				       (simple-run-runname runrec))))
+	 ;; (debug:print 0 *default-log-port* "Update run  " run-id)
+	 (sparse-vector-set! (dboard:rdat-runs rdat) run-id runrec)
+	 (hash-table-set! (dboard:rdat-targ-runid rdat) full-targ-runname run-id)
+	 (tree:add-node tb "Runs" (string-split full-targ-runname "/"))
+	 ))
+     data)
+    numruns))
+
+;;======================================================================
+;; The "new" runs browser, this one sets up the view and registers the
+;; updater
+;;
+(define (dashboard:runs-browse commondat tabdat #!key (tab-num 5))
+  (let* ((rdat     (make-dboard:rdat))
+	 (runsmtx  (dboard:runs-new-matrix commondat rdat))
+	 (itemsmtx (dboard:runs-new-matrix commondat rdat)))
+    (dboard:rdat-runs-mtx-set! rdat runsmtx)
+    (dboard:rdat-items-mtx-set! rdat itemsmtx)
+    (dboard:commondat-add-updater
+     commondat
+     (lambda ()
+       (dashboard:new-runs-updater commondat tabdat rdat))
+     tab-num: tab-num)
+    (iup:split
+     #:orientation "VERTICAL"
+     #:value 100
+     #:shrink "YES"
+     (iup:vbox
+      (dboard:runs-tree-new-view-browser commondat rdat))
+     (iup:split
+      #:orientation "VERTICAL"
+      #:value 100
+      (iup:vbox runsmtx)
+      (iup:vbox
+       (iup:split
+	#:orientation "VERTICAL"
+	#:value 500
+	itemsmtx
+	(dboard:test-info-matrix commondat rdat)
+	))))))
+
+(define (dashboard:new-runs-updater commondat tabdat rdat)
+  (let* ((runnum           (dboard:rdat-runnum          rdat))
+	 (start-time       (current-milliseconds))
+	 (tot-runs         #f))
+    (if (eq? runnum 0)(dashboard:update-runs-data rdat))
+    (set! tot-runs (vector-length (dboard:rdat-runsbynum rdat)))
+    (let loop ((rn   runnum))
+      (if (and (< (- (current-milliseconds) start-time) 250)
+	       (< rn tot-runs))
+	  (let* ((newrn (if (>= runnum (vector-length (dboard:rdat-runsbynum rdat)))
+			    0 ;; start over
+			    (+ rn 1)))) ;; (+ runnum 1)))
+	    (dashboard:update-run-data rn rdat)
+	    (dboard:rdat-runnum-set! rdat newrn)
+	    (if (> newrn 0)
+		(loop newrn)))))
+    (if (>=  (dboard:rdat-runnum rdat) tot-runs)
+	(dboard:rdat-runnum-set! rdat 0))
+    ;; (dboard:rdat-runnum-set! rdat rn))) ;; not needed as it is set above
+    ;; (dboard:rdat-last-update-set! rdat (- (current-seconds) 10))
+    (dashboard:update-new-runs-view-runs-matrix commondat rdat)
+    '()))
+
+;; NOTE: runnum is NOT the run-id, it is a pointer into the runsbynum vector
+;;
+(define (dashboard:update-run-data runnum rdat)
+  (let* ((curr-time            (current-seconds))
+	 (runrec               (vector-ref (dboard:rdat-runsbynum rdat) runnum))
+	 (run-id               (simple-run-id runrec))
+	 (last-update          (sparse-vector-ref (dboard:rdat-last-updates rdat) run-id))
+	 ;; filters
+	 (testname-sql-filt    (dboard:rdat-testname-sql-filt    rdat))
+	 ;; (itempath-sql-filt    (dboard:rdat-itempath-sql-filt    rdat))
+	 (test-state-sql-filt  (dboard:rdat-test-state-sql-filt  rdat))  ;; not used yet
+	 (test-status-sql-filt (dboard:rdat-test-status-sql-filt rdat))  ;; not used yet
+	 (tests                (rmt:get-tests-for-run-state-status run-id
+						      testname-sql-filt
+						      last-update                ;; last-update
+						      )))
+    ;; (debug:print 0 *default-log-port* "tests: " tests)
+    (sparse-vector-set! (dboard:rdat-last-updates rdat) run-id (- curr-time 1))
+    (sparse-vector-set! (dboard:rdat-run-tests rdat) run-id
+			(delete-duplicates
+			 (append tests (sparse-vector-ref (dboard:rdat-run-tests rdat) run-id))
+			 (lambda (a b)
+			   (eq? (vector-ref a 0)(vector-ref b 0))))) ;; de-duplicate based on test id
+    #;(debug:print 0 *default-log-port* "Got " (length tests) " tests for run-id "
+		 run-id " testname-sql-filt " testname-sql-filt " and last-update " last-update
+		 " first test info: " tests) ;; (if (not (null? tests))(car tests) '()))
+    (length tests)))
+
+;; NB// start at 1.
+;;
+(define (dashboard:get-row-num mtrx rownames tname)
+  (or (hash-table-ref/default rownames tname #f)
+      (let* ((numentries (hash-table-size rownames))
+	     (nextnum    (+ numentries 1)))
+	(hash-table-set! rownames tname nextnum)
+	(iup:attribute-set! mtrx (conc nextnum ":0") tname)
+	nextnum)))
+
+(define (dashboard:update-new-runs-view-runs-matrix commondat rdat)
+  (let* ((run-tests-data (dboard:rdat-run-tests rdat)) ;; from dbmod.scm (define-record simple-run target id runname state status owner event_time)
+	 (run-tests-mtx  (dboard:rdat-runs-mtx  rdat))
+	 (runs-by-num    (dboard:rdat-runsbynum rdat)) ;; this is the sequence num
+	 (num-runs       (vector-length runs-by-num))
+	 )
+    (debug:print 0 *default-log-port* "num-runs: " num-runs)
+    (let loop ((col-num 1))
+      (let* ((runrec    (vector-ref runs-by-num (- col-num 1)))
+	     (run-id    (simple-run-id runrec))
+	     (target    (simple-run-target runrec))
+	     (runname   (simple-run-runname runrec))
+	     (vert-targ (string-translate (conc target "/" runname) "/" "\n"))
+	     (run-tests (sparse-vector-ref run-tests-data run-id))
+	     (changed   #f))  ;; manage redraws on a column by column basis
+	(debug:print 0 *default-log-port* "run-tests: " run-tests)
+	(if (null? run-tests) ;; empty run
+	    (if (< col-num num-runs) ;; NOT CORRECT
+		(loop (+ col-num)))
+	    (begin
+	      (set! changed (dcommon:modifiy-if-different ;; set the col header
+			     run-tests-mtx
+			     (conc "0:" col-num)
+			     vert-targ
+			     changed))
+	      (let testloop ((inum    0)
+			     (tail    run-tests))
+		(let* ((test-dat   (car tail))
+		       (tname      (db:test-get-testname test-dat))
+		       (state      (db:test-get-state    test-dat))
+		       (status     (db:test-get-status   test-dat))
+		       (item-path  (db:test-get-item-path test-dat))
+		       (color      (gutils:get-color-for-state-status state status))
+		       (is-deleted (equal? state "DELETED"))
+		       (row-num    (if is-deleted
+				       #f
+				       (dashboard:get-row-num run-tests-mtx
+							      (dboard:rdat-rownames rdat) tname)))
+		       (cell-name (conc row-num ":" col-num)))
+		  (if (or (not is-deleted)
+			  (equal? item-path ""))
+		      (begin
+ 			(set! changed (dcommon:modifiy-if-different 
+ 				       run-tests-mtx
+ 				       (conc "BGCOLOR" row-num ":" col-num)
+ 				       (car color)
+ 				       changed))
+			(set! changed (dcommon:modifiy-if-different 
+ 				       run-tests-mtx
+ 				       cell-name
+ 				       (cadr color)
+ 				       changed))))
+		  (if (not (null? (cdr tail)))
+		      (testloop (+ inum 1)(cdr tail))
+		      (begin
+			(iup:attribute-set! run-tests-mtx (conc "C" col-num) "REDRAW")
+			(if (< col-num num-runs)
+			    (loop (+ col-num 1)))))))))))))
+
+(define (dboard:runs-new-matrix commondat rdat)
+  (iup:matrix
+   #:alignment1 "ALEFT"
+   #:expand "YES" ;; "HORIZONTAL"
+   #:scrollbar "YES"
+   #:numcol 100
+   #:numlin 200
+   #:numcol-visible 3 ;; (min 8)
+   #:numlin-visible 10
+   #:widthdef 20
+   #:click-cb
+   (lambda (obj row col status)
+     (let* ((cell (conc row ":" col)))
+       #f))
+   ))
+
+;; run info, test info
+(define (dboard:test-info-matrix commondat rdat)
+  (let* ((run-fields
+	  '(("Run Info"  . 1)
+	    ("Fields"    . 2)
+	    ("Target"    . 3)
+	    ("Runname"   . 4)
+	    ("Run-id"    . 5)
+	    ("Run-date"  . 6)))
+	 (test-fields
+	  '(("Test Info" . 1)
+	    ("Testname"  . 2)
+	    ("Item path" . 3)
+	    ("State"     . 4)
+	    ("Status"    . 5)
+	    ("Comment"   . 6)
+	    ("Test-id"   . 7)
+	    ("Test-date" . 8)))
+	 (test-meta-fields
+	  '(("Test Meta Data" . 1)
+	    ("Author"    . 2)
+	    ("Owner"     . 3)
+	    ("Reviewed"  . 4)
+	    ("Tags"      . 5)
+	    ("Description" . 6)))
+	 (remhost-run-info-fields
+	  '(("Host/run info" . 1)
+	    ("Hostname"  . 2)
+	    ("Disk free" . 3)
+	    ("CPU Load"  . 4)
+	    ("Run duration" . 5)
+	    ("Logfile"   . 6)
+	    ("Process ID" . 7)
+	    ("Machine info" . 8)))
+	 (mk-matrix (lambda (cfgdat)
+		      (let ((mtx (iup:matrix
+				  #:alignment1 "ALEFT"
+				  ;; #:expand "YES" ;; "HORIZONTAL"
+				  #:scrollbar "YES"
+				  #:numcol 1
+				  #:numlin (length cfgdat)
+				  #:numcol-visible 1 ;; (min 8)
+				  #:numlin-visible (length cfgdat)
+				  #:widthdef 50
+				  #:width0 50
+				  #:click-cb
+				  (lambda (obj row col status)
+				    (let* ((cell (conc row ":" col)))
+				      #f)))))
+			(for-each (lambda (finfo)
+				    (match finfo
+				      ((fieldname . rownum)
+				       (iup:attribute-set! mtx (conc rownum":0") fieldname))
+				      (else (debug:print 0 *default-log-port* "ERROR: bad finfo "finfo))))
+				  cfgdat)
+			mtx)))
+	 (runmtx  (mk-matrix run-fields))
+	 (testmtx (mk-matrix test-fields))
+	 (metamtx (mk-matrix test-meta-fields))
+	 (remhostmtx (mk-matrix remhost-run-info-fields)))
+    ;; (dboard:rdat-runs-mtx-set! rdat runmtx)
+    ;; (dboard:rdat-items-mtx-set! rdat testmtx)
+    ;; (
+    (iup:vbox
+     #:expandchildren #t
+     #:expand #f
+     runmtx testmtx
+     metamtx remhostmtx
+     )))
+
+;; browse runs as a tree. Used in both "Runs" tab and
+;; in the runs control panel.
+;;
+;;  THIS IS THE NEW ONE
+;;
+(define (dboard:runs-tree-new-view-browser commondat rdat)
+  (let* ((txtbox (iup:textbox
+		  #:action (lambda (val a b)
+			     (debug:catch-and-dump
+			      (lambda ()
+				;; for the Runs view we put the list
+				;; of keyvals into tabdat target for
+				;; the Run Controls we put then update
+				;; the run-command
+				(if b (dboard:rdat-targ-sql-filt-set! rdat
+								 (string-split b "/")))
+				#;(dashboard:update-run-command tabdat))
+			      "command-testname-selector tb action"))
+		  ;; #:value (dboard:test-patt->lines  ;; This seems like it was wrong, BUG in code where it was copied from?
+	          ;;		   (dboard:tabdat-test-patts-use tabdat))
+		  #:expand "HORIZONTAL"
+		  ;; #:size "10x"
+		  ))
+	 (tb
+          (iup:treebox
+           #:value 0
+           #:title "Runs"     ;;  was #:name -- iup 3.19 changed
+			      ;;  this... "Changed: [DEPRECATED
+			      ;;  REMOVED] removed the old attribute
+			      ;;  NAMEid from IupTree to avoid
+			      ;;  conflict with the common attribute
+			      ;;  NAME. Use the TITLEid attribute."
+           #:expand "YES"
+           #:addexpanded "YES"
+           #:size "120x"
+           #:selection-cb
+           (lambda (obj id state)
+             (debug:catch-and-dump
+              (lambda ()
+                (let* ((run-path (tree:node->path obj id))
+                       (run-id    (new-tree-path->run-id rdat (cdr run-path))))
+                  ;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ??
+                  ;; done below when run-id is a number
+                  (dboard:rdat-targ-sql-filt-set! rdat (cdr run-path)) ;; (print
+								    ;; "run-path:
+								    ;; "
+								    ;; run-path)
+		  (iup:attribute-set! txtbox "VALUE"
+				      (string-intersperse (cdr run-path) "/"))
+		  #;(dashboard:update-run-command tabdat)
+                  #;(dboard:tabdat-layout-update-ok-set! tabdat #f)
+                  (if (number? run-id)
+                      (begin
+                        ;; capture last two in tabdat.
+                        (dboard:rdat-push-run-id rdat run-id)
+			(dboard:rdat-view-changed-set! rdat #t))
+                      (debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id))))
+              "treebox"))
+           ;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
+           )))
+    (dboard:rdat-runs-tree-set! rdat tb)
+    (iup:detachbox
+     (iup:vbox 
+      txtbox
+      tb
+      ))))
+

Index: dashboard-tests.scm
==================================================================
--- dashboard-tests.scm
+++ dashboard-tests.scm
@@ -38,10 +38,19 @@
 (declare (uses rmt))
 (declare (uses ezsteps))
 ;; (declare (uses sdb))
 ;; (declare (uses filedb))
 (declare (uses subrun))
+
+(declare (uses commonmod))
+(import commonmod)
+
+(declare (uses configfmod))
+(import configfmod)
+
+(declare (uses dbmod))
+(import dbmod)
 
 (include "common_records.scm")
 (include "db_records.scm")
 (include "run_records.scm")
 
@@ -261,18 +270,33 @@
 ;; if there is a submegatest create a button to launch dashboard in that area
 ;;
 (define (submegatest-panel dbstruct keydat testdat runname testconfig)
   (let* ((test-run-dir      (db:test-get-rundir testdat))
 	 (subarea           (subrun:get-runarea test-run-dir))
-	 (area-exists       (and subarea (common:file-exists? subarea silent: #t))))
-    (if subarea
+	 (area-exists       (and subarea (common:file-exists? subarea silent: #t)))
+	 (target            #f)
+	 (runname           #f)
+	 (cmd-parts-file (conc test-run-dir "/subrun-command-parts.sexp")))
+    (if (file-exists? cmd-parts-file) ;; existance of this file is sufficient to *try* opening a dashboard
+	(let* ((cmd-parts      (if (file-exists? cmd-parts-file)
+				   (with-input-from-file cmd-parts-file
+				     read)
+				   '()))
+	       (target         (alist-ref "-target" cmd-parts equal?))
+	       (runname        (alist-ref "-runname" cmd-parts equal?))
+	       (run-area       (alist-ref "-startdir" cmd-parts equal?)))
 	(iup:frame 
 	 #:title "Megatest Run Info" ; #:expand "YES"
+	   (iup:vbox
 	 (iup:button
 	  "Launch Dashboard"
 	  #:action (lambda (obj)
-                     (subrun:launch-dashboard test-run-dir))))
+			(subrun:launch-dashboard test-run-dir)))
+	    (iup:button
+	     "Launch Dashboard+Filter"
+	     #:action (lambda (obj)
+			(subrun:launch-dashboard test-run-dir target: target runname: runname))))))
 	(iup:vbox))))
 
 ;; use a global for setting the buttons colors
 ;;                           state status teststeps
 (define *state-status* (vector #f #f #f))

Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -24,16 +24,17 @@
 (import (prefix iup iup:))
 
 (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
+(use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors
+     matchable) ;; defstruct
 (import (prefix sqlite3 sqlite3:))
+
 
 (declare (uses common))
 (declare (uses margs))
-(declare (uses keys))
 (declare (uses items))
 (declare (uses db))
 (declare (uses configf))
 (declare (uses process))
 (declare (uses launch))
@@ -45,19 +46,47 @@
 (declare (uses dashboard-context-menu))
 (declare (uses vg))
 (declare (uses subrun))
 ;; (declare (uses dashboard-main))
 (declare (uses mt))
+
+(declare (uses commonmod))
+(import commonmod)
+(declare (uses commonmod.import))
+
+(declare (uses configfmod))
+(import configfmod)
+(declare (uses configfmod.import))
+
+(declare (uses dcommonmod))
+(import dcommonmod)
+(declare (uses dcommonmod.import))
+
+(declare (uses apimod))
+(import apimod)
+
+;; (declare (uses ods))
+;; (import ods)
+;; 
+(declare (uses dbmod))
+(import dbmod)
+;; (declare (uses dbmod.import))
+
+(declare (uses servermod))
+(import servermod)
 
 (include "common_records.scm")
 (include "db_records.scm")
 (include "run_records.scm")
 (include "task_records.scm")
 (include "megatest-version.scm")
-(include "megatest-fossil-hash.scm")
+;; (include "megatest-fossil-hash.scm")
 (include "vg_records.scm")
 
+;; This is the new runs view
+(include "dashboard-new-runs-view.scm")
+
 (define help (conc 
 	      "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
   version " megatest-version "
   license GPL, Copyright (C) Matt Welland 2012-2017
 
@@ -167,33 +196,13 @@
 ;;     (begin
 ;;       (debug:print-info 0 *default-log-port* "Forcing db-cache mode due to read-only access to megatest.db")
 ;;       (hash-table-set! args:arg-hash "-use-db-cache" #t)));;;)
 ;;)
 
-;; data common to all tabs goes here
-;;
-(defstruct dboard:commondat
-  ((curr-tab-num 0) : number)
-  please-update  
-  tabdats
-  update-mutex
-  updaters 
-  updating
-  uidat ;; needs to move to tabdat at some time
-  hide-not-hide-tabs
-  )
-
-(define (dboard:commondat-make)
-  (make-dboard:commondat
-   curr-tab-num:         0
-   tabdats:              (make-hash-table)
-   please-update:        #t
-   update-mutex:         (make-mutex)
-   updaters:             (make-hash-table)
-   updating:             #f
-   hide-not-hide-tabs:   #f
-   ))
+;; data common to all tabs in dboard:commondat struct moved to dcommonmod
+  ;; data from sql db
+;; (keys       (rmt:get-keys))         ;; to be removed when targets handling is r
 
 ;; RA => returns the tabdat stored at hashkey passed in commondat-tabdats table (e.g. 0 gives summary)
 ;;
 (define (dboard:common-get-tabdat commondat #!key (tab-num #f))
   (let* ((tnum (or tab-num
@@ -237,133 +246,10 @@
 			     (dboard:commondat-curr-tab-num commondat)))
 	 (curr-updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '())))
     (hash-table-set! (dboard:commondat-updaters commondat)
 		     tnum
 		     (cons updater curr-updaters))))
-
-;; data for each specific tab goes here
-;;
-(defstruct dboard:tabdat 
-  ;; runs
-  ((allruns         '())                 : list)        ;; list of dboard:rundat records
-  ((allruns-by-id    (make-hash-table))  : hash-table)  ;; hash of run-id -> dboard:rundat records
-  ((done-runs       '())                 : list)        ;; list of runs already drawn
-  ((not-done-runs   '())                 : list)        ;; list of runs not yet drawn
-  (header            #f)                                ;; header for decoding the run records
-  (keys              #f)                                ;; keys for this run (i.e. target components)
-  ((numruns          (string->number (or (args:get-arg "-cols")
-					 (configf:lookup *configdat* "dashboard" "cols")
-					 "8")))                 : number)      ;; 
-  ((tot-runs          0)                 : number)
-  ((last-data-update  0)                 : number)      ;; last time the data in allruns was updated
-  ((last-runs-update  0)                 : number)      ;; last time we pulled the runs info to update the tree
-  (runs-mutex         (make-mutex))                     ;; use to prevent parallel access to draw objects
-  ((run-update-times  (make-hash-table)) : hash-table)  ;; update times indexed by run-id
-  ((last-test-dat      (make-hash-table)) : hash-table)  ;; cache last tests dat by run-id
-  ((run-db-paths      (make-hash-table)) : hash-table)  ;; cache the paths to the run db files
-
-  ;; Runs view
-  ((buttondat         (make-hash-table)) : hash-table)  ;;     
-  ((item-test-names  '())                : list)        ;; list of itemized tests
-  ((run-keys          (make-hash-table)) : hash-table)
-  (runs-matrix        #f)                               ;; used in newdashboard
-  ((start-run-offset   0)                : number)      ;; left-right slider value
-  ((start-test-offset  0)                : number)      ;; up-down slider value
-  ((runs-btn-height    (or (configf:lookup *configdat* "dashboard" "btn-height") "x16")) : string)  ;; was 12
-  ((runs-btn-fontsz    (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10")) : string)   ;; was 8
-  ((runs-cell-width    (or (configf:lookup *configdat* "dashboard" "cell-width") "50")) : string)   ;; was 50
-  ((all-test-names     '())              : list)
-  
-  ;; Canvas and drawing data
-  (cnv                #f)
-  (cnv-obj            #f)
-  (drawing            #f)
-  ((run-start-row     0)                 : number)
-  ((max-row           0)                 : number)
-  ((running-layout    #f)                : boolean)
-  (originx            #f)
-  (originy            #f)
-  ((layout-update-ok  #t)                : boolean)
-  ((compact-layout    #t)                : boolean)
-
-  ;; Run times layout
-  ;; (graph-button-box #f) ;; RA => Think it is not referenced anywhere
-  (graph-matrix     #f)
-  ((graph-matrix-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru graph name info
-  ((graph-cell-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru matrix cell info
-  ((graph-matrix-row 1) : number)
-  ((graph-matrix-col 1) : number)
-
-  ;; Controls used to launch runs etc.
-  ((command          "")                 : string)      ;; for run control this is the command being built up
-  (command-tb        #f)	                        ;; widget for the type of command; run, remove-runs etc.
-  (test-patterns-textbox #f)                            ;; text box widget for editing a list of test patterns
-  (key-listboxes     #f)			         
-  (key-lbs           #f)			         
-  run-name                                              ;; from run name setting widget
-  states                                                ;; states for -state s1,s2 ...
-  statuses                                              ;; statuses for -status s1,s2 ...
-						         
-  ;; Selector variables				         
-  curr-run-id                                           ;; current row to display in Run summary view
-  prev-run-id                                           ;; previous runid selected before current runid was selected (used in xor-two-runs runs summary mode
-  curr-test-ids                                         ;; used only in dcommon:run-update which is used in newdashboard
-  ((filters-changed  #t)                  : boolean)    ;; to indicate that the user changed filters for this tab
-  ((last-filter-str  "")                  : string)      ;; conc the target runname and testpatt for a signature of changed filters
-  ((hide-empty-runs  #f)                  : boolean)     
-  ((hide-not-hide    #t)                  : boolean)     ;; toggle for hide/not hide empty runs
-  (hide-not-hide-button #f)
-  ((searchpatts        (make-hash-table)) : hash-table)  ;;
-  ((state-ignore-hash  (make-hash-table)) : hash-table)  ;; hash of  STATE => #t/#f for display control
-  ((status-ignore-hash (make-hash-table)) : hash-table)  ;; hash of STATUS => #t/#f
-  (target              #f)
-  (test-patts          #f)
-
-  ;; db info to file the .db files for the area
-  (access-mode        (db:get-access-mode))             ;; use cached db or not
-  (dbdir               #f)
-  (dbfpath             #f)
-  (dbkeys              #f)
-  ((last-db-update     (make-hash-table)) : hash-table) ;; last db file timestamp
-  (monitor-db-path     #f)                              ;; where to find monitor.db
-  ro                                                    ;; is the database read-only?
-
-  ;; tests data
-  ((num-tests          10)               : number)      ;; total number of tests to show (used in the old runs display)
-
-  ;; runs tree
-  ((path-run-ids       (make-hash-table)) : hash-table) ;; path (target / runname) => id
-  (runs-tree           #f)
-  ((runs-tree-ht       (make-hash-table)) : hash-table) ;; track which targets added to tree (merge functionality with path-run-ids?)
-
-  ;; tab data
-  ((view-changed       #t)                : boolean)   
-  ((xadj               0)                 : number)     ;; x slider number (if using canvas)
-  ((yadj               0)                 : number)     ;; y slider number (if using canvas)
-  ;; runs-summary tab state
-  ((runs-summary-modes '((one-run . "Show One Run") (xor-two-runs . "XOR Two Runs") (xor-two-runs-hide-clean . "XOR; Hide Clean")) )   : list)
-  ((runs-summary-mode-buttons '())               : list)
-  ((runs-summary-mode  'one-run)            : symbol)
-  ((runs-summary-mode-change-callbacks '()) : list)
-  (runs-summary-source-runname-label #f)
-  (runs-summary-dest-runname-label #f)
-  ;; runs summary view
-  
-  tests-tree       ;; used in newdashboard
-  )
-
-;; register tabdat with BBpp
-;; this is used by BBpp (Brandon's pretty printer) to convert dboard:tabdat into a composition of lists that pp will handle
-(hash-table-set! *BBpp_custom_expanders_list* TABDAT:
-                 (cons dboard:tabdat?
-                       (lambda (tabdat-item)
-                         (filter
-                          (lambda (alist-entry)
-                            (member (car alist-entry)
-                                    '(allruns-by-id allruns))) ;; FIELDS OF INTEREST
-                          (dboard:tabdat->alist tabdat-item)))))
-
 
 
 (define (dboard:tabdat-target-string vec)
   (let ((targ (dboard:tabdat-target vec)))
     (if (list? targ)(string-intersperse targ "/") "no-target-specified")))
@@ -375,17 +261,24 @@
 (define (dboard:tabdat-test-patts-set!-use    vec val)
   (dboard:tabdat-test-patts-set! vec (if (equal? val "") #f val)))
 
 (define (dboard:tabdat-make-data)
   (let ((dat (make-dboard:tabdat)))
+    (dboard:tabdat-runs-btn-height-set! dat (or (configf:lookup *configdat* "dashboard" "btn-height") "x16")) ;; was 12
+    (dboard:tabdat-runs-btn-fontsz-set! dat (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10"))  ;; was 8
+    (dboard:tabdat-runs-cell-width-set! dat (or (configf:lookup *configdat* "dashboard" "cell-width") "50"))  ;; was 50
+    (dboard:tabdat-numruns-set!         dat (string->number (or (args:get-arg "-cols")
+								(configf:lookup *configdat* "dashboard" "cols")
+								"8")))
+    (dboard:tabdat-access-mode-set!     dat (db:get-access-mode))             ;; use cached db or not
     (dboard:setup-tabdat dat)
     (dboard:setup-num-rows dat)
     dat))
 
 (define (dboard:setup-tabdat tabdat)
-  (dboard:tabdat-dbdir-set! tabdat (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
-  (dboard:tabdat-dbfpath-set! tabdat (db:dbfile-path))
+  (dboard:tabdat-dbdir-set! tabdat (common:get-db-tmp-area)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
+  (dboard:tabdat-dbfpath-set! tabdat (common:get-db-tmp-area))
   (dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db"))
 
   ;; HACK ALERT: this is a hack, please fix.
   (dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat))))
   
@@ -392,144 +285,16 @@
   (dboard:tabdat-keys-set! tabdat (rmt:get-keys))
   (dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname")))
   (dboard:tabdat-tot-runs-set! tabdat (rmt:get-num-runs "%"))
   )
 
-;; RADT => Matrix defstruct addition
-(defstruct dboard:graph-dat
-    ((id           #f) : string)
-    ((color        #f) : vector)
-    ((flag         #t) : boolean)
-    ((cell         #f) : number)
-    )
-
-;; data for runs, tests etc. was used in run summary?
-;;
-(defstruct dboard:runsdat
-  ;; new system
-  runs-index    ;; target/runname => colnum
-  tests-index   ;; testname/itempath => rownum
-  matrix-dat    ;; vector of vectors rows/cols
-  )
-
 (define (dboard:runsdat-make-init)
   (make-dboard:runsdat
    runs-index: (make-hash-table)
    tests-index: (make-hash-table)
    matrix-dat: (make-sparse-array)))
 
-;; used to keep the rundata from rmt:get-tests-for-run
-;; in sync. 
-;;
-(defstruct dboard:rundat
-  run
-  tests-drawn    ;; list of id's already drawn on screen
-  tests-notdrawn ;; list of id's NOT already drawn
-  rowsused       ;; hash of lists covering what areas used - replace with quadtree
-  hierdat        ;; put hierarchial sorted list here
-  tests          ;; hash of id => testdat
-  ((tests-by-name (make-hash-table)) : hash-table) ;; hash of testfullname => testdat
-  key-vals
-  ((last-update   0)                 : number)    ;; last query to db got records from before last-update
-  ((last-db-time  0)                 : number)    ;; last timestamp on megatest.db
-  ((data-changed  #f)                : boolean)   
-  ((run-data-offset  0)              : number)      ;; get only 100 items per call, set back to zero when received less than 100 items
-  (db-path #f))
-
-;; for the new runs view lets build up a few new record types and then consolidate later
-;;
-;; this is a two level deep pipeline for the incoming data:
-;;   sql query data ==> filters ==> data for display
-;;
-(defstruct dboard:rdat
-  ;; view related items
-  (runnum    0) ;; which column we are processing, index into runsbynum, we sweep across all these runs then start over
-  (leftcol   0) ;; number of the leftmost visible column
-  (toprow    0) ;; topmost visible row
-  (numcols  24) ;; number of columns visible
-  (numrows  20) ;; number of rows visible
-  
-  ;; data from sql db
-  (keys       (rmt:get-keys))         ;; to be removed when targets handling is refactored
-  (runs       (make-sparse-vector))   ;; id => runrec
-  (runsbynum  (make-vector 100 #f))   ;; vector num => runrec 
-  (targ-runid (make-hash-table))      ;; area/target/runname => run-id  ;; not sure this will be needed
-  (tests      (make-hash-table))      ;; test[/itempath] => list of test rec
-
-  ;; run sql filters 
-  (targ-sql-filt        "%")
-  (runname-sql-filt     "%")
-  (run-state-sql-filt   "%")
-  (run-status-sql-filt  "%")
-
-  ;; test sql filter
-  (testname-sql-filt    "%")
-  (itempath-sql-filt    "%")
-  (test-state-sql-filt  "%")
-  (test-status-sql-filt "%")
-
-  ;; other sql related fields
-  (last-updates (make-sparse-vector 0))  ;; run-id -> timestamp of the last update from sql db, set to zero on any field changes
-
-  ;; filtered data
-  (cols  (make-sparse-vector))   ;; columnnum => run-id
-  (tests (make-hash-table))      ;; test[/itempath] => (vector columnnum => test rec)
-
-  ;; various
-  (prev-run-ids  '())            ;; push previously looked at runs on this
-  (view-changed #f)
-
-  ;; widgets
-  (runs-tree #f)                 ;; 
-  )
-
-(define (dboard:rdat-push-run-id rdat run-id)
-  (dboard:rdat-prev-run-ids-set! rdat (cons run-id (dboard:rdat-prev-run-ids rdat))))
-
-(defstruct dboard:runrec
-  id
-  target  ;; a/b/c...
-  tdef    ;; for future use
-  )
-     
-(defstruct dboard:testrec
-  id
-  runid
-  testname  ;; test[/itempath]
-  state
-  status
-  start-time
-  duration
-  )
-
-;; register dboard:rundat with BBpp
-;; this is used by BBpp (Brandon's pretty printer) to convert dboard:rundat into a composition of lists that pp will handle
-(hash-table-set! *BBpp_custom_expanders_list* RUNDAT:
-                 (cons dboard:rundat?
-                       (lambda (tabdat-item)
-                         (filter
-                          (lambda (alist-entry)
-                            (member (car alist-entry)
-                                    '(run run-data-offset ))) ;; FIELDS OF INTEREST
-                          (dboard:rundat->alist tabdat-item)))))
-
-
-
-
-(define (dboard:rundat-make-init #!key (run #f)(key-vals #f)(tests #f));; -100 is before time began
-  (make-dboard:rundat 
-   run: run
-   tests: (or tests (make-hash-table))
-   key-vals: key-vals 
-   )) 
-
-(defstruct dboard:testdat
-  id       ;; testid
-  state    ;; test state
-  status   ;; test status
-  )
-
 ;; default is to NOT set the cell if the column and row names are not pre-existing
 ;;
 (define (dboard:runsdat-set-test-cell dat target runname testname itempath test-id state status #!key (force-set #f))
   (let* ((col-num  (dcommon:runsdat-get-col-num dat target runname force-set))
 	 (row-num  (dcommon:runsdat-get-row-num dat testname itempath force-set)))
@@ -580,11 +345,12 @@
 (define (get-curr-sort)
   (vector-ref *tests-sort-options* *tests-sort-reverse*))
 
 ;;======================================================================
 
-(debug:setup)
+;;======================================================================
+(common:debug-setup)
 
 ;; (define uidat #f)
 
 (define-inline (dboard:uidat-get-keycol  vec)(vector-ref vec 0))
 (define-inline (dboard:uidat-get-lftcol  vec)(vector-ref vec 1))
@@ -1820,20 +1586,10 @@
 ;; R U N
 ;;======================================================================
 ;;
 ;; display and manage a single run at a time
 
-(define (tree-path->run-id tabdat path)
-  (if (not (null? path))
-      (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) path #f)
-      #f))
-
-(define (new-tree-path->run-id rdat path)
-  (if (not (null? path))
-      (hash-table-ref/default (dboard:rdat-path-run-ids tabdat) path #f)
-      #f))
-
 ;; (define (dboard:get-tests-dat tabdat run-id last-update)
 ;;   (let* ((access-mode     (dboard:tabdat-access-mode tabdat))
 ;;          (tdat (if run-id (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run
 ;;                                              run-id 
 ;; 					     (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
@@ -2601,150 +2357,18 @@
 ;; simple-run-status-set!            procedure (x3814 val3815)
 ;; simple-run-target                 procedure (x3786)
 ;; simple-run-target-set!            procedure (x3782 val3783)
 ;; simple-run?                       procedure (x3780)
 
-
-;;======================================================================
-;; Extracting the data to display for runs
-;;
-;; This needs to be re-entrant such that it does one column per call
-;; on the zeroeth call update runs data
-;; on each subsequent call update one run (configurable - could do two, three ... or update until tdelta exceeded
-;; on last run reset to zeroeth
-;;
-;;   1. select with run filters; area, target, runname, runstate, runstatus, starttime, duration
-;;       - put this information into two data structures:
-;;         a. hash of area/target/runname => runstruct #< ordernun, id, area, target, runname, state,
-;;                                                        status, starttime, duration, non-deleted testcount>
-;;            ordernum reflects order as received from sql query
-;;         b. sparsevec of id => runstruct
-;;   2. for each run in runshash ordered by ordernum do:
-;;         retrieve data since last update for that run
-;;         if there is a deleted test - retrieve full data
-;;         if there are non-deleted tests register this run in the columns sparsevec
-;;         if this is the zeroeth column regenerate the rows sparsevec
-;;         if this column is in the visible zone update visible cells
-;;
-;; Other factors:
-;;   1. left index handling:
-;;       - add test/itempaths to left index as discovered, re-order and
-;;         update row -> test/itempath mapping on each read run
-;;======================================================================
-
-;; runs is <vec header runs>
-;;   get ALL runs info
-;;   update rdat-targ-run-id
-;;   update rdat-runs
-;;
-(define (dashboard:update-runs-data rdat)
-  (let* ((tb               (dboard:rdat-runs-tree rdat))
-	 (targ-sql-filt    (dboard:rdat-targ-sql-filt    rdat))
-	 (runname-sql-filt (dboard:rdat-runname-sql-filt rdat))
-	 (state-sql-filt   (dboard:rdat-run-state-sql-filt   rdat))
-	 (status-sql-filt  (dboard:rdat-run-status-sql-filt  rdat))
-	 ;; Use (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
-	 (data             (rmt:simple-get-runs runname-sql-filt #f #f targ-sql-filt #f))
-	 (numruns          (length data)))
-    ;; store in the runsbynum vector
-    (dboard:rdat-runsbynum-set! rdat (list->vector data))
-    ;; update runs       id              => runrec
-    ;; update targ-runid target/runname  => run-id
-    (for-each
-     (lambda (runrec)
-       (let* ((run-id (simple-run-id runrec))
-	      (full-targ-runname (conc (simple-run-target runrec) "/"
-				       (simple-run-runname runrec))))
-	 (debug:print 0 *default-log-port* "Update run  " run-id)
-	 (sparse-vector-set! (dboard:rdat-runs rdat) run-id runrec)
-	 (hash-table-set! (dboard:rdat-targ-runid rdat) full-targ-runname run-id)
-	 ))
-     data)
-    numruns))
-
-;; NOTE: runnum is NOT the run-id, it is a pointer into the runsbynum vector
-;;
-(define (dashboard:update-run-data runnum rdat)
-  (let* ((curr-time            (current-seconds))
-	 (runrec               (vector-ref (dboard:rdat-runsbynum rdat) runnum))
-	 (run-id               (simple-run-id runrec))
-	 (last-update          (sparse-vector-ref (dboard:rdat-last-updates rdat) run-id))
-	 ;; filters
-	 (testname-sql-filt    (dboard:rdat-testname-sql-filt    rdat))
-	 ;; (itempath-sql-filt    (dboard:rdat-itempath-sql-filt    rdat))
-	 (test-state-sql-filt  (dboard:rdat-test-state-sql-filt  rdat))  ;; not used yet
-	 (test-status-sql-filt (dboard:rdat-test-status-sql-filt rdat))  ;; not used yet
-	 (tests                (rmt:get-tests-for-run-state-status run-id
-						      testname-sql-filt
-						      last-update                ;; last-update
-						      )))
-    (sparse-vector-set! (dboard:rdat-last-updates rdat) run-id (- curr-time 1))
-    (debug:print 0 *default-log-port* "Got " (length tests) " tests for run-id "
-		 run-id " testname-sql-filt " testname-sql-filt " and last-update " last-update) 
-    (length tests)))
-
-(define (new-runs-updater commondat rdat)
-  (let* ((runnum           (dboard:rdat-runnum          rdat))
-	 (start-time       (current-milliseconds))
-	 (tot-runs         #f))
-    (if (eq? runnum 0)(dashboard:update-runs-data rdat))
-    (set! tot-runs (vector-length (dboard:rdat-runsbynum rdat)))
-    (let loop ((rn   runnum))
-      (if (and (< (- (current-milliseconds) start-time) 250)
-	       (< rn tot-runs))
-	  (let* ((newrn (if (>= runnum (vector-length (dboard:rdat-runsbynum rdat)))
-			    0 ;; start over
-			    (+ rn 1)))) ;; (+ runnum 1)))
-	    (dashboard:update-run-data rn rdat)
-	    (dboard:rdat-runnum-set! rdat newrn)
-	    (if (> newrn 0)
-		(loop newrn)))))
-    (if (>=  (dboard:rdat-runnum rdat) tot-runs)
-	(dboard:rdat-runnum-set! rdat 0))
-    ;; (dboard:rdat-runnum-set! rdat rn))) ;; not needed as it is set above
-    ;; (dboard:rdat-last-update-set! rdat (- (current-seconds) 10))
-    ;;    	 (tree:add-node tb "Runs" (string-split full-targ-runname "/"))
-    '()))
-
-(define (dboard:runs-new-matrix commondat rdat)
-  (iup:matrix
-   #:alignment1 "ALEFT"
-   ;; #:expand "YES" ;; "HORIZONTAL"
-   #:scrollbar "YES"
-   #:numcol 10
-   #:numlin 20
-   #:numcol-visible 5 ;; (min 8)
-   #:numlin-visible 1
-   #:click-cb
-   (lambda (obj row col status)
-     (let* ((cell (conc row ":" col)))
-       #f))
-   ))
-	 
-(define (make-runs-view commondat rdat tab-num)
-  ;; register an updater
-  (dboard:commondat-add-updater
-   commondat
-   (lambda ()
-     (new-runs-updater commondat rdat))
-   tab-num: tab-num)
-
-  (iup:vbox
-   (iup:split
-    #:orientation "VERTICAL" ;; "HORIZONTAL"
-    #:value 100
-    (dboard:runs-tree-new-browser commondat rdat)
-    (dboard:runs-new-matrix commondat rdat)
-    )))
-
 (define (make-dashboard-buttons commondat) ;;  runs-sum-dat new-view-dat)
   (let* ((stats-dat       (dboard:tabdat-make-data))
 	 (runs-dat        (dboard:tabdat-make-data))
 	 (runs2-dat       (make-dboard:rdat)) ;; (dboard:tabdat-make-data))
 	 (onerun-dat      (dboard:tabdat-make-data)) ;; name for run-summary structure 
 	 (runcontrols-dat (dboard:tabdat-make-data))
 	 (runtimes-dat    (dboard:tabdat-make-data))
+	 (runs-browse-dat (dboard:tabdat-make-data))
 	 (nruns           (dboard:tabdat-numruns runs-dat))
 	 (ntests          (dboard:tabdat-num-tests runs-dat))
 	 (keynames        (dboard:tabdat-dbkeys runs-dat))
 	 (nkeys           (length keynames))
 	 (runsvec         (make-vector nruns))
@@ -2916,10 +2540,11 @@
     ;; now assemble the hdrlst and bdylst and kick off the dialog
     (iup:show
      (iup:dialog 
       #:title (conc "Megatest dashboard " (current-user-name) ":" *toppath*)
       #:menu (dcommon:main-menu)
+      #:shrink "YES"
       (let* ((runs-view (iup:vbox
 			 (iup:split
 			  #:orientation "VERTICAL" ;; "HORIZONTAL"
 			  #:value 100
 			  (dboard:runs-tree-browser commondat runs-dat)
@@ -2936,11 +2561,11 @@
 			    (dashboard:runs-horizontal-slider runs-dat))))
 			 controls
 			 ))
 	     (views-cfgdat (common:load-views-config))
 	     (additional-tabnames '())
-	     (tab-start-num       5)   ;; DON'T FORGET TO UPDATE THIS WHEN CHANGING THE STANDARD TABS BELOW
+	     (tab-start-num       6)   ;; DON'T FORGET TO UPDATE THIS WHEN CHANGING THE STANDARD TABS BELOW
 	     ;; (data (dboard:tabdat-init (make-d:data)))
 	     (additional-views 	;; process views-dat
 	      (let ((tab-num tab-start-num)
 		    (result  '()))
 		(for-each
@@ -2965,10 +2590,11 @@
 			 (let ((order-a (or (any->number (configf:lookup views-cfgdat a "order")) 999))
 			       (order-b (or (any->number (configf:lookup views-cfgdat b "order")) 999)))
 			   (> order-a order-b)))))
 		result))
 	     (tabs (apply iup:tabs
+			  #:shrink "YES"
 			  #:tabchangepos-cb (lambda (obj curr prev)
 					      (debug:catch-and-dump
 					       (lambda ()
 						 (let* ((tab-num (dboard:commondat-curr-tab-num commondat))
 							(tabdat  (dboard:common-get-tabdat commondat tab-num: tab-num)))
@@ -2982,11 +2608,12 @@
 			  (dashboard:summary commondat stats-dat tab-num: 0)
 			  runs-view
 			  ;; (make-runs-view commondat runs2-dat 2)
 			  (dashboard:runs-summary commondat onerun-dat tab-num: 2)
 			  (dashboard:run-controls commondat runcontrols-dat tab-num: 3)
-			  (dashboard:run-times commondat runtimes-dat tab-num: 4)
+			  (dashboard:run-times    commondat runtimes-dat tab-num: 4)
+			  (dashboard:runs-browse  commondat runs-browse-dat tab-num: 5)
 			  additional-views)))
 	;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
 	(iup:attribute-set! tabs "TABTITLE0" "Summary")
 	(iup:attribute-set! tabs "TABTITLE1" "Runs")
 	;; (iup:attribute-set! tabs "TABTITLE2" "Runs2")
@@ -2993,11 +2620,12 @@
 	(iup:attribute-set! tabs "TABTITLE2" "Run Summary")
 	(iup:attribute-set! tabs "TABTITLE3" "Run Control")
 	(iup:attribute-set! tabs "TABTITLE4" "Run Times")
 	;; (iup:attribute-set! tabs "TABTITLE3" "New View")
 	;; (iup:attribute-set! tabs "TABTITLE4" "Run Control")
-
+	(iup:attribute-set! tabs "TABTITLE5" "Runs Browse")
+	
 	;; set the tab names for user added tabs
 	(for-each
 	 (lambda (tab-info)
 	   (iup:attribute-set! tabs (conc "TABTITLE" (car tab-info)) (cdr tab-info)))
 	 additional-tabnames)
@@ -3010,10 +2638,11 @@
 	(dboard:common-set-tabdat! commondat 1 runs-dat)
 	;;(dboard:common-set-tabdat! commondat 2 runs2-dat)
 	(dboard:common-set-tabdat! commondat 2 onerun-dat)
 	(dboard:common-set-tabdat! commondat 3 runcontrols-dat)
 	(dboard:common-set-tabdat! commondat 4 runtimes-dat)
+	(dboard:common-set-tabdat! commondat 5 runs-browse-dat)
 
 	(iup:vbox
 	 tabs
 	 ;; controls
 	 ))))

DELETED datashare.scm
Index: datashare.scm
==================================================================
--- datashare.scm
+++ /dev/null
@@ -1,825 +0,0 @@
-
-;; Copyright 2006-2013, Matthew Welland.
-;; 
-;; This file is part of Megatest.
-;; 
-;;     Megatest is free software: you can redistribute it and/or modify
-;;     it under the terms of the GNU General Public License as published by
-;;     the Free Software Foundation, either version 3 of the License, or
-;;     (at your option) any later version.
-;; 
-;;     Megatest is distributed in the hope that it will be useful,
-;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;     GNU General Public License for more details.
-;; 
-;;     You should have received a copy of the GNU General Public License
-;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
-
-(use ssax)
-(use sxml-serializer)
-(use sxml-modifications)
-(use regex)
-(use srfi-69)
-(use regex-case)
-(use posix)
-(use json)
-(use csv)
-(use srfi-18)
-(use format)
-
-(require-library iup)
-(import (prefix iup iup:))
-(require-library ini-file)
-(import (prefix ini-file ini:))
-
-(use canvas-draw)
-(import canvas-draw-iup)
-
-(use sqlite3 srfi-1 posix regex regex-case srfi-69)
-(import (prefix sqlite3 sqlite3:))
-
-(declare (uses configf))
-(declare (uses tree))
-(declare (uses margs))
-;; (declare (uses dcommon))
-;; (declare (uses launch))
-;; (declare (uses gutils))
-;; (declare (uses db))
-;; (declare (uses synchash))
-;; (declare (uses server))
-;; (declare (uses megatest-version))
-;; (declare (uses tbd))
-
-(include "megatest-fossil-hash.scm")
-
-;;
-;; GLOBALS
-;;
-(define *datashare:current-tab-number* 0)
-(define *args-hash* (make-hash-table))
-(define datashare:help (conc "Usage: datashare [action [params ...]]
-
-Note: run datashare without parameters to start the gui.
-
-  list-areas                          : List the allowed areas
-
-  list-versions <area>                : List versions available in <area>
-         options : -full, -vpatt patt
-
-  publish <path> <area> <version>     : Publish data for area and with version
-
-  get <area> <version>                : Get a link to data, put the link in destpath
-         options : -i iteration
-
-  update <area>                       : Update the link to data to the latest iteration.
-
-Part of the Megatest tool suite.
-Learn more at http://www.kiatoa.com/fossils/megatest
-
-Version: " megatest-fossil-hash)) ;; "
-
-;;======================================================================
-;; RECORDS
-;;======================================================================
-
-;; make-vector-record "testing" datastore pkg id area version_name store_type copied source_path iteration submitter datetime storegrp datavol quality disk_id comment
-;; testing
-(define (make-datashare:pkg)(make-vector 15))
-(define-inline (datashare:pkg-get-id             vec)    (vector-ref  vec 0))
-(define-inline (datashare:pkg-get-area           vec)    (vector-ref  vec 1))
-(define-inline (datashare:pkg-get-version_name   vec)    (vector-ref  vec 2))
-(define-inline (datashare:pkg-get-store_type     vec)    (vector-ref  vec 3))
-(define-inline (datashare:pkg-get-copied         vec)    (vector-ref  vec 4))
-(define-inline (datashare:pkg-get-source_path    vec)    (vector-ref  vec 5))
-(define-inline (datashare:pkg-get-iteration      vec)    (vector-ref  vec 6))
-(define-inline (datashare:pkg-get-submitter      vec)    (vector-ref  vec 7))
-(define-inline (datashare:pkg-get-datetime       vec)    (vector-ref  vec 8))
-(define-inline (datashare:pkg-get-storegrp       vec)    (vector-ref  vec 9))
-(define-inline (datashare:pkg-get-datavol        vec)    (vector-ref  vec 10))
-(define-inline (datashare:pkg-get-quality        vec)    (vector-ref  vec 11))
-(define-inline (datashare:pkg-get-disk_id        vec)    (vector-ref  vec 12))
-(define-inline (datashare:pkg-get-comment        vec)    (vector-ref  vec 13))
-(define-inline (datashare:pkg-get-stored_path    vec)    (vector-ref  vec 14))
-(define-inline (datashare:pkg-set-id!            vec val)(vector-set! vec 0 val))
-(define-inline (datashare:pkg-set-area!          vec val)(vector-set! vec 1 val))
-(define-inline (datashare:pkg-set-version_name!  vec val)(vector-set! vec 2 val))
-(define-inline (datashare:pkg-set-store_type!    vec val)(vector-set! vec 3 val))
-(define-inline (datashare:pkg-set-copied!        vec val)(vector-set! vec 4 val))
-(define-inline (datashare:pkg-set-source_path!   vec val)(vector-set! vec 5 val))
-(define-inline (datashare:pkg-set-iteration!     vec val)(vector-set! vec 6 val))
-(define-inline (datashare:pkg-set-submitter!     vec val)(vector-set! vec 7 val))
-(define-inline (datashare:pkg-set-datetime!      vec val)(vector-set! vec 8 val))
-(define-inline (datashare:pkg-set-storegrp!      vec val)(vector-set! vec 9 val))
-(define-inline (datashare:pkg-set-datavol!       vec val)(vector-set! vec 10 val))
-(define-inline (datashare:pkg-set-quality!       vec val)(vector-set! vec 11 val))
-(define-inline (datashare:pkg-set-disk_id!       vec val)(vector-set! vec 12 val))
-(define-inline (datashare:pkg-set-comment!       vec val)(vector-set! vec 13 val))
-(define-inline (datashare:pkg-set-stored_path!   vec val)(vector-set! vec 14 val))
-
-;;======================================================================
-;; DB
-;;======================================================================
-
-(define (datashare:initialize-db db)
-  (for-each
-   (lambda (qry)
-     (sqlite3:execute db qry))
-   (list 
-    "CREATE TABLE pkgs 
-         (id           INTEGER PRIMARY KEY,
-          area         TEXT,
-          version_name TEXT,
-          store_type   TEXT DEFAULT 'copy',
-          copied       INTEGER DEFAULT 0,
-          source_path  TEXT,
-          stored_path  TEXT,
-          iteration    INTEGER DEFAULT 0,
-          submitter    TEXT,
-          datetime     TIMESTAMP DEFAULT (strftime('%s','now')),
-          storegrp     TEXT,
-          datavol      INTEGER,
-          quality      TEXT,
-          disk_id      INTEGER,
-          comment      TEXT);"
-    "CREATE TABLE refs
-         (id        INTEGER PRIMARY KEY,
-          pkg_id    INTEGER,
-          destlink  TEXT);"
-    "CREATE TABLE disks
-         (id         INTEGER PRIMARY KEY,
-          storegrp   TEXT,
-          path       TEXT);")))
-
-(define (datashare:register-data db area version-name store-type submitter quality source-path comment)
-  (let ((iter-qry       (sqlite3:prepare db "SELECT max(iteration) FROM pkgs WHERE area=? AND version_name=?;"))
-	(next-iteration 0))
-    (sqlite3:with-transaction
-     db
-     (lambda ()
-       (sqlite3:for-each-row
-	(lambda (iteration)
-	  (if (and (number? iteration)
-		   (>= iteration next-iteration))
-	      (set! next-iteration (+ iteration 1))))
-	iter-qry area version-name)
-       ;; now store the data
-       (sqlite3:execute db "INSERT INTO pkgs (area,version_name,iteration,store_type,submitter,source_path,quality,comment) 
-                                 VALUES (?,?,?,?,?,?,?,?);"
-			area version-name next-iteration (conc store-type) submitter source-path quality comment)))
-    (sqlite3:finalize! iter-qry)
-    next-iteration))
-
-(define (datashare:get-id db area version-name iteration)
-  (let ((res #f))
-    (sqlite3:for-each-row
-     (lambda (id)
-       (set! res id))
-     db
-     "SELECT id FROM pkgs WHERE area=? AND version_name=? AND iteration=?;"
-     area version-name iteration)
-    res))
-
-(define (datashare:set-stored-path db id path)
-  (sqlite3:execute db "UPDATE pkgs SET stored_path=? WHERE id=?;" path id))
-
-(define (datashare:set-copied db id value)
-  (sqlite3:execute db "UPDATE pkgs SET copied=? WHERE id=?;" value id))
-  
-(define (datashare:get-pkg-record db area version-name iteration)
-  (let ((res #f))
-    (sqlite3:for-each-row
-     (lambda (a . b)
-       (set! res (apply vector a b)))
-     db 
-     "SELECT * FROM pkgs WHERE area=? AND version_name=? AND iteration=?;"
-     area 
-     version-name
-     iteration)
-    res))
-
-;; take version-name iteration and register or update "lastest/0"
-;;
-(define (datashare:set-latest db id area version-name iteration)
-  (let* ((rec         (datashare:get-pkg-record db area version-name iteration))
-	 (latest-id   (datashare:get-id db area "latest" 0))
-	 (stored-path (datashare:pkg-get-stored_path rec)))
-    (if latest-id ;; have a record - bump the link pointer
-	(datashare:set-stored-path db latest-id stored-path)
-	(datashare:register-data db area "latest" 'link "auto" "na" stored-path "latest data"))))
-
-;; set a package ref, this is the location where the link back to the stored data 
-;; is put. 
-;;
-;; if there is nothing at that location then the record can be removed
-;; if there are no refs for a particular pkg-id then that pkg-id is a 
-;; candidate for removal
-;;
-(define (datashare:record-pkg-ref db pkg-id dest-link)
-  (sqlite3:execute db "INSERT INTO refs (pkg_id,destlink) VALUES (?,?);" pkg-id dest-link))
-  
-(define (datashare:count-refs db pkg-id)
-  (let ((res 0))
-    (sqlite3:for-each-row
-     (lambda (count)
-       (set! res count))
-     db
-     "SELECT count(id) FROM refs WHERE pkg_id=?;"
-     pkg-id)
-    res))
-
-;; Create the sqlite db
-(define (datashare:open-db configdat) 
-  (let ((path (configf:lookup configdat "database" "location")))
-    (if (and path
-	     (directory? path)
-	     (file-read-access? path))
-	(let* ((dbpath    (conc path "/datashare.db"))
-	       (writeable (file-write-access? dbpath))
-	       (dbexists  (common:file-exists? dbpath))
-	       (handler   (make-busy-timeout 136000)))
-	  (handle-exceptions
-	   exn
-	   (begin
-	     (debug:print 2 *default-log-port* "ERROR: problem accessing db " dbpath
-			  ((condition-property-accessor 'exn 'message) exn))
-	     (exit))
-	   (set! db (sqlite3:open-database dbpath)))
-	  (if *db-write-access* (sqlite3:set-busy-handler! db handler))
-	  (if (not dbexists)
-	      (begin
-		(datashare:initialize-db db)))
-	  db)
-	(print "ERROR: invalid path for storing database: " path))))
-
-(define (open-run-close-exception-handling proc idb . params)
-  (handle-exceptions
-   exn
-   (let ((sleep-time (random 30))
-         (err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
-     (case err-status
-       ((busy)
-        (thread-sleep! sleep-time))
-       (else
-        (print "EXCEPTION: database overloaded or unreadable.")
-        (print " message: " ((condition-property-accessor 'exn 'message) exn))
-        (print "exn=" (condition->list exn))
-        (print " status:  " ((condition-property-accessor 'sqlite3 'status) exn))
-        (print-call-chain (current-error-port))
-        (thread-sleep! sleep-time)
-        (print "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up")))
-     (apply open-run-close-exception-handling proc idb params))
-   (apply open-run-close-no-exception-handling proc idb params)))
-
-(define (open-run-close-no-exception-handling  proc idb . params)
-  ;; (print "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params)
-  (let* ((db (cond
-	      ((sqlite3:database? idb)     idb)
-	      ((not idb)                   (print "ERROR: cannot open-run-close with #f anymore"))
-	      ((procedure? idb)            (idb))
-	      (else                        (print "ERROR: cannot open-run-close with #f anymore"))))
-	 (res #f))
-    (set! res (apply proc db params))
-    (if (not idb)(sqlite3:finalize! dbstruct))
-    ;; (print "open-run-close-no-exception-handling END" )
-    res))
-
-(define open-run-close open-run-close-no-exception-handling)
-
-(define (datashare:get-pkgs db area-filter version-filter iter-filter)
-  (let ((res '()))
-    (sqlite3:for-each-row ;; replace with fold ...
-     (lambda (a . b)
-       (set! res (cons (list->vector (cons a b)) res)))
-     db 
-     (conc "SELECT id,area,version_name,store_type,copied,source_path,iteration,submitter,datetime,storegrp,datavol,quality,disk_id,comment,stored_path "
-	   " FROM pkgs WHERE area like ? AND version_name LIKE ? AND iteration " iter-filter ";")
-     area-filter version-filter)
-    (reverse res)))
-
-(define (datashare:get-pkg db area-name version-name #!key (iteration #f))
-  (let ((dat '())
-	(res #f))
-    (sqlite3:for-each-row ;; replace with fold ...
-     (lambda (a . b)
-       (set! dat (cons (list->vector (cons a b)) dat)))
-     db 
-     (conc "SELECT id,area,version_name,store_type,copied,source_path,iteration,submitter,datetime,storegrp,datavol,quality,disk_id,comment,stored_path "
-	   " FROM pkgs WHERE area=? AND version_name=? ORDER BY iteration ASC;")
-     area-name version-name)
-    ;; now filter for iteration, either max if #f or specific one
-    (if (null? dat)
-	#f
-	(let loop ((hed (car dat))
-		   (tal (cdr dat))
-		   (cur 0))
-	  (let ((itr (datashare:pkg-get-iteration hed)))
-	    (if (equal? itr iteration) ;; this is the one if iteration is specified
-		hed
-		(if (null? tal)
-		    hed
-		    (loop (car tal)(cdr tal)))))))))
-
-(define (datashare:get-versions-for-area db area-name #!key (version-patt #f))
-  (let ((res '())
-	(data (make-hash-table)))
-    (sqlite3:for-each-row
-     (lambda (version-name submitter iteration submitted-time comment)
-       ;;                                              0           1         2           3           4
-       (hash-table-set! data version-name (vector version-name submitter iteration submitted-time comment)))
-     db 
-     "SELECT version_name,submitter,iteration,datetime,comment FROM pkgs WHERE area='megatest' AND version_name != 'latest' AND version_name LIKE ? ORDER BY datetime asc;"
-     (or version-patt "%"))
-    (map (lambda (x)(hash-table-ref data x))(sort (hash-table-keys data) string-ci>=))))
-
-;;======================================================================
-;; DATA IMPORT/EXPORT
-;;======================================================================
-
-(define (datashare:import-data configdat source-path dest-path area version iteration)
-  (let* ((space-avail (car dest-path))
-	 (disk-path   (cdr dest-path))
-	 (targ-path   (conc disk-path "/" area "/" version "/" iteration))
-	 (id          (datashare:get-id db area version iteration))
-	 (db          (datashare:open-db configdat)))
-    (if (> space-avail 10000) ;; dumb heuristic
-	(begin
-	  (create-directory targ-path #t)
-	  (datashare:set-stored-path db id targ-path)
-	  (print "Running command: rsync -av " source-path "/ " targ-path "/")
-	  (let ((th1 (make-thread (lambda ()
-				    (let ((pid (process-run "rsync" (list "-av" (conc source-path "/") (conc targ-path "/")))))
-				      (process-wait pid)
-				      (datashare:set-copied db id "yes")
-				      (sqlite3:finalize! db)))
-				   "Data copy")))
-	    (thread-start! th1))
-	  #t)
-	(begin
-	  (print "ERROR: Not enough space in storage area " dest-path)
-	  (datashare:set-copied db id "no")
-	  (sqlite3:finalize! db)
-	  #f))))
-
-(define (datashare:get-areas configdat)
-  (let* ((areadat (configf:get-section configdat "areas"))
-	 (areas   (if areadat (map car areadat) '())))
-    areas))
-
-(define (datashare:publish configdat publish-type area-name version comment spath submitter quality)
-  ;; input checks
-  (cond 
-   ((not (member area-name (datashare:get-areas configdat)))
-    (cons #f (conc "Illegal area name \"" area-name "\"")))
-   (else
-    (let ((db          (datashare:open-db configdat))
-	  (iteration   (datashare:register-data db area-name version publish-type submitter quality spath comment))
-	  (dest-store  (datashare:get-best-storage configdat)))
-      (if iteration
-	  (if (eq? 'copy publish-type)
-	      (begin
-		(datashare:import-data configdat spath dest-store area-name version iteration)
-		(let ((id (datashare:get-id db area-name version iteration)))
-		  (datashare:set-latest db id area-name version iteration)))
-	      (let ((id (datashare:get-id db area-name version iteration)))
-		(datashare:set-stored-path db id spath)
-		(datashare:set-copied db id "yes")
-		(datashare:set-copied db id "n/a")
-		(datashare:set-latest db id area-name version iteration)))
-	  (print "ERROR: Failed to get an iteration number"))
-      (sqlite3:finalize! db)
-      (cons #t "Successfully saved data")))))
-
-(define (datashare:get-best-storage configdat)
-  (let* ((storage     (configf:lookup configdat "settings" "storage"))
-	 (store-areas (if storage (string-split storage) '())))
-    (print "Looking for available space in " store-areas)
-    (datashare:find-most-space store-areas)))
-
-;; (string->number (list-ref (with-input-from-pipe "df -B1000000 /tmp" (lambda ()(read-line)(string-split (read-line)))) 3))
-
-(define (datashare:find-most-space paths)
-  (fold (lambda (area res)
-	  ;; (print "area=" area " res=" res)
-	  (let ((maxspace (car res))
-		(currpath (cdr res)))
-	    ;; (print currpath " " maxspace)
-	    (if (file-write-access? area)
-		(let ((currspace (string->number
-				  (list-ref
-				   (with-input-from-pipe 
-				    ;; (conc "df --output=avail " area)
-				    (conc "df -B1000000 " area)
-				    ;; (lambda ()(read)(read))
-				    (lambda ()(read-line)(string-split (read-line))))
-				   3))))
-		  (if (> currspace maxspace) 
-		      (cons currspace area)
-		      res))
-		res)))
-	(cons 0 #f)
-	paths))
-
-;; remove existing link and if possible ...
-;; create path to next of tip of target, create link back to source
-(define (datashare:build-dir-make-link source target)
-  (if (common:file-exists? target)(datashare:backup-move target))
-  (create-directory (pathname-directory target) #t)
-  (create-symbolic-link source target))
-
-(define (datashare:backup-move path)
-  (let* ((trashdir  (conc (pathname-directory path) "/.trash"))
-	 (trashfile (conc trashdir "/" (current-seconds) "-" (pathname-file path))))
-    (create-directory trashdir #t)
-    (if (directory? path)
-	(system (conc "mv " path " " trashfile))
-	(file-move path trash-file))))
-
-;;======================================================================
-;; GUI
-;;======================================================================
-
-;; The main menu 
-(define (datashare:main-menu)
-  (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top)
-   (iup:menu-item "Files" (iup:menu   ;; Note that you can use either #:action or action: for options
-		       (iup:menu-item "Open"  action: (lambda (obj)
-							(iup:show (iup:file-dialog))
-							(print "File->open " obj)))
-		       (iup:menu-item "Save"  #:action (lambda (obj)(print "File->save " obj)))
-		       (iup:menu-item "Exit"  #:action (lambda (obj)(exit)))))
-   (iup:menu-item "Tools" (iup:menu
-		       (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah")))
-		       ;; (iup:menu-item "Show dialog"     #:action (lambda (obj)
-		       ;;  					   (show message-window
-		       ;;  					     #:modal? #t
-		       ;;  					     ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current
-		       ;;  					     ;; #:x 'mouse
-		       ;;  					     ;; #:y 'mouse
-		       ;;  )					     
-		       ))))
-
-(define (datashare:publish-view configdat)
-  ;; (pp (hash-table->alist configdat))
-  (let* ((areas       (configf:get-section configdat "areas"))
-	 (label-size  "70x")
-	 (areas-sel   (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES"))
-	 (version-tb  (iup:textbox #:expand "HORIZONTAL")) ;;  #:size "50x"))
-	 (areas-sel   (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES"))
-	 (component   (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES" ))
-	 (version-val (iup:textbox #:expand "HORIZONTAL" #:size "50x"))
-	 ;; (copy-link   (iup:toggle  #:expand "HORIZONTAL"))
-	 ;; (iteration   (iup:textbox #:expand "YES" #:size "20x"))
-	 ;; (iteration   (iup:textbox #:expand "HORIZONTAL" #:size "20x"))
-	 (area-filter (iup:textbox #:expand "HORIZONTAL" #:value "%"))
-	 (comment-tb  (iup:textbox #:expand "YES" #:multiline "YES"))
-	 (source-tb   (iup:textbox #:expand "HORIZONTAL"
-				   #:value (or (configf:lookup configdat "settings" "basepath")
-					       "")))
-	 (publish     (lambda (publish-type)
-			(let* ((area-num    (or (string->number (iup:attribute areas-sel "VALUE")) 0))
-			       (area-dat    (if (> area-num 0)(list-ref areas (- area-num 1))'("NOT SELECTED" "NOT SELECTED")))
-			       (area-path   (cadr area-dat))
-			       (area-name   (car  area-dat))
-			       (version     (iup:attribute version-tb "VALUE"))
-			       (comment     (iup:attribute comment-tb "VALUE"))
-			       (spath       (iup:attribute source-tb  "VALUE"))
-			       (submitter   (current-user-name))
-			       (quality     2))
-			  (datashare:publish configdat publish-type area-name version comment spath submitter quality))))
-	 (copy        (iup:button "Copy and Publish"
-				  #:expand "HORIZONTAL"
-				  #:action (lambda (obj)
-					     (publish 'copy))))
-	 (link        (iup:button "Link and Publish"
-				  #:expand "HORIZONTAL"
-				  #:action (lambda (obj)
-					     (publish 'link))))
-	 (browse-btn  (iup:button "Browse"
-				  #:size "40x"
-				  #:action (lambda (obj)
-					     (let* ((fd  (iup:file-dialog #:dialogtype "DIR"))
-						    (top (iup:show fd #:modal? "YES")))
-					       (iup:attribute-set! source-tb "VALUE"
-								   (iup:attribute fd "VALUE"))
-					       (iup:destroy! fd))))))
-    (print "areas")
-    ;; (pp areas)
-    (fold (lambda (areadat num)
-	    ;; (print "Adding num=" num ", areadat=" areadat)
-	    (iup:attribute-set! areas-sel (conc num) (car areadat))
-	    (+ 1 num))
-	  1 areas)
-    (iup:vbox
-     (iup:hbox (iup:label "Area:"        #:size label-size) ;; area-filter 
-	       areas-sel)
-     (iup:hbox (iup:label "Version:"     #:size label-size)   version-tb)
-     ;; (iup:hbox (iup:label "Link only"    #:size label-size)   copy-link)
-     ;; 	       (iup:label "Iteration:")   iteration)
-     (iup:hbox (iup:label "Comment:"     #:size label-size)   comment-tb)
-     (iup:hbox (iup:label "Source base path:" #:size label-size)   source-tb browse-btn)
-     (iup:hbox copy link))))
-
-(define (datashare:lst->path pathlst)
-  (conc "/" (string-intersperse (map conc pathlst) "/")))
-
-(define (datashare:path->lst path)
-  (string-split path "/"))
-
-(define (datashare:pathdat-apply-heuristics configdat path)
-  (cond
-   ((common:file-exists? path) "found")
-   (else (conc path " not installed"))))
-
-(define (datashare:get-view configdat)
-  (iup:vbox
-   (iup:hbox
-    (let* ((label-size     "60x")
-	   ;; filter elements
-	   (area-filter    "%")
-	   (version-filter "%")
-	   (iter-filter    ">= 0")
-	   ;; reverse lookup from path to data for src and installed
-	   (srcdat         (make-hash-table)) ;; reverse lookup
-	   (installed-dat  (make-hash-table))
-	   ;; config values
-	   (basepath       (configf:lookup configdat "settings" "basepath"))
-	   ;; gui elements
-	   (submitter      (iup:label "" #:expand "HORIZONTAL"))
-	   (date-submitted (iup:label "" #:expand "HORIZONTAL"))
-	   (comment        (iup:label "" #:expand "HORIZONTAL"))
-	   (copy-link      (iup:label "" #:expand "HORIZONTAL"))
-	   (quality        (iup:label "" #:expand "HORIZONTAL"))
-	   (installed-status (iup:label "" #:expand "HORIZONTAL"))
-	   ;; misc 
-	   (curr-record    #f)
-	   ;; (source-data    (iup:label "" #:expand "HORIZONTAL"))
-	   (tb             (iup:treebox
-			    #:value 0
-			    #:name "Packages"
-			    #:expand "YES"
-			    #:addexpanded "NO"
-			    #:selection-cb
-			    (lambda (obj id state)
-			      ;; (print "obj: " obj ", id: " id ", state: " state)
-			      (let* ((path   (datashare:lst->path (cdr (tree:node->path obj id))))
-				     (record (hash-table-ref/default srcdat path #f)))
-				(if record
-				    (begin
-				      (set! curr-record record)
-				      (iup:attribute-set! submitter      "TITLE" (datashare:pkg-get-submitter record))
-				      (iup:attribute-set! date-submitted "TITLE" (time->string (seconds->local-time (datashare:pkg-get-datetime record))))
-				      (iup:attribute-set! comment        "TITLE" (datashare:pkg-get-comment record))
-				      (iup:attribute-set! quality        "TITLE" (datashare:pkg-get-quality record))
-				      (iup:attribute-set! copy-link      "TITLE" (datashare:pkg-get-store_type record))
-				      ))
-				;; (print  "id=" id " path=" path " record=" record);; (tree:node->path obj id) " run-id: " run-id)
-				))))
-	   (tb2             (iup:treebox
-			    #:value 0
-			    #:name "Installed"
-			    #:expand "YES"
-			    #:addexpanded "NO"
-			    #:selection-cb
-			    (lambda (obj id state)
-			      ;; (print "obj: " obj ", id: " id ", state: " state)
-			      (let* ((path   (datashare:lst->path (cdr (tree:node->path obj id))))
-				     (status (hash-table-ref/default installed-dat path #f)))
-				(iup:attribute-set! installed-status "TITLE" (if status status ""))
-				))))
-	   (refresh        (lambda (obj)
-			     (let* ((db    (datashare:open-db configdat))
-				    (areas (or (configf:get-section configdat "areas") '())))
-			       ;;
-			       ;; first update the Sources
-			       ;;
-			       (for-each
-				(lambda (pkgitem)
-				  (let* ((pkg-path   (list (datashare:pkg-get-area  pkgitem)
-							   (datashare:pkg-get-version_name pkgitem)
-							   (datashare:pkg-get-iteration pkgitem)))
-					 (pkg-id     (datashare:pkg-get-id          pkgitem))
-					 (path       (datashare:lst->path pkg-path)))
-				    ;; (print "tree:add-node tb=" tb ", pkg-path=" pkg-path ", pkg-id=" pkg-id)
-				    (if (not (hash-table-ref/default srcdat path #f))
-					(tree:add-node tb "Packages" pkg-path userdata: (conc "pkg-id: " pkg-id)))
-				    ;; (print "path=" path " pkgitem=" pkgitem)
-				    (hash-table-set! srcdat path pkgitem)))
-				(datashare:get-pkgs db area-filter version-filter iter-filter))
-			       ;;
-			       ;; then update the installed
-			       ;;
-			       (for-each
-				(lambda (area)
-				  (let* ((path     (conc "/" (cadr area)))
-					 (fullpath (conc basepath path)))
-				    (if (not (hash-table-ref/default installed-dat path #f))
-					(tree:add-node tb2 "Installed" (datashare:path->lst path)))
-				    (hash-table-set! installed-dat path (datashare:pathdat-apply-heuristics configdat fullpath))))
-				areas)
-			       (sqlite3:finalize! db))))
-	   (apply          (iup:button "Apply"
-				       #:action
-				       (lambda (obj)
-					 (if curr-record
-					     (let* ((area        (datashare:pkg-get-area        curr-record))
-						    (stored-path (datashare:pkg-get-stored_path curr-record))
-						    (source-type (datashare:pkg-get-store_type  curr-record))
-						    (source-path (case source-type ;;  (equal? source-type "link"))
-								   ((link)(datashare:pkg-get-source-path curr-record))
-								   ((copy)stored-path)
-								   (else #f)))
-						    (dest-stub   (configf:lookup configdat "areas" area))
-						    (target-path (conc basepath "/" dest-stub)))
-					       (datashare:build-dir-make-link stored-path target-path)
-					       (print "Creating link from " stored-path " to " target-path)))))))
-      (iup:vbox 
-       (iup:hbox tb tb2)
-       (iup:frame 
-	#:title "Source Info"
-	(iup:vbox
-	 (iup:hbox (iup:button "Refresh" #:action refresh) apply)
-	 (iup:hbox (iup:label "Submitter: ") ;;  #:size label-size)
-		   submitter 
-		   (iup:label "Submitted on: ") ;;  #:size label-size)
-		   date-submitted)
-	 (iup:hbox (iup:label "Data stored: ")
-		   copy-link
-		   (iup:label "Quality: ")
-		   quality)
-	 (iup:hbox (iup:label "Comment: ")
-		   comment)))
-       (iup:frame
-	#:title "Installed Info"
-	(iup:vbox
-	 (iup:hbox (iup:label "Installed status/path: ") installed-status)))
-       )))))
-
-(define (datashare:manage-view configdat)
-  (iup:vbox
-   (iup:hbox 
-    (iup:button "Pushme"
-		#:expand "YES"
-		))))
-
-(define (datashare:gui configdat)
-  (iup:show
-   (iup:dialog 
-    #:title (conc "DataShare dashboard " (current-user-name) ":" (current-directory))   
-    #:menu (datashare:main-menu)
-    (let* ((tabs (iup:tabs
-		  #:tabchangepos-cb (lambda (obj curr prev)
-				      (set! *datashare:current-tab-number* curr))
-		  (datashare:publish-view configdat)
-		  (datashare:get-view configdat)
-		  (datashare:manage-view configdat)
-		  )))
-	;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
-	(iup:attribute-set! tabs "TABTITLE0" "Publish")
-	(iup:attribute-set! tabs "TABTITLE1" "Get")
-	(iup:attribute-set! tabs "TABTITLE2" "Manage")
-	;; (iup:attribute-set! tabs "BGCOLOR" "190 190 190")
-	tabs)))
-  (iup:main-loop))
-
-;;======================================================================
-;; MISC
-;;======================================================================
-
-
-(define (datashare:do-as-calling-user proc)
-  (let ((eid (current-effective-user-id))
-        (cid (current-user-id)))
-    (if (not (eq? eid cid)) ;; running suid
-            (set! (current-effective-user-id) cid))
-    ;; (print "running as " (current-effective-user-id))
-    (proc)
-    (if (not (eq? eid cid))
-        (set! (current-effective-user-id) eid))))
-
-(define (datashare:find name paths)
-  (if (null? paths)
-      #f
-      (let loop ((hed (car paths))
-		 (tal (cdr paths)))
-	(if (common:file-exists? (conc hed "/" name))
-	    hed
-	    (if (null? tal)
-		#f
-		(loop (car tal)(cdr tal)))))))
-
-;;======================================================================
-;; MAIN
-;;======================================================================
-
-(define (datashare:load-config exe-dir exe-name)
-  (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)
-	(make-hash-table))))
-
-(define (datashare:process-action configdat action . args)
-  (case (string->symbol action)
-    ((get)
-     (if (< (length args) 2)
-	 (begin 
-	   (print "ERROR: Missing arguments; " (string-intersperse args ", "))
-	   (exit 1))
-	 (let* ((basepath    (configf:lookup configdat "settings" "basepath"))
-		(db          (datashare:open-db configdat))
-		(area        (car args))
-		(version     (cadr args)) ;;    iteration
-		(remargs     (args:get-args args '("-i") '() args:arg-hash 0))
-		(iteration   (if (args:get-arg "-i")(string->number (args:get-arg "-i")) #f))
-		(curr-record (datashare:get-pkg db area version iteration: iteration)))
-	   (if (not curr-record)
-	       (begin
-		 (print "ERROR: No matching record found; area=" area ", version=" version ", iteration=" (if iteration iteration "(max)"))
-		 (exit 1))
-	       (let* ((stored-path (datashare:pkg-get-stored_path curr-record))
-		      (source-type (datashare:pkg-get-store_type  curr-record))
-		      (source-path (case source-type ;;  (equal? source-type "link"))
-				     ((link) (datashare:pkg-get-source-path curr-record))
-				     ((copy) stored-path)
-				     (else #f)))
-		      (dest-stub   (configf:lookup configdat "areas" area))
-		      (target-path (conc basepath "/" dest-stub)))
-		 (datashare:build-dir-make-link stored-path target-path)
-		 (datashare:record-pkg-ref db (datashare:pkg-get-id curr-record) target-path)
-		 (sqlite3:finalize! db)
-		 (print "Creating link from " stored-path " to " target-path))))))
-    ((publish)
-     (if (< (length args) 3)
-	 (begin 
-	   (print "ERROR: Missing arguments; " (string-intersperse args ", "))
-	   (exit 1))
-	 (let* ((srcpath  (list-ref args 0))
-		(areaname (list-ref args 1))
-		(version  (list-ref args 2))
-		(remargs  (args:get-args (drop args 2)
-					 '("-type" ;; link or copy (default is copy)
-					   "-m")
- 					 '()
- 					 args:arg-hash
- 					 0))
-		(publish-type (if (equal? (args:get-arg "-type") "link") 'link 'copy))
-		(comment      (or (args:get-arg "-m") ""))
-		(submitter    (current-user-name))
-		(quality      (args:get-arg "-quality"))
-		(publish-res  (datashare:publish configdat publish-type areaname version comment srcpath submitter quality)))
-	   (if (not (car publish-res))
-	       (begin
-		 (print "ERROR: " (cdr publish-res))
-		 (exit 1))))))
-    ((list-versions)
-     (let ((area-name (car args)) ;;      version patt   full print
-	   (remargs   (args:get-args args '("-vpatt") '("-full") args:arg-hash 0))
-	   (db        (datashare:open-db configdat))
-	   (versions  (datashare:get-versions-for-area db (car args) version-patt: (args:get-arg "-vpatt"))))
-       ;; (print "area-name=" area-name " args=" args " *args-hash*=" (hash-table->alist *args-hash*))
-       (map (lambda (x)
-	      (if (args:get-arg "-full")
-		  (format #t 
-			  "~10a~10a~4a~27a~30a\n"
-			  (vector-ref x 0)
-			  (vector-ref x 1) 
-			  (vector-ref x 2) 
-			  (conc "\"" (time->string (seconds->local-time (vector-ref x 3))) "\"")
-			  (conc "\"" (vector-ref x 4) "\""))
-		  (print (vector-ref x 0))))
-	    versions)
-       (sqlite3:finalize! db)))))
-
-;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION!
-(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.datasharerc")))
-  (if (common:file-exists? debugcontrolf)
-      (load debugcontrolf)))
-
-(define (main)
-  (let* ((args      (argv))
-	 (prog      (car args))
-	 (rema      (cdr args))
-	 (exe-name  (pathname-file (car (argv))))
-	 (exe-dir   (or (pathname-directory prog)
-			(datashare:find exe-name (string-split (get-environment-variable "PATH") ":"))))
-	 (configdat (datashare:load-config exe-dir exe-name)))
-    (cond
-     ;; one-word commands
-     ((eq? (length rema) 1)
-      (case (string->symbol (car rema))
-	((help -h -help --h --help)
-	 (print datashare:help))
-	((list-areas)
-	 (map print (datashare:get-areas configdat)))
-	(else
-	 (print "ERROR: Unrecognised command. Try \"datashare help\""))))
-     ;; multi-word commands
-     ((null? rema)(datashare:gui configdat))
-     ((>= (length rema) 2)
-      (apply datashare:process-action configdat (car rema)(cdr rema)))
-     (else (print "ERROR: Unrecognised command. Try \"datashare help\"")))))
-
-(main)

ADDED   datashare/datashare.scm
Index: datashare/datashare.scm
==================================================================
--- /dev/null
+++ datashare/datashare.scm
@@ -0,0 +1,825 @@
+
+;; Copyright 2006-2013, Matthew Welland.
+;; 
+;; This file is part of Megatest.
+;; 
+;;     Megatest is free software: you can redistribute it and/or modify
+;;     it under the terms of the GNU General Public License as published by
+;;     the Free Software Foundation, either version 3 of the License, or
+;;     (at your option) any later version.
+;; 
+;;     Megatest is distributed in the hope that it will be useful,
+;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;     GNU General Public License for more details.
+;; 
+;;     You should have received a copy of the GNU General Public License
+;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
+
+(use ssax)
+(use sxml-serializer)
+(use sxml-modifications)
+(use regex)
+(use srfi-69)
+(use regex-case)
+(use posix)
+(use json)
+(use csv)
+(use srfi-18)
+(use format)
+
+(require-library iup)
+(import (prefix iup iup:))
+(require-library ini-file)
+(import (prefix ini-file ini:))
+
+(use canvas-draw)
+(import canvas-draw-iup)
+
+(use sqlite3 srfi-1 posix regex regex-case srfi-69)
+(import (prefix sqlite3 sqlite3:))
+
+(declare (uses configf))
+(declare (uses tree))
+(declare (uses margs))
+;; (declare (uses dcommon))
+;; (declare (uses launch))
+;; (declare (uses gutils))
+;; (declare (uses db))
+;; (declare (uses synchash))
+;; (declare (uses server))
+;; (declare (uses megatest-version))
+;; (declare (uses tbd))
+
+(include "megatest-fossil-hash.scm")
+
+;;
+;; GLOBALS
+;;
+(define *datashare:current-tab-number* 0)
+(define *args-hash* (make-hash-table))
+(define datashare:help (conc "Usage: datashare [action [params ...]]
+
+Note: run datashare without parameters to start the gui.
+
+  list-areas                          : List the allowed areas
+
+  list-versions <area>                : List versions available in <area>
+         options : -full, -vpatt patt
+
+  publish <path> <area> <version>     : Publish data for area and with version
+
+  get <area> <version>                : Get a link to data, put the link in destpath
+         options : -i iteration
+
+  update <area>                       : Update the link to data to the latest iteration.
+
+Part of the Megatest tool suite.
+Learn more at http://www.kiatoa.com/fossils/megatest
+
+Version: " megatest-fossil-hash)) ;; "
+
+;;======================================================================
+;; RECORDS
+;;======================================================================
+
+;; make-vector-record "testing" datastore pkg id area version_name store_type copied source_path iteration submitter datetime storegrp datavol quality disk_id comment
+;; testing
+(define (make-datashare:pkg)(make-vector 15))
+(define-inline (datashare:pkg-get-id             vec)    (vector-ref  vec 0))
+(define-inline (datashare:pkg-get-area           vec)    (vector-ref  vec 1))
+(define-inline (datashare:pkg-get-version_name   vec)    (vector-ref  vec 2))
+(define-inline (datashare:pkg-get-store_type     vec)    (vector-ref  vec 3))
+(define-inline (datashare:pkg-get-copied         vec)    (vector-ref  vec 4))
+(define-inline (datashare:pkg-get-source_path    vec)    (vector-ref  vec 5))
+(define-inline (datashare:pkg-get-iteration      vec)    (vector-ref  vec 6))
+(define-inline (datashare:pkg-get-submitter      vec)    (vector-ref  vec 7))
+(define-inline (datashare:pkg-get-datetime       vec)    (vector-ref  vec 8))
+(define-inline (datashare:pkg-get-storegrp       vec)    (vector-ref  vec 9))
+(define-inline (datashare:pkg-get-datavol        vec)    (vector-ref  vec 10))
+(define-inline (datashare:pkg-get-quality        vec)    (vector-ref  vec 11))
+(define-inline (datashare:pkg-get-disk_id        vec)    (vector-ref  vec 12))
+(define-inline (datashare:pkg-get-comment        vec)    (vector-ref  vec 13))
+(define-inline (datashare:pkg-get-stored_path    vec)    (vector-ref  vec 14))
+(define-inline (datashare:pkg-set-id!            vec val)(vector-set! vec 0 val))
+(define-inline (datashare:pkg-set-area!          vec val)(vector-set! vec 1 val))
+(define-inline (datashare:pkg-set-version_name!  vec val)(vector-set! vec 2 val))
+(define-inline (datashare:pkg-set-store_type!    vec val)(vector-set! vec 3 val))
+(define-inline (datashare:pkg-set-copied!        vec val)(vector-set! vec 4 val))
+(define-inline (datashare:pkg-set-source_path!   vec val)(vector-set! vec 5 val))
+(define-inline (datashare:pkg-set-iteration!     vec val)(vector-set! vec 6 val))
+(define-inline (datashare:pkg-set-submitter!     vec val)(vector-set! vec 7 val))
+(define-inline (datashare:pkg-set-datetime!      vec val)(vector-set! vec 8 val))
+(define-inline (datashare:pkg-set-storegrp!      vec val)(vector-set! vec 9 val))
+(define-inline (datashare:pkg-set-datavol!       vec val)(vector-set! vec 10 val))
+(define-inline (datashare:pkg-set-quality!       vec val)(vector-set! vec 11 val))
+(define-inline (datashare:pkg-set-disk_id!       vec val)(vector-set! vec 12 val))
+(define-inline (datashare:pkg-set-comment!       vec val)(vector-set! vec 13 val))
+(define-inline (datashare:pkg-set-stored_path!   vec val)(vector-set! vec 14 val))
+
+;;======================================================================
+;; DB
+;;======================================================================
+
+(define (datashare:initialize-db db)
+  (for-each
+   (lambda (qry)
+     (sqlite3:execute db qry))
+   (list 
+    "CREATE TABLE pkgs 
+         (id           INTEGER PRIMARY KEY,
+          area         TEXT,
+          version_name TEXT,
+          store_type   TEXT DEFAULT 'copy',
+          copied       INTEGER DEFAULT 0,
+          source_path  TEXT,
+          stored_path  TEXT,
+          iteration    INTEGER DEFAULT 0,
+          submitter    TEXT,
+          datetime     TIMESTAMP DEFAULT (strftime('%s','now')),
+          storegrp     TEXT,
+          datavol      INTEGER,
+          quality      TEXT,
+          disk_id      INTEGER,
+          comment      TEXT);"
+    "CREATE TABLE refs
+         (id        INTEGER PRIMARY KEY,
+          pkg_id    INTEGER,
+          destlink  TEXT);"
+    "CREATE TABLE disks
+         (id         INTEGER PRIMARY KEY,
+          storegrp   TEXT,
+          path       TEXT);")))
+
+(define (datashare:register-data db area version-name store-type submitter quality source-path comment)
+  (let ((iter-qry       (sqlite3:prepare db "SELECT max(iteration) FROM pkgs WHERE area=? AND version_name=?;"))
+	(next-iteration 0))
+    (sqlite3:with-transaction
+     db
+     (lambda ()
+       (sqlite3:for-each-row
+	(lambda (iteration)
+	  (if (and (number? iteration)
+		   (>= iteration next-iteration))
+	      (set! next-iteration (+ iteration 1))))
+	iter-qry area version-name)
+       ;; now store the data
+       (sqlite3:execute db "INSERT INTO pkgs (area,version_name,iteration,store_type,submitter,source_path,quality,comment) 
+                                 VALUES (?,?,?,?,?,?,?,?);"
+			area version-name next-iteration (conc store-type) submitter source-path quality comment)))
+    (sqlite3:finalize! iter-qry)
+    next-iteration))
+
+(define (datashare:get-id db area version-name iteration)
+  (let ((res #f))
+    (sqlite3:for-each-row
+     (lambda (id)
+       (set! res id))
+     db
+     "SELECT id FROM pkgs WHERE area=? AND version_name=? AND iteration=?;"
+     area version-name iteration)
+    res))
+
+(define (datashare:set-stored-path db id path)
+  (sqlite3:execute db "UPDATE pkgs SET stored_path=? WHERE id=?;" path id))
+
+(define (datashare:set-copied db id value)
+  (sqlite3:execute db "UPDATE pkgs SET copied=? WHERE id=?;" value id))
+  
+(define (datashare:get-pkg-record db area version-name iteration)
+  (let ((res #f))
+    (sqlite3:for-each-row
+     (lambda (a . b)
+       (set! res (apply vector a b)))
+     db 
+     "SELECT * FROM pkgs WHERE area=? AND version_name=? AND iteration=?;"
+     area 
+     version-name
+     iteration)
+    res))
+
+;; take version-name iteration and register or update "lastest/0"
+;;
+(define (datashare:set-latest db id area version-name iteration)
+  (let* ((rec         (datashare:get-pkg-record db area version-name iteration))
+	 (latest-id   (datashare:get-id db area "latest" 0))
+	 (stored-path (datashare:pkg-get-stored_path rec)))
+    (if latest-id ;; have a record - bump the link pointer
+	(datashare:set-stored-path db latest-id stored-path)
+	(datashare:register-data db area "latest" 'link "auto" "na" stored-path "latest data"))))
+
+;; set a package ref, this is the location where the link back to the stored data 
+;; is put. 
+;;
+;; if there is nothing at that location then the record can be removed
+;; if there are no refs for a particular pkg-id then that pkg-id is a 
+;; candidate for removal
+;;
+(define (datashare:record-pkg-ref db pkg-id dest-link)
+  (sqlite3:execute db "INSERT INTO refs (pkg_id,destlink) VALUES (?,?);" pkg-id dest-link))
+  
+(define (datashare:count-refs db pkg-id)
+  (let ((res 0))
+    (sqlite3:for-each-row
+     (lambda (count)
+       (set! res count))
+     db
+     "SELECT count(id) FROM refs WHERE pkg_id=?;"
+     pkg-id)
+    res))
+
+;; Create the sqlite db
+(define (datashare:open-db configdat) 
+  (let ((path (configf:lookup configdat "database" "location")))
+    (if (and path
+	     (directory? path)
+	     (file-read-access? path))
+	(let* ((dbpath    (conc path "/datashare.db"))
+	       (writeable (file-write-access? dbpath))
+	       (dbexists  (common:file-exists? dbpath))
+	       (handler   (make-busy-timeout 136000)))
+	  (handle-exceptions
+	   exn
+	   (begin
+	     (debug:print 2 *default-log-port* "ERROR: problem accessing db " dbpath
+			  ((condition-property-accessor 'exn 'message) exn))
+	     (exit))
+	   (set! db (sqlite3:open-database dbpath)))
+	  (if *db-write-access* (sqlite3:set-busy-handler! db handler))
+	  (if (not dbexists)
+	      (begin
+		(datashare:initialize-db db)))
+	  db)
+	(print "ERROR: invalid path for storing database: " path))))
+
+(define (open-run-close-exception-handling proc idb . params)
+  (handle-exceptions
+   exn
+   (let ((sleep-time (random 30))
+         (err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
+     (case err-status
+       ((busy)
+        (thread-sleep! sleep-time))
+       (else
+        (print "EXCEPTION: database overloaded or unreadable.")
+        (print " message: " ((condition-property-accessor 'exn 'message) exn))
+        (print "exn=" (condition->list exn))
+        (print " status:  " ((condition-property-accessor 'sqlite3 'status) exn))
+        (print-call-chain (current-error-port))
+        (thread-sleep! sleep-time)
+        (print "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up")))
+     (apply open-run-close-exception-handling proc idb params))
+   (apply open-run-close-no-exception-handling proc idb params)))
+
+(define (open-run-close-no-exception-handling  proc idb . params)
+  ;; (print "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params)
+  (let* ((db (cond
+	      ((sqlite3:database? idb)     idb)
+	      ((not idb)                   (print "ERROR: cannot open-run-close with #f anymore"))
+	      ((procedure? idb)            (idb))
+	      (else                        (print "ERROR: cannot open-run-close with #f anymore"))))
+	 (res #f))
+    (set! res (apply proc db params))
+    (if (not idb)(sqlite3:finalize! dbstruct))
+    ;; (print "open-run-close-no-exception-handling END" )
+    res))
+
+(define open-run-close open-run-close-no-exception-handling)
+
+(define (datashare:get-pkgs db area-filter version-filter iter-filter)
+  (let ((res '()))
+    (sqlite3:for-each-row ;; replace with fold ...
+     (lambda (a . b)
+       (set! res (cons (list->vector (cons a b)) res)))
+     db 
+     (conc "SELECT id,area,version_name,store_type,copied,source_path,iteration,submitter,datetime,storegrp,datavol,quality,disk_id,comment,stored_path "
+	   " FROM pkgs WHERE area like ? AND version_name LIKE ? AND iteration " iter-filter ";")
+     area-filter version-filter)
+    (reverse res)))
+
+(define (datashare:get-pkg db area-name version-name #!key (iteration #f))
+  (let ((dat '())
+	(res #f))
+    (sqlite3:for-each-row ;; replace with fold ...
+     (lambda (a . b)
+       (set! dat (cons (list->vector (cons a b)) dat)))
+     db 
+     (conc "SELECT id,area,version_name,store_type,copied,source_path,iteration,submitter,datetime,storegrp,datavol,quality,disk_id,comment,stored_path "
+	   " FROM pkgs WHERE area=? AND version_name=? ORDER BY iteration ASC;")
+     area-name version-name)
+    ;; now filter for iteration, either max if #f or specific one
+    (if (null? dat)
+	#f
+	(let loop ((hed (car dat))
+		   (tal (cdr dat))
+		   (cur 0))
+	  (let ((itr (datashare:pkg-get-iteration hed)))
+	    (if (equal? itr iteration) ;; this is the one if iteration is specified
+		hed
+		(if (null? tal)
+		    hed
+		    (loop (car tal)(cdr tal)))))))))
+
+(define (datashare:get-versions-for-area db area-name #!key (version-patt #f))
+  (let ((res '())
+	(data (make-hash-table)))
+    (sqlite3:for-each-row
+     (lambda (version-name submitter iteration submitted-time comment)
+       ;;                                              0           1         2           3           4
+       (hash-table-set! data version-name (vector version-name submitter iteration submitted-time comment)))
+     db 
+     "SELECT version_name,submitter,iteration,datetime,comment FROM pkgs WHERE area='megatest' AND version_name != 'latest' AND version_name LIKE ? ORDER BY datetime asc;"
+     (or version-patt "%"))
+    (map (lambda (x)(hash-table-ref data x))(sort (hash-table-keys data) string-ci>=))))
+
+;;======================================================================
+;; DATA IMPORT/EXPORT
+;;======================================================================
+
+(define (datashare:import-data configdat source-path dest-path area version iteration)
+  (let* ((space-avail (car dest-path))
+	 (disk-path   (cdr dest-path))
+	 (targ-path   (conc disk-path "/" area "/" version "/" iteration))
+	 (id          (datashare:get-id db area version iteration))
+	 (db          (datashare:open-db configdat)))
+    (if (> space-avail 10000) ;; dumb heuristic
+	(begin
+	  (create-directory targ-path #t)
+	  (datashare:set-stored-path db id targ-path)
+	  (print "Running command: rsync -av " source-path "/ " targ-path "/")
+	  (let ((th1 (make-thread (lambda ()
+				    (let ((pid (process-run "rsync" (list "-av" (conc source-path "/") (conc targ-path "/")))))
+				      (process-wait pid)
+				      (datashare:set-copied db id "yes")
+				      (sqlite3:finalize! db)))
+				   "Data copy")))
+	    (thread-start! th1))
+	  #t)
+	(begin
+	  (print "ERROR: Not enough space in storage area " dest-path)
+	  (datashare:set-copied db id "no")
+	  (sqlite3:finalize! db)
+	  #f))))
+
+(define (datashare:get-areas configdat)
+  (let* ((areadat (configf:get-section configdat "areas"))
+	 (areas   (if areadat (map car areadat) '())))
+    areas))
+
+(define (datashare:publish configdat publish-type area-name version comment spath submitter quality)
+  ;; input checks
+  (cond 
+   ((not (member area-name (datashare:get-areas configdat)))
+    (cons #f (conc "Illegal area name \"" area-name "\"")))
+   (else
+    (let ((db          (datashare:open-db configdat))
+	  (iteration   (datashare:register-data db area-name version publish-type submitter quality spath comment))
+	  (dest-store  (datashare:get-best-storage configdat)))
+      (if iteration
+	  (if (eq? 'copy publish-type)
+	      (begin
+		(datashare:import-data configdat spath dest-store area-name version iteration)
+		(let ((id (datashare:get-id db area-name version iteration)))
+		  (datashare:set-latest db id area-name version iteration)))
+	      (let ((id (datashare:get-id db area-name version iteration)))
+		(datashare:set-stored-path db id spath)
+		(datashare:set-copied db id "yes")
+		(datashare:set-copied db id "n/a")
+		(datashare:set-latest db id area-name version iteration)))
+	  (print "ERROR: Failed to get an iteration number"))
+      (sqlite3:finalize! db)
+      (cons #t "Successfully saved data")))))
+
+(define (datashare:get-best-storage configdat)
+  (let* ((storage     (configf:lookup configdat "settings" "storage"))
+	 (store-areas (if storage (string-split storage) '())))
+    (print "Looking for available space in " store-areas)
+    (datashare:find-most-space store-areas)))
+
+;; (string->number (list-ref (with-input-from-pipe "df -B1000000 /tmp" (lambda ()(read-line)(string-split (read-line)))) 3))
+
+(define (datashare:find-most-space paths)
+  (fold (lambda (area res)
+	  ;; (print "area=" area " res=" res)
+	  (let ((maxspace (car res))
+		(currpath (cdr res)))
+	    ;; (print currpath " " maxspace)
+	    (if (file-write-access? area)
+		(let ((currspace (string->number
+				  (list-ref
+				   (with-input-from-pipe 
+				    ;; (conc "df --output=avail " area)
+				    (conc "df -B1000000 " area)
+				    ;; (lambda ()(read)(read))
+				    (lambda ()(read-line)(string-split (read-line))))
+				   3))))
+		  (if (> currspace maxspace) 
+		      (cons currspace area)
+		      res))
+		res)))
+	(cons 0 #f)
+	paths))
+
+;; remove existing link and if possible ...
+;; create path to next of tip of target, create link back to source
+(define (datashare:build-dir-make-link source target)
+  (if (common:file-exists? target)(datashare:backup-move target))
+  (create-directory (pathname-directory target) #t)
+  (create-symbolic-link source target))
+
+(define (datashare:backup-move path)
+  (let* ((trashdir  (conc (pathname-directory path) "/.trash"))
+	 (trashfile (conc trashdir "/" (current-seconds) "-" (pathname-file path))))
+    (create-directory trashdir #t)
+    (if (directory? path)
+	(system (conc "mv " path " " trashfile))
+	(file-move path trash-file))))
+
+;;======================================================================
+;; GUI
+;;======================================================================
+
+;; The main menu 
+(define (datashare:main-menu)
+  (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top)
+   (iup:menu-item "Files" (iup:menu   ;; Note that you can use either #:action or action: for options
+		       (iup:menu-item "Open"  action: (lambda (obj)
+							(iup:show (iup:file-dialog))
+							(print "File->open " obj)))
+		       (iup:menu-item "Save"  #:action (lambda (obj)(print "File->save " obj)))
+		       (iup:menu-item "Exit"  #:action (lambda (obj)(exit)))))
+   (iup:menu-item "Tools" (iup:menu
+		       (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah")))
+		       ;; (iup:menu-item "Show dialog"     #:action (lambda (obj)
+		       ;;  					   (show message-window
+		       ;;  					     #:modal? #t
+		       ;;  					     ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current
+		       ;;  					     ;; #:x 'mouse
+		       ;;  					     ;; #:y 'mouse
+		       ;;  )					     
+		       ))))
+
+(define (datashare:publish-view configdat)
+  ;; (pp (hash-table->alist configdat))
+  (let* ((areas       (configf:get-section configdat "areas"))
+	 (label-size  "70x")
+	 (areas-sel   (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES"))
+	 (version-tb  (iup:textbox #:expand "HORIZONTAL")) ;;  #:size "50x"))
+	 (areas-sel   (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES"))
+	 (component   (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES" ))
+	 (version-val (iup:textbox #:expand "HORIZONTAL" #:size "50x"))
+	 ;; (copy-link   (iup:toggle  #:expand "HORIZONTAL"))
+	 ;; (iteration   (iup:textbox #:expand "YES" #:size "20x"))
+	 ;; (iteration   (iup:textbox #:expand "HORIZONTAL" #:size "20x"))
+	 (area-filter (iup:textbox #:expand "HORIZONTAL" #:value "%"))
+	 (comment-tb  (iup:textbox #:expand "YES" #:multiline "YES"))
+	 (source-tb   (iup:textbox #:expand "HORIZONTAL"
+				   #:value (or (configf:lookup configdat "settings" "basepath")
+					       "")))
+	 (publish     (lambda (publish-type)
+			(let* ((area-num    (or (string->number (iup:attribute areas-sel "VALUE")) 0))
+			       (area-dat    (if (> area-num 0)(list-ref areas (- area-num 1))'("NOT SELECTED" "NOT SELECTED")))
+			       (area-path   (cadr area-dat))
+			       (area-name   (car  area-dat))
+			       (version     (iup:attribute version-tb "VALUE"))
+			       (comment     (iup:attribute comment-tb "VALUE"))
+			       (spath       (iup:attribute source-tb  "VALUE"))
+			       (submitter   (current-user-name))
+			       (quality     2))
+			  (datashare:publish configdat publish-type area-name version comment spath submitter quality))))
+	 (copy        (iup:button "Copy and Publish"
+				  #:expand "HORIZONTAL"
+				  #:action (lambda (obj)
+					     (publish 'copy))))
+	 (link        (iup:button "Link and Publish"
+				  #:expand "HORIZONTAL"
+				  #:action (lambda (obj)
+					     (publish 'link))))
+	 (browse-btn  (iup:button "Browse"
+				  #:size "40x"
+				  #:action (lambda (obj)
+					     (let* ((fd  (iup:file-dialog #:dialogtype "DIR"))
+						    (top (iup:show fd #:modal? "YES")))
+					       (iup:attribute-set! source-tb "VALUE"
+								   (iup:attribute fd "VALUE"))
+					       (iup:destroy! fd))))))
+    (print "areas")
+    ;; (pp areas)
+    (fold (lambda (areadat num)
+	    ;; (print "Adding num=" num ", areadat=" areadat)
+	    (iup:attribute-set! areas-sel (conc num) (car areadat))
+	    (+ 1 num))
+	  1 areas)
+    (iup:vbox
+     (iup:hbox (iup:label "Area:"        #:size label-size) ;; area-filter 
+	       areas-sel)
+     (iup:hbox (iup:label "Version:"     #:size label-size)   version-tb)
+     ;; (iup:hbox (iup:label "Link only"    #:size label-size)   copy-link)
+     ;; 	       (iup:label "Iteration:")   iteration)
+     (iup:hbox (iup:label "Comment:"     #:size label-size)   comment-tb)
+     (iup:hbox (iup:label "Source base path:" #:size label-size)   source-tb browse-btn)
+     (iup:hbox copy link))))
+
+(define (datashare:lst->path pathlst)
+  (conc "/" (string-intersperse (map conc pathlst) "/")))
+
+(define (datashare:path->lst path)
+  (string-split path "/"))
+
+(define (datashare:pathdat-apply-heuristics configdat path)
+  (cond
+   ((common:file-exists? path) "found")
+   (else (conc path " not installed"))))
+
+(define (datashare:get-view configdat)
+  (iup:vbox
+   (iup:hbox
+    (let* ((label-size     "60x")
+	   ;; filter elements
+	   (area-filter    "%")
+	   (version-filter "%")
+	   (iter-filter    ">= 0")
+	   ;; reverse lookup from path to data for src and installed
+	   (srcdat         (make-hash-table)) ;; reverse lookup
+	   (installed-dat  (make-hash-table))
+	   ;; config values
+	   (basepath       (configf:lookup configdat "settings" "basepath"))
+	   ;; gui elements
+	   (submitter      (iup:label "" #:expand "HORIZONTAL"))
+	   (date-submitted (iup:label "" #:expand "HORIZONTAL"))
+	   (comment        (iup:label "" #:expand "HORIZONTAL"))
+	   (copy-link      (iup:label "" #:expand "HORIZONTAL"))
+	   (quality        (iup:label "" #:expand "HORIZONTAL"))
+	   (installed-status (iup:label "" #:expand "HORIZONTAL"))
+	   ;; misc 
+	   (curr-record    #f)
+	   ;; (source-data    (iup:label "" #:expand "HORIZONTAL"))
+	   (tb             (iup:treebox
+			    #:value 0
+			    #:name "Packages"
+			    #:expand "YES"
+			    #:addexpanded "NO"
+			    #:selection-cb
+			    (lambda (obj id state)
+			      ;; (print "obj: " obj ", id: " id ", state: " state)
+			      (let* ((path   (datashare:lst->path (cdr (tree:node->path obj id))))
+				     (record (hash-table-ref/default srcdat path #f)))
+				(if record
+				    (begin
+				      (set! curr-record record)
+				      (iup:attribute-set! submitter      "TITLE" (datashare:pkg-get-submitter record))
+				      (iup:attribute-set! date-submitted "TITLE" (time->string (seconds->local-time (datashare:pkg-get-datetime record))))
+				      (iup:attribute-set! comment        "TITLE" (datashare:pkg-get-comment record))
+				      (iup:attribute-set! quality        "TITLE" (datashare:pkg-get-quality record))
+				      (iup:attribute-set! copy-link      "TITLE" (datashare:pkg-get-store_type record))
+				      ))
+				;; (print  "id=" id " path=" path " record=" record);; (tree:node->path obj id) " run-id: " run-id)
+				))))
+	   (tb2             (iup:treebox
+			    #:value 0
+			    #:name "Installed"
+			    #:expand "YES"
+			    #:addexpanded "NO"
+			    #:selection-cb
+			    (lambda (obj id state)
+			      ;; (print "obj: " obj ", id: " id ", state: " state)
+			      (let* ((path   (datashare:lst->path (cdr (tree:node->path obj id))))
+				     (status (hash-table-ref/default installed-dat path #f)))
+				(iup:attribute-set! installed-status "TITLE" (if status status ""))
+				))))
+	   (refresh        (lambda (obj)
+			     (let* ((db    (datashare:open-db configdat))
+				    (areas (or (configf:get-section configdat "areas") '())))
+			       ;;
+			       ;; first update the Sources
+			       ;;
+			       (for-each
+				(lambda (pkgitem)
+				  (let* ((pkg-path   (list (datashare:pkg-get-area  pkgitem)
+							   (datashare:pkg-get-version_name pkgitem)
+							   (datashare:pkg-get-iteration pkgitem)))
+					 (pkg-id     (datashare:pkg-get-id          pkgitem))
+					 (path       (datashare:lst->path pkg-path)))
+				    ;; (print "tree:add-node tb=" tb ", pkg-path=" pkg-path ", pkg-id=" pkg-id)
+				    (if (not (hash-table-ref/default srcdat path #f))
+					(tree:add-node tb "Packages" pkg-path userdata: (conc "pkg-id: " pkg-id)))
+				    ;; (print "path=" path " pkgitem=" pkgitem)
+				    (hash-table-set! srcdat path pkgitem)))
+				(datashare:get-pkgs db area-filter version-filter iter-filter))
+			       ;;
+			       ;; then update the installed
+			       ;;
+			       (for-each
+				(lambda (area)
+				  (let* ((path     (conc "/" (cadr area)))
+					 (fullpath (conc basepath path)))
+				    (if (not (hash-table-ref/default installed-dat path #f))
+					(tree:add-node tb2 "Installed" (datashare:path->lst path)))
+				    (hash-table-set! installed-dat path (datashare:pathdat-apply-heuristics configdat fullpath))))
+				areas)
+			       (sqlite3:finalize! db))))
+	   (apply          (iup:button "Apply"
+				       #:action
+				       (lambda (obj)
+					 (if curr-record
+					     (let* ((area        (datashare:pkg-get-area        curr-record))
+						    (stored-path (datashare:pkg-get-stored_path curr-record))
+						    (source-type (datashare:pkg-get-store_type  curr-record))
+						    (source-path (case source-type ;;  (equal? source-type "link"))
+								   ((link)(datashare:pkg-get-source-path curr-record))
+								   ((copy)stored-path)
+								   (else #f)))
+						    (dest-stub   (configf:lookup configdat "areas" area))
+						    (target-path (conc basepath "/" dest-stub)))
+					       (datashare:build-dir-make-link stored-path target-path)
+					       (print "Creating link from " stored-path " to " target-path)))))))
+      (iup:vbox 
+       (iup:hbox tb tb2)
+       (iup:frame 
+	#:title "Source Info"
+	(iup:vbox
+	 (iup:hbox (iup:button "Refresh" #:action refresh) apply)
+	 (iup:hbox (iup:label "Submitter: ") ;;  #:size label-size)
+		   submitter 
+		   (iup:label "Submitted on: ") ;;  #:size label-size)
+		   date-submitted)
+	 (iup:hbox (iup:label "Data stored: ")
+		   copy-link
+		   (iup:label "Quality: ")
+		   quality)
+	 (iup:hbox (iup:label "Comment: ")
+		   comment)))
+       (iup:frame
+	#:title "Installed Info"
+	(iup:vbox
+	 (iup:hbox (iup:label "Installed status/path: ") installed-status)))
+       )))))
+
+(define (datashare:manage-view configdat)
+  (iup:vbox
+   (iup:hbox 
+    (iup:button "Pushme"
+		#:expand "YES"
+		))))
+
+(define (datashare:gui configdat)
+  (iup:show
+   (iup:dialog 
+    #:title (conc "DataShare dashboard " (current-user-name) ":" (current-directory))   
+    #:menu (datashare:main-menu)
+    (let* ((tabs (iup:tabs
+		  #:tabchangepos-cb (lambda (obj curr prev)
+				      (set! *datashare:current-tab-number* curr))
+		  (datashare:publish-view configdat)
+		  (datashare:get-view configdat)
+		  (datashare:manage-view configdat)
+		  )))
+	;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
+	(iup:attribute-set! tabs "TABTITLE0" "Publish")
+	(iup:attribute-set! tabs "TABTITLE1" "Get")
+	(iup:attribute-set! tabs "TABTITLE2" "Manage")
+	;; (iup:attribute-set! tabs "BGCOLOR" "190 190 190")
+	tabs)))
+  (iup:main-loop))
+
+;;======================================================================
+;; MISC
+;;======================================================================
+
+
+(define (datashare:do-as-calling-user proc)
+  (let ((eid (current-effective-user-id))
+        (cid (current-user-id)))
+    (if (not (eq? eid cid)) ;; running suid
+            (set! (current-effective-user-id) cid))
+    ;; (print "running as " (current-effective-user-id))
+    (proc)
+    (if (not (eq? eid cid))
+        (set! (current-effective-user-id) eid))))
+
+(define (datashare:find name paths)
+  (if (null? paths)
+      #f
+      (let loop ((hed (car paths))
+		 (tal (cdr paths)))
+	(if (common:file-exists? (conc hed "/" name))
+	    hed
+	    (if (null? tal)
+		#f
+		(loop (car tal)(cdr tal)))))))
+
+;;======================================================================
+;; MAIN
+;;======================================================================
+
+(define (datashare:load-config exe-dir exe-name)
+  (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)
+	(make-hash-table))))
+
+(define (datashare:process-action configdat action . args)
+  (case (string->symbol action)
+    ((get)
+     (if (< (length args) 2)
+	 (begin 
+	   (print "ERROR: Missing arguments; " (string-intersperse args ", "))
+	   (exit 1))
+	 (let* ((basepath    (configf:lookup configdat "settings" "basepath"))
+		(db          (datashare:open-db configdat))
+		(area        (car args))
+		(version     (cadr args)) ;;    iteration
+		(remargs     (args:get-args args '("-i") '() args:arg-hash 0))
+		(iteration   (if (args:get-arg "-i")(string->number (args:get-arg "-i")) #f))
+		(curr-record (datashare:get-pkg db area version iteration: iteration)))
+	   (if (not curr-record)
+	       (begin
+		 (print "ERROR: No matching record found; area=" area ", version=" version ", iteration=" (if iteration iteration "(max)"))
+		 (exit 1))
+	       (let* ((stored-path (datashare:pkg-get-stored_path curr-record))
+		      (source-type (datashare:pkg-get-store_type  curr-record))
+		      (source-path (case source-type ;;  (equal? source-type "link"))
+				     ((link) (datashare:pkg-get-source-path curr-record))
+				     ((copy) stored-path)
+				     (else #f)))
+		      (dest-stub   (configf:lookup configdat "areas" area))
+		      (target-path (conc basepath "/" dest-stub)))
+		 (datashare:build-dir-make-link stored-path target-path)
+		 (datashare:record-pkg-ref db (datashare:pkg-get-id curr-record) target-path)
+		 (sqlite3:finalize! db)
+		 (print "Creating link from " stored-path " to " target-path))))))
+    ((publish)
+     (if (< (length args) 3)
+	 (begin 
+	   (print "ERROR: Missing arguments; " (string-intersperse args ", "))
+	   (exit 1))
+	 (let* ((srcpath  (list-ref args 0))
+		(areaname (list-ref args 1))
+		(version  (list-ref args 2))
+		(remargs  (args:get-args (drop args 2)
+					 '("-type" ;; link or copy (default is copy)
+					   "-m")
+ 					 '()
+ 					 args:arg-hash
+ 					 0))
+		(publish-type (if (equal? (args:get-arg "-type") "link") 'link 'copy))
+		(comment      (or (args:get-arg "-m") ""))
+		(submitter    (current-user-name))
+		(quality      (args:get-arg "-quality"))
+		(publish-res  (datashare:publish configdat publish-type areaname version comment srcpath submitter quality)))
+	   (if (not (car publish-res))
+	       (begin
+		 (print "ERROR: " (cdr publish-res))
+		 (exit 1))))))
+    ((list-versions)
+     (let ((area-name (car args)) ;;      version patt   full print
+	   (remargs   (args:get-args args '("-vpatt") '("-full") args:arg-hash 0))
+	   (db        (datashare:open-db configdat))
+	   (versions  (datashare:get-versions-for-area db (car args) version-patt: (args:get-arg "-vpatt"))))
+       ;; (print "area-name=" area-name " args=" args " *args-hash*=" (hash-table->alist *args-hash*))
+       (map (lambda (x)
+	      (if (args:get-arg "-full")
+		  (format #t 
+			  "~10a~10a~4a~27a~30a\n"
+			  (vector-ref x 0)
+			  (vector-ref x 1) 
+			  (vector-ref x 2) 
+			  (conc "\"" (time->string (seconds->local-time (vector-ref x 3))) "\"")
+			  (conc "\"" (vector-ref x 4) "\""))
+		  (print (vector-ref x 0))))
+	    versions)
+       (sqlite3:finalize! db)))))
+
+;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION!
+(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.datasharerc")))
+  (if (common:file-exists? debugcontrolf)
+      (load debugcontrolf)))
+
+(define (main)
+  (let* ((args      (argv))
+	 (prog      (car args))
+	 (rema      (cdr args))
+	 (exe-name  (pathname-file (car (argv))))
+	 (exe-dir   (or (pathname-directory prog)
+			(datashare:find exe-name (string-split (get-environment-variable "PATH") ":"))))
+	 (configdat (datashare:load-config exe-dir exe-name)))
+    (cond
+     ;; one-word commands
+     ((eq? (length rema) 1)
+      (case (string->symbol (car rema))
+	((help -h -help --h --help)
+	 (print datashare:help))
+	((list-areas)
+	 (map print (datashare:get-areas configdat)))
+	(else
+	 (print "ERROR: Unrecognised command. Try \"datashare help\""))))
+     ;; multi-word commands
+     ((null? rema)(datashare:gui configdat))
+     ((>= (length rema) 2)
+      (apply datashare:process-action configdat (car rema)(cdr rema)))
+     (else (print "ERROR: Unrecognised command. Try \"datashare help\"")))))
+
+(main)

Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -23,1772 +23,150 @@
 ;;======================================================================
 
 ;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc
 
 (use (srfi 18) extras tcp stack)
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records matchable)
+(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest
+     base64 format dot-locking z3 typed-records matchable)
 (import (prefix sqlite3 sqlite3:))
 (import (prefix base64 base64:))
 
 (declare (unit db))
 (declare (uses common))
-(declare (uses keys))
-(declare (uses ods))
 (declare (uses client))
 (declare (uses mt))
+
+(declare (uses commonmod))
+(import commonmod)
+
+(declare (uses configfmod))
+(import configfmod)
+
+(declare (uses dbmod))
+(import dbmod)
+
+(declare (uses servermod))
+(import servermod)
 
 (include "common_records.scm")
 (include "db_records.scm")
 (include "key_records.scm")
 (include "run_records.scm")
 
-(define *number-of-writes* 0)
-(define *number-non-write-queries* 0)
-
-;;======================================================================
-;;  R E C O R D S
-;;======================================================================
-
-;; each db entry is a pair ( db . dbfilepath )
-;; I propose this record evolves into the area record
-;;
-(defstruct dbr:dbstruct 
-  (tmpdb       #f)
-  (dbstack     #f) ;; stack for tmp db handles, do not initialize with a stack
-  (mtdb        #f)
-  (refndb      #f)
-  (homehost    #f) ;; not used yet
-  (on-homehost #f) ;; not used yet
-  (read-only   #f)
-  (stmt-cache  (make-hash-table))
-  )                ;; goal is to converge on one struct for an area but for now it is too confusing
-  
-
-;; record for keeping state,status and count for doing roll-ups in
-;; iterated tests
-;;
-(defstruct dbr:counts
-  (state #f)
-  (status #f)
-  (count  0)) 
-
-;;======================================================================
-;; alist-of-alists
-;;======================================================================
-;; 
-;; (define (db:aa-set! dat key1 key2 val)
-;;   (let loop ((
-
-;;======================================================================
-;; hash of hashs
-;;======================================================================
-
-
-(define (db:hoh-set! dat key1 key2 val)
-  (let* ((subhash (hash-table-ref/default dat key1 #f)))
-    (if subhash
-	(hash-table-set! subhash key2 val)
-	(begin
-	  (hash-table-set! dat key1 (make-hash-table))
-	  (db:hoh-set! dat key1 key2 val)))))
-
-(define (db:hoh-get dat key1 key2)
-  (let* ((subhash (hash-table-ref/default dat key1 #f)))
-    (and subhash
-	 (hash-table-ref/default subhash key2 #f))))
-
-(define (db:get-cache-stmth dbstruct db stmt)
-  (let* ((stmt-cache        (dbr:dbstruct-stmt-cache dbstruct))
-	 (stmth             (db:hoh-get stmt-cache db stmt)))
-    (or stmth
-	(let* ((newstmth (sqlite3:prepare db stmt)))
-	  (db:hoh-set! stmt-cache db stmt newstmth)
-	  newstmth))))
-
-;;======================================================================
-;; SQLITE3 HELPERS
-;;======================================================================
-
-(define (db:general-sqlite-error-dump exn stmt . params)
-  (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) ;; RADT ... how does this work?
-    ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn)
-    ;; (print "err-status: " err-status)
-    (debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn))
-    (print-call-chain (current-error-port))))
-
-;; convert to -inline 
-;;
-(define (db:first-result-default db stmt default . params)
-  (handle-exceptions
-   exn
-   (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
-     ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn)
-     (if (eq? err-status 'done)
-	 default
-	 (begin
-	   (debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
-	   (print-call-chain (current-error-port))
-	   default)))
-   (apply sqlite3:first-result db stmt params)))
-
-;; Get/open a database
-;;    if run-id => get run specific db
-;;    if #f     => get main db
-;;    if db already open - return inmem
-;;    if db not open, open inmem, rundb and sync then return inmem
-;;    inuse gets set automatically for rundb's
-;;
-(define (db:get-db dbstruct) ;;  run-id) 
-  (if (stack? (dbr:dbstruct-dbstack dbstruct))
-      (if (stack-empty? (dbr:dbstruct-dbstack dbstruct))
-          (let ((newdb (db:open-megatest-db path: (db:dbfile-path))))
-            ;; (stack-push! (dbr:dbstruct-dbstack dbstruct) newdb)
-            newdb)
-          (stack-pop! (dbr:dbstruct-dbstack dbstruct)))
-      (db:open-db dbstruct)))
-
-;; ;; legacy handling of structure for managing db's. Refactor this into dbr:?
-(define (db:dbdat-get-db dbdat)
-  (if (pair? dbdat)
-      (car dbdat)
-      dbdat))
-
-(define (db:dbdat-get-path dbdat)
-  (if (pair? dbdat)
-      (cdr dbdat)
-      #f))
-
-(define-inline (db:generic-error-printout exn . message)
-  (print-call-chain (current-error-port))
-  (apply debug:print-error 0 *default-log-port* message)
-  (debug:print-error 0 *default-log-port* "   params: " params
-		     ", error: "     ((condition-property-accessor 'exn 'message)   exn)
-		     ", arguments: " ((condition-property-accessor 'exn 'arguments) exn)
-		     ", location: "  ((condition-property-accessor 'exn 'location)  exn)
-		     ))
-
-;; (db:with-db dbstruct run-id sqlite3:exec "select blah fgrom blaz;")
-;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no
-;;
-(define (db:with-db dbstruct run-id r/w proc . params)
-  (let* ((have-struct (dbr:dbstruct? dbstruct))
-         (dbdat     (if have-struct 
-			(db:get-db dbstruct)
-			#f))
-	 (db        (if have-struct
-			(db:dbdat-get-db dbdat)
-			dbstruct))
-	 (fname     (db:dbdat-get-path dbdat))
-	 (use-mutex (> *api-process-request-count* 25))) ;; was 25
-    (if (and use-mutex
-	     (common:low-noise-print 120 "over-50-parallel-api-requests"))
-	(debug:print-info 0 *default-log-port* *api-process-request-count* " parallel api requests being processed in process " (current-process-id) ", throttling access"))
-    (if (common:low-noise-print 600 (conc "parallel-api-requests" *max-api-process-requests*))
-	(debug:print-info 2 *default-log-port* "Parallel api request count: " *api-process-request-count* " max parallel requests: " *max-api-process-requests*))
-    (condition-case
-     (begin
-       (if use-mutex (mutex-lock! *db-with-db-mutex*))
-       (let ((res (apply proc db params)))
-	 (if use-mutex (mutex-unlock! *db-with-db-mutex*))
-	 ;; (if (vector? dbstruct)(db:done-with dbstruct run-id r/w))
-	 (if dbdat (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat))
-	 res))
-     (exn (io-error)
-	  (db:generic-error-printout exn "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again."))
-     (exn (corrupt)
-	  (db:generic-error-printout exn "ERROR: database " fname " is corrupt. Repair it to proceed."))
-     (exn (busy)
-	  (db:generic-error-printout exn "ERROR: database " fname
-				     " is locked. Try copying to another location, remove original and copy back."))
-     (exn (permission)(db:generic-error-printout exn "ERROR: database " fname " has some permissions problem."))
-     (exn ()
-	  (db:generic-error-printout exn "ERROR: Unknown error with database " fname " message: "
-		       ((condition-property-accessor 'exn 'message) exn))))))
-      
-;;======================================================================
-;; K E E P   F I L E D B   I N   dbstruct
-;;======================================================================
-
-;; (define (db:get-filedb dbstruct run-id)
-;;   (let ((db (vector-ref dbstruct 2)))
-;;     (if db
-;; 	db
-;; 	(let ((fdb (filedb:open-db (conc *toplevel* "/db/files.db"))))
-;; 	  (vector-set! dbstruct 2 fdb)
-;; 	  fdb))))
-;; 
-;; ;; Can also be used to save arbitrary strings
-;; ;;
-;; (define (db:save-path dbstruct path)
-;;   (let ((fdb (db:get-filedb dbstruct)))b
-;;     (filedb:register-path fdb path)))
-;; 
-;; ;; Use to get a path. To get an arbitrary string see next define
-;; ;;
-;; (define (db:get-path dbstruct id)
-;;   (let ((fdb (db:get-filedb dbstruct)))
-;;     (filedb:get-path db id)))
-
-;; NB// #f => return dbdir only
-;;      (was planned to be;  zeroth db with name=main.db)
-;; 
-;; If run-id is #f return to create and retrieve the path where the db will live.
-;;
-(define db:dbfile-path common:get-db-tmp-area)
-
-(define (db:set-sync db)
-  (let ((syncprag (configf:lookup *configdat* "setup" "sychronous")))
-    (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 0) ";")))) 
-
-;; open an sql database inside a file lock
-;; returns: db existed-prior-to-opening
-;; RA => Returns a db handler; sets the lock if opened in writable mode
-;;
-;; (define *db-open-mutex* (make-mutex))
-
-(define (db:lock-create-open fname initproc)
-  (let* ((parent-dir   (or (pathname-directory fname)(current-directory))) ;; no parent? go local
-         (raw-fname    (pathname-file fname))
-	 (dir-writable (file-write-access? parent-dir))
-	 (file-exists  (common:file-exists? fname))
-	 (file-write   (if file-exists
-			   (file-write-access? fname)
-			   dir-writable )))
-    ;; (mutex-lock! *db-open-mutex*) ;; tried this mutex, not clear it helped.
-    (if file-write ;; dir-writable
-	(condition-case
-         (let* ((lockfname   (conc fname ".lock"))
-                (readyfname  (conc parent-dir "/.ready-" raw-fname))
-                (readyexists (common:file-exists? readyfname)))
-           (if (not readyexists)
-               (common:simple-file-lock-and-wait lockfname))
-           (let ((db      (sqlite3:open-database fname)))
-             (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
-             (sqlite3:execute db "PRAGMA synchronous = 0;")
-             (if (and (configf:lookup *configdat* "setup" "tmp_mode") (string-match "^/tmp/.*" fname))
-                 (begin
-                   ;;(print "DEBUG: Setting tmp_mode for " fname) 
-                   (sqlite3:execute db (configf:lookup *configdat* "setup" "tmp_mode"))
-                   )
-                 )  
-             (if (and (configf:lookup *configdat* "setup" "nfs_mode") (not (string-match "^/tmp/.*" fname)))
-                 (begin
-                   ;;(print "DEBUG: Setting nfs_mode for " fname)
-                   (sqlite3:execute db (configf:lookup *configdat* "setup" "nfs_mode"))
-                   )
-                 )  
-             (if (and (not (or (configf:lookup *configdat* "setup" "tmp_mode") (configf:lookup *configdat* "setup" "nfs_mode")))  
-                      (configf:lookup *configdat* "setup" "use-wal")
-                      (string-match "^/tmp/.*" fname)) ;; this is a file in /tmp
-                 (sqlite3:execute db "PRAGMA journal_mode=WAL;")
-                 (debug:print 2 *default-log-port* "Creating " fname " in NON-WAL mode."))
-             (if (not file-exists)
-                 (initproc db))
-             (if (not readyexists)
-                 (begin
-                   (common:simple-file-release-lock lockfname)
-                   (with-output-to-file
-                       readyfname
-                     (lambda ()
-                       (print "Ready at " 
-                              (seconds->year-work-week/day-time 
-                               (current-seconds)))))))
-             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))))
-        
-	(condition-case
-         (begin
-           (debug:print 2 *default-log-port* "WARNING: opening db in non-writable dir " fname)
-           (let ((db (sqlite3:open-database fname)))
-             (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
-             (sqlite3:execute db "PRAGMA synchronous = 0;")
-	     ;; (mutex-unlock! *db-open-mutex*)
-             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))))
-	)))
-
-
-;; This routine creates the db if not already present. It is only called if the db is not already opened
-;;
-(define (db:open-db dbstruct #!key (areapath #f)(do-sync #t)) ;; TODO: actually use areapath
-  (let ((tmpdb-stack (dbr:dbstruct-dbstack dbstruct))) ;; RA => Returns the first reference in dbstruct
-    (if (stack? tmpdb-stack)
-	(db:get-db tmpdb-stack) ;; get previously opened db (will create new db handle if all in the stack are already used
-        (let* ((max-stale-tmp (configf:lookup-number *configdat* "server" "filling-db-max-stale-seconds" default: 10))
-               (dbpath       (db:dbfile-path ))      ;; path to tmp db area
-               (dbexists     (common:file-exists? dbpath))
-	       (tmpdbfname   (conc dbpath "/megatest.db"))
-	       (dbfexists    (common:file-exists? tmpdbfname))  ;; (conc dbpath "/megatest.db")))
-               (mtdbexists   (common:file-exists? (conc *toppath* "/megatest.db")))
-							 
-               (mtdbmodtime  (if mtdbexists (common:lazy-sqlite-db-modification-time (conc *toppath* "/megatest.db"))   #f))
-	        		 (tmpdbmodtime (if dbfexists  (common:lazy-sqlite-db-modification-time tmpdbfname) #f)) 
-               (mtdb         (db:open-megatest-db))
-               (mtdbpath     (db:dbdat-get-path mtdb))
-               (tmpdb        (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db))
-               (refndb       (db:open-megatest-db path: dbpath name: "megatest_ref.db"))
-               (write-access (file-write-access? mtdbpath))
-	       ;(mtdbmodtime  (if mtdbexists (common:lazy-sqlite-db-modification-time mtdbpath)   #f)) ; moving this before db:open-megatest-db is called. if wal mode is on -WAL and -shm file get created with causing the  tmpdbmodtime timestamp always greater than mtdbmodtime
-	       ;(tmpdbmodtime (if dbfexists  (common:lazy-sqlite-db-modification-time tmpdbfname) #f)) 
-					;if wal mode is on -WAL and -shm file get created when db:open-megatest-db is called. modtimedelta will always be < 10 so db in tmp not get synced
-          ;(tmpdbmodtime (if dbfexists (db:get-last-update-time (car tmpdb)) #f))    
-          ;(fmt (file-modification-time tmpdbfname))
-	       (modtimedelta (and mtdbmodtime tmpdbmodtime (- mtdbmodtime tmpdbmodtime))))
-
-          (when write-access
-            (sqlite3:execute (car mtdb) "drop trigger if exists update_tests_trigger")
-            (sqlite3:execute (car mtdb) "drop trigger if exists update_runs_trigger"))
-          
-         ;(print "mtdbmodtime " mtdbmodtime " tmpdbmodtime " tmpdbmodtime " mtdbpath " mtdbpath " " (conc *toppath* "/megatest.db"))
-	        ;;(debug:print-info 13 *default-log-port* "db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists" and write-access="write-access)
-          (if (and dbexists (not write-access))
-              (begin
-                (set! *db-write-access* #f)
-                (dbr:dbstruct-read-only-set! dbstruct #t)))
-          (dbr:dbstruct-mtdb-set!   dbstruct mtdb)
-          (dbr:dbstruct-tmpdb-set!  dbstruct tmpdb)
-          (dbr:dbstruct-dbstack-set! dbstruct (make-stack)) ;; BB: why a stack?  Why would the number of db's be indeterminate?  Is this a legacy of 1.db 2.db .. ?
-          (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb) ;; olddb is already a (cons db path)
-          (dbr:dbstruct-refndb-set! dbstruct refndb)
-          (if (and  (or (not dbfexists)
-			(and modtimedelta
-			     (> modtimedelta max-stale-tmp))) ;; if db in tmp is over ten seconds older than the file in MTRA then do a sync back
-		    do-sync)
-	      (begin
-		(debug:print 1 *default-log-port* "filling db " (db:dbdat-get-path tmpdb) " with data \n    from " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta)
-		(db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb refndb tmpdb)
-    ;touch tmp db to avoid wal mode wierdness  
-     (set! (file-modification-time tmpdbfname) (current-seconds))  
-                (debug:print-info 13 *default-log-port* "db:sync-all-tables-list done.")
-                )
-	      (debug:print 4 *default-log-port* " db, " (db:dbdat-get-path tmpdb) " already exists or fresh enough, not propogating data from\n     " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta) )
-	  ;; (db:multi-db-sync dbstruct 'old2new))  ;; migrate data from megatest.db automatically
-          tmpdb))))
-
-
-(define (db:get-last-update-time db)
-;	(db:with-db
-;   dbstruct #f #f 
-;    (lambda (db)
-			(let ((last-update-time #f))
-      	(sqlite3:for-each-row 
-          (lambda (lup) 
-             (set! last-update-time lup))     
-          db    
-					"select max(lup) from ( select max(last_update) as lup  from tests union select max(last_update) as lup from runs);")
-        last-update-time))
-;))
-
-;; Make the dbstruct, setup up auxillary db's and call for main db at least once
-;;
-;; called in http-transport and replicated in rmt.scm for *local* access. 
-;;
-(define (db:setup do-sync #!key (areapath #f))
-  ;;
-  (cond
-   (*dbstruct-db* *dbstruct-db*);; TODO: when multiple areas are supported, this optimization will be a hazard
-   (else ;;(common:on-homehost?)
-    (debug:print-info 13 *default-log-port* "db:setup entered (first time, not cached.)")
-    (let* ((dbstruct (make-dbr:dbstruct)))
-      (when (not *toppath*)
-        (debug:print-info 13 *default-log-port* "in db:setup, *toppath* not set; calling launch:setup")
-        (launch:setup areapath: areapath))
-      (debug:print-info 13 *default-log-port* "Begin db:open-db")
-      (db:open-db dbstruct areapath: areapath do-sync: do-sync)
-      (debug:print-info 13 *default-log-port* "Done db:open-db")
-      (set! *dbstruct-db* dbstruct)
-      ;;(debug:print-info 13 *default-log-port* "new dbstruct = "(dbr:dbstruct->alist dbstruct))
-      dbstruct))))
-   ;; (else
-   ;;  (debug:print 0 *default-log-port* "ERROR: attempt to open database when not on homehost. Exiting. Homehost: " (common:get-homehost))
-   ;;  (exit 1))))
-
-;; Open the classic megatest.db file (defaults to open in toppath)
-;;
-;;   NOTE: returns a dbdat not a dbstruct!
-;;
-
-;;(define (db:reopen-megatest-db
-
-(define (db:open-megatest-db #!key (path #f)(name #f))
-  (let* ((dbdir        (or path *toppath*))
-         (dbpath       (conc  dbdir "/" (or name "megatest.db")))
-	 (dbexists     (common:file-exists? dbpath))
-	 (db           (db:lock-create-open dbpath
-					    (lambda (db)
-                                              (db:initialize-main-db db)
-					      ;;(db:initialize-run-id-db db)
-					      )))
-	 (write-access (file-write-access? dbpath)))
-    (debug:print-info 13 *default-log-port* "db:open-megatest-db "dbpath)
-    (if (and dbexists (not write-access))
-	(set! *db-write-access* #f))
-    (cons db dbpath)))
-
-;; sync run to disk if touched
-;;
-(define (db:sync-touched dbstruct run-id #!key (force-sync #f))
-  (let ((tmpdb   (db:get-db dbstruct))
-	(mtdb    (dbr:dbstruct-mtdb   dbstruct))
-        (refndb  (dbr:dbstruct-refndb dbstruct))
-	(start-t (current-seconds)))
-    (debug:print-info 4 *default-log-port* "Syncing for run-id: " run-id)
-    (mutex-lock! *db-multi-sync-mutex*)
-    (let ((update_info (cons (if force-sync 0 *db-last-sync*) "last_update")))
-      (mutex-unlock! *db-multi-sync-mutex*)
-      (db:sync-tables (db:sync-all-tables-list dbstruct) update_info tmpdb refndb mtdb))
-    (mutex-lock! *db-multi-sync-mutex*)
-    (set! *db-last-sync* start-t)
-    (set! *db-last-access* start-t)
-    (mutex-unlock! *db-multi-sync-mutex*)
-    (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb)))
-
-(define (db:safely-close-sqlite3-db db stmt-cache #!key (try-num 3))
-  (if (<= try-num 0)
-      #f
-      (handle-exceptions
-	  exn
-	(begin
-	  (print "Attempt to safely close sqlite3 db failed. Trying again. exn=" exn)
-	  (thread-sleep! 3)
-	  (sqlite3:interrupt! db)
-	  (db:safely-close-sqlite3-db db stmt-cache try-num: (- try-num 1)))
-	(if (sqlite3:database? db)
-	    (let* ((stmts (and stmt-cache (hash-table-ref/default stmt-cache db #f))))
-	      (if stmts (map sqlite3:finalize! (hash-table-values stmts)))
-	      (sqlite3:finalize! db)
-	      #t)
-	    #f))))
-
-;; close all opened run-id dbs
-(define (db:close-all dbstruct)
-  (if (dbr:dbstruct? dbstruct)
-      (handle-exceptions
-	  exn
-	  (begin
-	    (debug:print 0 *default-log-port* "WARNING: Finalizing failed, "  ((condition-property-accessor 'exn 'message) exn) ", note - exn=" exn)
-	    (print-call-chain *default-log-port*))
-	;; (db:sync-touched dbstruct 0 force-sync: #t) ;; NO. Do not do this here. Instead we rely on a server to be started when there are writes, even if the server itself is not going to be used as a server.
-        (let ((tdbs       (map db:dbdat-get-db 
-			       (stack->list (dbr:dbstruct-dbstack dbstruct))))
-              (mdb        (db:dbdat-get-db (dbr:dbstruct-mtdb   dbstruct)))
-              (rdb        (db:dbdat-get-db (dbr:dbstruct-refndb dbstruct)))
-	      (stmt-cache (dbr:dbstruct-stmt-cache dbstruct)))
-          (map (lambda (db)
-		 (db:safely-close-sqlite3-db db stmt-cache))
-	       tdbs)
-          (db:safely-close-sqlite3-db mdb stmt-cache)     ;; (if (sqlite3:database? mdb) (sqlite3:finalize! mdb))
-          (db:safely-close-sqlite3-db rdb stmt-cache))))) ;; (if (sqlite3:database? rdb) (sqlite3:finalize! rdb))))))
-
-;;   (let ((locdbs (dbr:dbstruct-locdbs dbstruct)))
-;;     (if (hash-table? locdbs)
-;; 	(for-each (lambda (run-id)
-;; 		    (db:close-run-db dbstruct run-id))
-;; 		  (hash-table-keys locdbs)))))
-
-;; (define (db:open-inmem-db)
-;;   (let* ((db      (sqlite3:open-database ":memory:"))
-;; 	 (handler (make-busy-timeout 3600)))
-;;     (sqlite3:set-busy-handler! db handler)
-;;     (db:initialize-run-id-db db)
-;;     (cons db #f)))
-
-;; just tests, test_steps and test_data tables
-(define db:sync-tests-only
-  (list
-   ;; (list "strs"
-   ;;       '("id"             #f)
-   ;;       '("str"            #f))
-   (list "tests" 
-	 '("id"             #f)
-	 '("run_id"         #f)
-	 '("testname"       #f)
-	 '("host"           #f)
-	 '("cpuload"        #f)
-	 '("diskfree"       #f)
-	 '("uname"          #f)
-	 '("rundir"         #f)
-	 '("shortdir"       #f)
-	 '("item_path"      #f)
-	 '("state"          #f)
-	 '("status"         #f)
-	 '("attemptnum"     #f)
-	 '("final_logf"     #f)
-	 '("logdat"         #f)
-	 '("run_duration"   #f)
-	 '("comment"        #f)
-	 '("event_time"     #f)
-	 '("fail_count"     #f)
-	 '("pass_count"     #f)
-	 '("archived"       #f)
-         '("last_update"    #f))
-  (list "test_steps"
-	 '("id"             #f)
-	 '("test_id"        #f)
-	 '("stepname"       #f)
-	 '("state"          #f)
-	 '("status"         #f)
-	 '("event_time"     #f)
-	 '("comment"        #f)
-	 '("logfile"        #f)
-         '("last_update"    #f))
-   (list "test_data"
-	 '("id"             #f)
-	 '("test_id"        #f)
-	 '("category"       #f)
-	 '("variable"       #f)
-	 '("value"          #f)
-	 '("expected"       #f)
-	 '("tol"            #f)
-	 '("units"          #f)
-	 '("comment"        #f)
-	 '("status"         #f)
-	 '("type"           #f)
-         '("last_update"    #f))))
-
-;; needs db to get keys, this is for syncing all tables
-;;
-(define (db:sync-main-list dbstruct)
-  (let ((keys  (db:get-keys dbstruct)))
-    (list
-     (list "keys"
-	   '("id"        #f)
-	   '("fieldname" #f)
-	   '("fieldtype" #f))
-     (list "metadat" '("var" #f) '("val" #f))
-     (append (list "runs" 
-		   '("id"  #f))
-	     (map (lambda (k)(list k #f))
-		  (append keys
-			  (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour" "last_update"))))
-     (list "archive_disks"
-           '("id" #f)
-           '("archive_area_name" #f) 
-           '("disk_path" #f)
-           '("last_df" #f)
-           '("last_df_time" #f)
-           '("creation_time" #f)) 
-
-     (list "archive_blocks"
-           '("id" #f)
-           '("archive_disk_id" #f) 
-           '("disk_path" #f)
-           '("last_du" #f)
-           '("last_du_time" #f)
-           '("creation_time" #f)) 
-
-     (list "test_meta"
-	   '("id"             #f)
-	   '("testname"       #f)
-	   '("owner"          #f)
-	   '("description"    #f)
-	   '("reviewed"       #f)
-	   '("iterated"       #f)
-	   '("avg_runtime"    #f)
-	   '("avg_disk"       #f)
-	   '("tags"           #f)
-	   '("jobgroup"       #f)))))
-
-(define (db:sync-all-tables-list dbstruct)
-  (append (db:sync-main-list dbstruct)
-	  db:sync-tests-only))
-
-;; use bunch of Unix commands to try to break the lock and recreate the db
-;;
-(define (db:move-and-recreate-db dbdat)
-  (let* ((dbpath   (db:dbdat-get-path        dbdat))
-	 (dbdir    (pathname-directory       dbpath))
-	 (fname    (pathname-strip-directory dbpath))
-	 (fnamejnl (conc fname "-journal"))
-	 (tmpname  (conc fname "." (current-process-id)))
-	 (tmpjnl   (conc fnamejnl "." (current-process-id))))
-    (debug:print-error 0 *default-log-port* "" fname " appears corrupted. Making backup \"old/" fname "\"")
-    (system (conc "cd " dbdir ";mkdir -p old;cat " fname " > old/" tmpname))
-    (system (conc "rm -f " dbpath))
-    (if (common:file-exists? fnamejnl)
-	(begin
-	  (debug:print-error 0 *default-log-port* "" fnamejnl " found, moving it to old dir as " tmpjnl)
-	  (system (conc "cd " dbdir ";mkdir -p old;cat " fnamejnl " > old/" tmpjnl))
-	  (system (conc "rm -f " dbdir "/" fnamejnl))))
-    ;; attempt to recreate database
-    (system (conc "cd " dbdir ";sqlite3 old/" tmpname " .dump | sqlite3 " fname))))
-    
-;; return #f to indicate the dbdat should be closed/reopened
-;; else return dbdat
-;;
-(define (db:repair-db dbdat #!key (numtries 1))
-  (let* ((dbpath   (db:dbdat-get-path        dbdat))
-	 (dbdir    (pathname-directory       dbpath))
-	 (fname    (pathname-strip-directory dbpath)))
-    (debug:print-info 0 *default-log-port* "Checking db " dbpath " for errors.")
-    (cond
-     ((not (file-write-access? dbdir))
-      (debug:print 0 *default-log-port* "WARNING: can't write to " dbdir ", can't fix " fname)
-      #f)
-
-     ;; handle special cases, megatest.db and monitor.db
-     ;; 
-     ;;  NOPE: apply this same approach to all db files
-     ;;
-     (else ;; ((equal? fname "megatest.db") ;; this file can be regenerated if needed
-      (handle-exceptions
-       exn
-       (begin
-	 (print "Problems trying to repair the db, exn=" exn)
-	 ;; (db:move-and-recreate-db dbdat)
-	 (if (> numtries 0)
-	     (db:repair-db dbdat numtries: (- numtries 1))
-	     #f)
-	 (debug:print 0 *default-log-port* "FATAL: file " dbpath " was found corrupted, an attempt to fix has been made but you must start over.")
-	 (debug:print 0 *default-log-port*
-		      "   check the following:\n"
-		      "      1. full directories, look in ~/ /tmp and " dbdir "\n"
-		      "      2. write access to " dbdir "\n\n"
-		      "   if the automatic recovery failed you may be able to recover data by doing \"" 
-		      (if (member fname '("megatest.db" "monitor.db"))
-			  "megatest -cleanup-db"
-			  "megatest -import-megatest.db;megatest -cleanup-db")
-		      "\"\n")
-	 (exit) ;; we can not safely continue when a db was corrupted - even if fixed.
-	 )
-       ;; test read/write access to the database
-       (let ((db (sqlite3:open-database dbpath)))
-	 (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
-	 (sqlite3:execute db "PRAGMA synchronous = 0;")
-	 (cond
-	  ((equal? fname "megatest.db")
-	   (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';"))
-	  ((equal? fname "main.db")
-	   (sqlite3:execute db "DELETE FROM runs WHERE state='deleted';"))
-	  ((string-match "\\d.db" fname)
-	   (sqlite3:execute db "UPDATE tests SET state='DELETED' WHERE state='DELETED';"))
-	  ((equal? fname "monitor.db")
-	   (sqlite3:execute "DELETE FROM servers WHERE state LIKE 'defunct%';"))
-	  (else
-	   (sqlite3:execute db "vacuum;")))
-	 
-	 (sqlite3:finalize! db)
-	 #t))))))
-    
-;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) )
-;; db's are dbdat's
-;;
-;; if last-update specified ("field-name" . time-in-seconds)
-;;    then sync only records where field-name >= time-in-seconds
-;;    IFF field-name exists
-;;
-(define (db:sync-tables tbls last-update fromdb todb . slave-dbs)
-  (handle-exceptions
-   exn
-   (begin
-     (debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.")
-     (print-call-chain (current-error-port))
-     (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
-     (debug:print 5 *default-log-port* "exn=" (condition->list exn))
-     (debug:print 0 *default-log-port* " status:  " ((condition-property-accessor 'sqlite3 'status) exn))
-     (debug:print 0 *default-log-port* " src db:  " (db:dbdat-get-path fromdb))
-     (for-each (lambda (dbdat)
-		 (let ((dbpath (db:dbdat-get-path dbdat)))
-		   (debug:print 0 *default-log-port* " dbpath:  " dbpath)
-		   (if (not (db:repair-db dbdat))
-		       (begin
-			 (debug:print-error 0 *default-log-port* "Failed to rebuild " dbpath ", exiting now.")
-			 (exit)))))
-	       (cons todb slave-dbs))
-     
-     0)
-   ;; this is the work to be done
-   (cond
-    ((not fromdb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with fromdb missing")
-     -1)
-    ((not todb)   (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with todb missing")
-     -2)
-    ((not (sqlite3:database? (db:dbdat-get-db fromdb)))
-     (debug:print-error 0 *default-log-port* "db:sync-tables called with fromdb not a database " fromdb)
-     -3)
-    ((not (sqlite3:database? (db:dbdat-get-db todb)))
-     (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a database " todb)
-     -4)
-
-    ((not (file-write-access? (db:dbdat-get-path todb)))
-     (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a read-only database " todb)
-     -5)
-    ((not (null? (let ((readonly-slave-dbs
-                        (filter
-                         (lambda (dbdat)
-                           (not (file-write-access? (db:dbdat-get-path todb))))
-                         slave-dbs)))
-                   (for-each
-                    (lambda (bad-dbdat)
-                      (debug:print-error
-                       0 *default-log-port* "db:sync-tables called with todb not a read-only database " bad-dbdat))
-                    readonly-slave-dbs)
-                   readonly-slave-dbs))) -6)
-    (else
-     (let ((stmts       (make-hash-table)) ;; table-field => stmt
-	   (all-stmts   '())              ;; ( ( stmt1 value1 ) ( stml2 value2 ))
-	   (numrecs     (make-hash-table))
-	   (start-time  (current-milliseconds))
-	   (tot-count   0))
-       (for-each ;; table
-	(lambda (tabledat)
-	  (let* ((tablename        (car tabledat))
-		 (fields           (cdr tabledat))
-		 (has-last-update  (member "last_update" fields))
-		 (use-last-update  (cond
-				    ((and has-last-update
-					  (member "last_update" fields))
-				     #t) ;; if given a number, just use it for all fields
-				    ((number? last-update) #f) ;; if not matched first entry then ignore last-update for this table
-				    ((and (pair? last-update)
-					  (member (car last-update)    ;; last-update field name
-						  (map car fields)))
-                                        #t)
-				    (last-update
-				     (debug:print 0 *default-log-port* "ERROR: parameter last-update for db:sync-tables must be a pair or a number, received: " last-update);; found in fields
-				     #f)
-				    (else
-				     #f)))
-		 (last-update-value (if use-last-update ;; no need to check for has-last-update - it is already accounted for
-					(if (number? last-update)
-					    last-update
-					    (cdr last-update))
-					#f))
-		 (last-update-field (if use-last-update
-					(if (number? last-update)
-					    "last_update"
-					    (car last-update))
-					#f))
-		 (num-fields (length fields))
-		 (field->num (make-hash-table))
-		 (num->field (apply vector (map car fields))) ;; BBHERE
-		 (full-sel   (conc "SELECT " (string-intersperse (map car fields) ",") 
-				   " FROM " tablename (if use-last-update ;; apply last-update criteria
-							  (conc " WHERE " last-update-field " >= " last-update-value)
-							  "")
-				   ";"))
-		 (full-ins   (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) "
-				   " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );"))
-		 (fromdat    '())
-		 (fromdats   '())
-		 (totrecords 0)
-		 (batch-len  (string->number (or (configf:lookup *configdat* "sync" "batchsize") "100")))
-		 (todat      (make-hash-table))
-		 (count      0)
-                 (field-names (map car fields))
-                 (delay-handicap  (string->number (or (configf:lookup *configdat* "sync" "delay-handicap") "0")))
-                 )
-
-	    ;; set up the field->num table
-	    (for-each
-	     (lambda (field)
-	       (hash-table-set! field->num field count)
-	       (set! count (+ count 1)))
-	     fields)
-
-	    ;; read the source table
-	    (sqlite3:for-each-row
-	     (lambda (a . b)
-	       (set! fromdat (cons (apply vector a b) fromdat))
-	       (if (> (length fromdat) batch-len)
-		   (begin
-		     (set! fromdats (cons fromdat fromdats))
-		     (set! fromdat  '())
-		     (set! totrecords (+ totrecords 1)))))
-	     (db:dbdat-get-db fromdb)
-	     full-sel)
-	    
-	    ;; tack on remaining records in fromdat
-	    (if (not (null? fromdat))
-		(set! fromdats (cons fromdat fromdats)))
-
-	    (if (common:low-noise-print 120 "sync-records")
-		(debug:print-info 4 *default-log-port* "found " totrecords " records to sync"))
-
-	    ;; read the target table; BBHERE
-	    (sqlite3:for-each-row
-	     (lambda (a . b)
-	       (hash-table-set! todat a (apply vector a b)))
-	     (db:dbdat-get-db todb)
-	     full-sel)
-
-            (when (and delay-handicap (> delay-handicap 0))
-              (debug:print-info 0 *default-log-port* "imposing synthetic sync delay of "delay-handicap" seconds since sync/delay-handicap is configured")
-              (thread-sleep! delay-handicap)
-              (debug:print-info 0 *default-log-port* "synthetic sync delay of "delay-handicap" seconds completed")
-              )
-            
-	    ;; first pass implementation, just insert all changed rows
-	    (for-each 
-	     (lambda (targdb)
-	       (let* ((db                 (db:dbdat-get-db targdb))
-                      (drp-trigger        (if (member "last_update" field-names)
-					      (db:drop-trigger db tablename) 
-					      #f))
-                      (is-trigger-dropped (if (member "last_update" field-names)
-                                              (db:is-trigger-dropped db tablename)
-					      #f)) 
-		      (stmth  (sqlite3:prepare db full-ins)))
-		 ;; (db:delay-if-busy targdb) ;; NO WAITING
-                 (if (member "last_update" field-names)
-                     (debug:print-info 3 *default-log-port* "is-trigger-dropped: " is-trigger-dropped)) 
-		 (for-each
-		  (lambda (fromdat-lst)
-		    (sqlite3:with-transaction
-		     db
-		     (lambda ()
-		       (for-each ;; 
-			(lambda (fromrow)
-			  (let* ((a    (vector-ref fromrow 0))
-				 (curr (hash-table-ref/default todat a #f))
-				 (same #t))
-			    (let loop ((i 0))
-			      (if (or (not curr)
-				      (not (equal? (vector-ref fromrow i)(vector-ref curr i))))
-				  (set! same #f))
-			      (if (and same
-				       (< i (- num-fields 1)))
-				  (loop (+ i 1))))
-			    (if (not same)
-				(begin
-				  (apply sqlite3:execute stmth (vector->list fromrow))
-				  (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0)))))))
-			fromdat-lst))))
-		  fromdats)
-		 (sqlite3:finalize! stmth)
-                 (if (member "last_update" field-names)
-                    (db:create-trigger db tablename))))
-	     (append (list todb) slave-dbs))))
-	tbls)
-       (let* ((runtime      (- (current-milliseconds) start-time))
-	      (should-print (or (debug:debug-mode 12)
-				(common:low-noise-print 120 "db sync" (> runtime 500))))) ;; low and high sync times treated as separate.
-	 (if should-print (debug:print 3 *default-log-port* "INFO: db sync, total run time " runtime " ms"))
-	 (for-each 
-	  (lambda (dat)
-	    (let ((tblname (car dat))
-		  (count   (cdr dat)))
-	      (set! tot-count (+ tot-count count))
-	      (if (> count 0)
-		  (if should-print (debug:print 0 *default-log-port* (format #f "    ~10a ~5a" tblname count))))))
-	  (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b))))))
-       tot-count)))))
-
-(define (db:patch-schema-rundb frundb)
-  ;;
-  ;; remove this some time after September 2016 (added in version v1.6031
-  ;;
-  (for-each
-   (lambda (table-name)
-     (handle-exceptions
-      exn
-      (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn))
-          (debug:print 0 *default-log-port* "Column last_update already added to " table-name " table")
-          (db:general-sqlite-error-dump exn "alter table " table-name " ..." #f "none"))
-      (sqlite3:execute
-       frundb
-       (conc "ALTER TABLE " table-name " ADD COLUMN last_update INTEGER DEFAULT 0")))
-     (sqlite3:execute
-      frundb
-      (conc "DROP TRIGGER IF EXISTS update_" table-name "_trigger;"))
-     (sqlite3:execute
-      frundb
-      (conc "CREATE TRIGGER IF NOT EXISTS update_" table-name "_trigger AFTER UPDATE ON " table-name "
-                             FOR EACH ROW
-                               BEGIN 
-                                 UPDATE " table-name " SET last_update=(strftime('%s','now'))
-                                   WHERE id=old.id;
-                               END;"))
-     )
-   '("tests" "test_steps" "test_data")))
-
-(define (db:patch-schema-maindb maindb)
-  ;;
-  ;; remove all these some time after september 2016 (added in v1.6031
-  ;;
-  (for-each
-   (lambda (column type default)
-     (handle-exceptions
-	 exn
-	 (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn))
-	     (debug:print 0 *default-log-port* "Column " column " already added to runs table")
-	     (db:general-sqlite-error-dump exn "alter table runs ..." #f "none"))
-       (sqlite3:execute
-	maindb
-	(conc "ALTER TABLE runs ADD COLUMN " column " " type " DEFAULT " default))))
-   (list "last_update" "contour")
-   (list "INTEGER"     "TEXT"   )
-   (list "0"           "''"   ))
-  ;; these schema changes don't need exception handling
-  (sqlite3:execute
-   maindb
-   "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs
-                             FOR EACH ROW
-                               BEGIN 
-                                 UPDATE runs SET last_update=(strftime('%s','now'))
-                                   WHERE id=old.id;
-                               END;")
-  (sqlite3:execute maindb "CREATE TABLE IF NOT EXISTS run_stats (
-                              id     INTEGER PRIMARY KEY,
-                              run_id INTEGER,
-                              state  TEXT,
-                              status TEXT,
-                              count  INTEGER,
-                              last_update INTEGER DEFAULT (strftime('%s','now')))")
-  (sqlite3:execute maindb "CREATE TRIGGER  IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats
-                             FOR EACH ROW
-                               BEGIN 
-                                 UPDATE run_stats SET last_update=(strftime('%s','now'))
-                                   WHERE id=old.id;
-                               END;")
-  (sqlite3:execute maindb "CREATE TABLE IF NOT EXISTS test_rundat (
-                              id           INTEGER PRIMARY KEY,
-                              test_id      INTEGER,
-                              update_time  TIMESTAMP,
-                              cpuload      INTEGER DEFAULT -1,
-                              diskfree     INTEGER DEFAULT -1,
-                              diskusage    INTGER DEFAULT -1,
-                              run_duration INTEGER DEFAULT 0);"))
-
-(define (db:adj-target db)
-  (let ((fields    (configf:get-section *configdat* "fields"))
-	(field-num 0))
-    ;; because we will be refreshing the keys table it is best to clear it here
-    (sqlite3:execute db "DELETE FROM keys;")
-    (for-each
-     (lambda (field)
-       (let ((column (car field))
-	     (spec   (cadr field)))
-	 (handle-exceptions
-	  exn
-	  (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn))
-	      (debug:print 0 *default-log-port* "Target field " column " already exists in the runs table")
-	      (db:general-sqlite-error-dump exn "alter table runs ..." #f "none"))
-	  ;; Add the column if needed
-	  (sqlite3:execute
-	   db
-	   (conc "ALTER TABLE runs ADD COLUMN " column " " spec)))
-	 ;; correct the entry in the keys column
-	 (sqlite3:execute
-	  db
-	  "INSERT INTO keys (id,fieldname,fieldtype) VALUES (?,?,?);"
-	  field-num column spec)
-	 ;; fill in blanks (not allowed as it would be part of the path
-	 (sqlite3:execute
-	  db
-	  (conc "UPDATE runs SET " column "='x' WHERE " column "='';"))
-	 (set! field-num (+ field-num 1))))
-     fields)))
-  
-(define *global-db-store* (make-hash-table))
-
-(define (db:get-access-mode)
-  (if (args:get-arg "-use-db-cache") 'cached 'rmt))
-
-;; Add db direct
-;;
-(define (db:dispatch-query access-mode rmt-cmd db-cmd . params)
-  (if (eq? access-mode 'cached)
-      (debug:print 2 *default-log-port* "not doing cached calls right now"))
-;;      (apply db:call-with-cached-db db-cmd params)
-      (apply rmt-cmd params))
-;;)
-
-;; return the target db handle so it can be used
-;;
-(define (db:cache-for-read-only source target #!key (use-last-update #f))
-  (if (and (hash-table-ref/default *global-db-store* target #f)
-	   (>= (file-modification-time target)(file-modification-time source)))
-      (hash-table-ref *global-db-store* target)
-      (let* ((toppath   (launch:setup))
-	     (targ-db-last-mod (if (common:file-exists? target)
-				   (file-modification-time target)
-				   0))
-	     (cache-db  (or (hash-table-ref/default *global-db-store* target #f)
-			    (db:open-megatest-db path: target)))
-	     (source-db (db:open-megatest-db path: source))
-	     (curr-time (current-seconds))
-	     (res      '())
-	     (last-update (if use-last-update (cons "last_update" targ-db-last-mod) #f)))
-	(db:sync-tables (db:sync-main-list source-db) last-update source-db cache-db)
-	(db:sync-tables db:sync-tests-only last-update source-db cache-db)
-	(hash-table-set! *global-db-store* target cache-db)
-	cache-db)))
-
-;; ;; call a proc with a cached db
-;; ;;
-;; (define (db:call-with-cached-db proc . params)
-;;   ;; first cache the db in /tmp
-;;   (let* ((cname-part (conc "megatest_cache/" (common:get-testsuite-name)))
-;; 	 (fname      (conc  (common:get-area-path-signature) ".db"))
-;; 	 (cache-dir  (common:get-create-writeable-dir
-;; 		      (list (conc "/tmp/" (current-user-name) "/" cname-part)
-;; 			    (conc "/tmp/" (current-user-name) "-" cname-part)
-;; 			     (conc "/tmp/" (current-user-name) "_" cname-part))))
-;; 	 (megatest-db (conc *toppath* "/megatest.db")))
-;;     ;; (debug:print-info 0 *default-log-port* "Using cache dir " cache-dir)
-;;     (if (not cache-dir)
-;; 	(begin
-;; 	  (debug:print 0 *default-log-port* "ERROR: Failed to find an area to write the cache db")
-;; 	  (exit 1))
-;; 	(let* ((th1      (make-thread
-;; 			  (lambda ()
-;; 			    (if (and (common:file-exists? megatest-db)
-;; 				     (file-write-access? megatest-db))
-;; 				(begin
-;; 				  (db:sync-to-megatest.db dbstruct 'timestamps) ;; internally mutexes on *db-local-sync*
-;; 				  (debug:print-info 2 *default-log-port* "Done syncing to megatest.db"))))
-;; 			  "call-with-cached-db sync-to-megatest.db"))
-;; 	       (cache-db (db:cache-for-read-only
-;; 			  megatest-db
-;; 			  (conc cache-dir "/" fname)
-;; 			  use-last-update: #t)))
-;; 	  (thread-start! th1)
-;; 	  (apply proc cache-db params)
-;; 	  ))))
-
-;; options:
-;;
-;;  'killservers  - kills all servers
-;;  'dejunk       - removes junk records
-;;  'adj-testids  - move test-ids into correct ranges
-;;  'old2new      - sync megatest.db to /tmp/.../megatest.db and /tmp/.../megatest_ref.db
-;;  'new2old      - sync /tmp/.../megatest.db to megatest.db and /tmp/.../megatest_ref.db (and update data_synced)
-;;  'closeall     - close all opened dbs
-;;  'schema       - attempt to apply schema changes
-;;  run-ids: '(1 2 3 ...) or #f (for all)
-;;
-(define (db:multi-db-sync dbstruct . options)
-  ;; (if (not (launch:setup))
-  ;;    (debug:print 0 *default-log-port* "ERROR: not able to setup up for megatest.")
-  (let* ((mtdb     (dbr:dbstruct-mtdb dbstruct))
-	 (tmpdb    (db:get-db dbstruct))
-	 (refndb   (dbr:dbstruct-refndb dbstruct))
-	 (allow-cleanup #t) ;; (if run-ids #f #t))
-	 (servers (server:get-list *toppath*)) ;; (tasks:get-all-servers (db:delay-if-busy tdbdat)))
-	 (data-synced 0)) ;; count of changed records (I hope)
-    
-    (for-each
-     (lambda (option)
-       
-       (case option
-	 ;; kill servers
-	 ((killservers)
-	  (for-each
-	   (lambda (server)
-             (handle-exceptions
-             exn
-             (begin 
-               (debug:print-info 0 *default-log-port*  "Unable to get host and/or port from " server ", exn=" exn)     
-               #f)
-	     (match-let (((mod-time host port start-time server-id pid) server))
-	       (if (and host pid)
-		   (tasks:kill-server host pid)))))
-	   servers)
-
-          ;; /tmp/bjbarcla/megatest_localdb/fullrun/.nfs.pdx.disks.icf_env_disk001.bjbarcla.gwa.issues.mtdev.matt-bisect.megatest.ext-tests.runs.all.v1.65.1.6524.dev.bb-24-justrollup-f8.rollup.fullrun/megatest.db.lock
-          (delete-file* (common:get-sync-lock-filepath))
-          )
-	 
-	 ;; clear out junk records
-	 ;;
-	 ((dejunk)
-	  ;; (db:delay-if-busy mtdb) ;; ok to delay on mtdb
-	  (when (file-write-access? (db:dbdat-get-path mtdb)) (db:clean-up mtdb))
-	  (db:clean-up tmpdb)
-	  (db:clean-up refndb))
-
-	 ;; sync runs, test_meta etc.
-	 ;;
-	 ((old2new)
-	  (set! data-synced
-	    (+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb tmpdb refndb)
-	       data-synced)))
-	 
-	 ;; now ensure all newdb data are synced to megatest.db
-	 ;; do not use the run-ids list passed in to the function
-	 ;;
-	 ((new2old)
-	  (set! data-synced
-	    (+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f tmpdb refndb mtdb)
-	       data-synced)))
-
-	 ((adj-target)
-	  (db:adj-target (db:dbdat-get-db mtdb))
-	  (db:adj-target (db:dbdat-get-db tmpdb))
-	  (db:adj-target (db:dbdat-get-db refndb)))
-	 
-	 ((schema)
-	  (db:patch-schema-maindb (db:dbdat-get-db mtdb))
-	  (db:patch-schema-maindb (db:dbdat-get-db tmpdb))
-	  (db:patch-schema-maindb (db:dbdat-get-db refndb))
-	  (db:patch-schema-rundb  (db:dbdat-get-db mtdb))
-	  (db:patch-schema-rundb  (db:dbdat-get-db tmpdb))
-	  (db:patch-schema-rundb  (db:dbdat-get-db refndb))))
-       
-       (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb))
-     options)
-    data-synced))
-
-(define (db:tmp->megatest.db-sync dbstruct last-update)
-  (let* ((mtdb        (dbr:dbstruct-mtdb dbstruct))
-	 (tmpdb       (db:get-db dbstruct))
-	 (refndb      (dbr:dbstruct-refndb dbstruct))
-	 (res         (db:sync-tables (db:sync-all-tables-list dbstruct) last-update tmpdb refndb mtdb)))
-    (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb)
-    res))
-
-;;;; run-ids
-;;    if #f use *db-local-sync* : or 'local-sync-flags
-;;    if #t use timestamps      : or 'timestamps
-;;
-;;  NB// no-sync-db is the db handle, not a flag!
-;;
-(define (db:sync-to-megatest.db dbstruct #!key (no-sync-db #f)) 
-  (let* ((start-time         (current-seconds))
-	 (last-full-update   (if no-sync-db
-				 (db:no-sync-get/default no-sync-db "LAST_FULL_UPDATE" 0)
-				 0))
-	 (full-sync-needed   (> (- start-time last-full-update) 3600)) ;; every hour do a full sync
-	 (last-update        (if full-sync-needed
-				 0
-				 (if no-sync-db
-				     (db:no-sync-get/default no-sync-db "LAST_UPDATE" 0)
-				     0))) ;; (or (db:get-var dbstruct "LAST_UPDATE") 0))
-	 (sync-needed        (> (- start-time last-update) 6))
-	 (res                (if (or sync-needed ;; don't sync if a sync already occurred in the past 6 seconds
-				     full-sync-needed)
-				 (begin
-				   (if no-sync-db
-				       (begin
-					 (if full-sync-needed (db:no-sync-set no-sync-db "LAST_FULL_UPDATE" start-time))
-					 (db:no-sync-set no-sync-db "LAST_UPDATE" start-time)))
-				   (db:tmp->megatest.db-sync dbstruct last-update))
-				 0))
-	 (sync-time           (- (current-seconds) start-time)))
-      (debug:print-info 3 *default-log-port* "Sync of newdb to olddb completed in " sync-time " seconds pid="(current-process-id))
-      (if (common:low-noise-print 30 "sync new to old")
-          (if sync-needed
-              (debug:print-info 0 *default-log-port* "Sync of " res " records from newdb to olddb completed in " sync-time " seconds pid="(current-process-id))
-              (debug:print-info 0 *default-log-port* "No sync needed, last updated " (- start-time last-update) " seconds ago")))
-      res))
-
-;; keeping it around for debugging purposes only
-#;(define (open-run-close-no-exception-handling  proc idb . params)
-  (debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params)
-  (print "I don't work anymore. open-run-close-no-exception-handling needs fixing or removing...")
-  (exit)
-  (if (or *db-write-access*
-	  (not #t)) ;; was: (member proc * db:all-write-procs *)))
-      (let* ((db (cond
-		  ((pair? idb)                 (db:dbdat-get-db idb))
-		  ((sqlite3:database? idb)     idb)
-		  ((not idb)                   (debug:print-error 0 *default-log-port* "cannot open-run-close with #f anymore"))
-		  ((procedure? idb)            (idb))
-		  (else   	               (debug:print-error 0 *default-log-port* "cannot open-run-close with #f anymore"))))
-	     (res #f))
-	(set! res (apply proc db params))
-	(if (not idb)(sqlite3:finalize! dbstruct))
-	(debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling END" )
-	res)
-      #f))
-
-#;(define (open-run-close-exception-handling proc idb . params)
-  (handle-exceptions
-   exn
-   (let ((sleep-time (random 30))
-	 (err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
-     (case err-status
-       ((busy)
-	(thread-sleep! sleep-time))
-       (else
-	(debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable.")
-	(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
-	(debug:print 5 *default-log-port* "exn=" (condition->list exn))
-	(debug:print 0 *default-log-port* " status:  " ((condition-property-accessor 'sqlite3 'status) exn))
-	(print-call-chain (current-error-port))
-	(thread-sleep! sleep-time)
-	(debug:print-info 0 *default-log-port* "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up")))
-     (apply open-run-close-exception-handling proc idb params))
-   (apply open-run-close-no-exception-handling proc idb params)))
-
-;; (define open-run-close 
-#;(define open-run-close open-run-close-exception-handling)
-		;;	   open-run-close-no-exception-handling
-;;			   open-run-close-exception-handling)
-;;)
-
-(define db:trigger-list 
-     (list (list "update_runs_trigger"  "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs
-                             FOR EACH ROW
-                               BEGIN 
-                                 UPDATE runs SET last_update=(strftime('%s','now'))
-                                   WHERE id=old.id;
-                               END;" ) 
-	   (list "update_run_stats_trigger"  "CREATE TRIGGER  IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats
-                             FOR EACH ROW
-                               BEGIN 
-                                 UPDATE run_stats SET last_update=(strftime('%s','now'))
-                                   WHERE id=old.id;
-                               END;" )
-	   (list "update_tests_trigger"  "CREATE TRIGGER  IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests
-                             FOR EACH ROW
-                               BEGIN 
-                                 UPDATE tests SET last_update=(strftime('%s','now'))
-                                   WHERE id=old.id;
-                               END;" )
-	   (list "update_teststeps_trigger"  "CREATE TRIGGER  IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps
-                             FOR EACH ROW
-                               BEGIN 
-                                 UPDATE test_steps SET last_update=(strftime('%s','now'))
-                                   WHERE id=old.id;
-                               END;" )
-	   (list "update_test_data_trigger"  "CREATE TRIGGER  IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data
-                             FOR EACH ROW
-                               BEGIN 
-                                 UPDATE test_data SET last_update=(strftime('%s','now'))
-                                   WHERE id=old.id;
-                               END;" )))
-
-(define (db:create-all-triggers dbstruct)
-(db:with-db
-   dbstruct #f #f
-   (lambda (db)
-(db:create-triggers db))))
-
-(define (db:create-triggers db)
-    (for-each (lambda (key)
-              (sqlite3:execute db (cadr key)))
-          db:trigger-list))
-
-(define (db:drop-all-triggers dbstruct)
-  (db:with-db
-   dbstruct #f #f
-   (lambda (db)
-     (db:drop-triggers db))))
-
-(define (db:is-trigger-dropped db tbl-name)
-  (let* ((trigger-name (if (equal? tbl-name "test_steps")
-			   "update_teststeps_trigger" 
-                           (conc "update_" tbl-name "_trigger")))
-	 (res          #f))
-    (sqlite3:for-each-row
-     (lambda (name)
-       (if (equal? name trigger-name)
-	   (set! res #t)))
-     db 
-     "SELECT name FROM sqlite_master WHERE type = 'trigger' ;" 
-     )))
-
-(define (db:drop-triggers db)
-  (for-each
-   (lambda (key) 
-     (sqlite3:execute db (conc "drop trigger if exists " (car key))))
-   db:trigger-list))
-
-(define  (db:drop-trigger db tbl-name)
-  (let* ((trigger-name (if (equal? tbl-name "test_steps")
-			   "update_teststeps_trigger" 
-                           (conc "update_" tbl-name "_trigger"))))
-    (for-each
-     (lambda (key) 
-       (if (equal? (car key) trigger-name)
-           (sqlite3:execute db (conc "drop trigger if exists " trigger-name))))
-     db:trigger-list)))
-
-(define  (db:create-trigger db tbl-name)
-      (let* ((trigger-name (if (equal? tbl-name "test_steps")
-                              "update_teststeps_trigger" 
-                              (conc "update_" tbl-name "_trigger"))))
-       (for-each (lambda (key) 
-             (if (equal? (car key) trigger-name)
-             (sqlite3:execute db (cadr key))))
-      db:trigger-list))) 
-
-
-(define (db:initialize-main-db dbdat)
-  (when (not *configinfo*)
-           (launch:setup)) ;; added because Elena was getting stack dump because *configinfo* below was #f.
-  (let* ((configdat (car *configinfo*))  ;; tut tut, global warning...
-	 (keys     (keys:config-get-fields configdat))
-	 (havekeys (> (length keys) 0))
-	 (keystr   (keys->keystr keys))
-	 (fieldstr (keys:make-key/field-string configdat))
-	 (db       (db:dbdat-get-db dbdat)))
-    (for-each (lambda (key)
-		(let ((keyn key))
-		  (if (member (string-downcase keyn)
-			      (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count"
-				    "pass_count" "contour"))
-		      (begin
-			(print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table, you must remove your megatest.db and <linktree>/.db before trying again.")
-			(exit 1)))))
-	      keys)
-    (sqlite3:with-transaction
-     db
-     (lambda ()
-      ;; handle-exceptions
-      ;; exn
-      ;; (begin
-      ;;   (debug:print 0 "ERROR: Failed to create tables. Look at your [fields] section, should be: fieldname TEXT DEFAULT 'yourdefault'")
-      ;;   (exit))
-	(sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));")
-	(for-each (lambda (key)
-		    (sqlite3:execute db "INSERT OR REPLACE INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT"))
-		  keys)
-	(sqlite3:execute db (conc 
-			     "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, \n			 " 
-			     fieldstr (if havekeys "," "") "
-			 runname    TEXT DEFAULT 'norun',
-                         contour    TEXT DEFAULT '',
-			 state      TEXT DEFAULT '',
-			 status     TEXT DEFAULT '',
-			 owner      TEXT DEFAULT '',
-			 event_time TIMESTAMP DEFAULT (strftime('%s','now')),
-			 comment    TEXT DEFAULT '',
-			 fail_count INTEGER DEFAULT 0,
-			 pass_count INTEGER DEFAULT 0,
-                         last_update INTEGER DEFAULT (strftime('%s','now')),
-			 CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));"))
-        ;; All triggers created at once in end
-	;;(sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs
-        ;;                    FOR EACH ROW
-        ;;                       BEGIN 
-        ;;                         UPDATE runs SET last_update=(strftime('%s','now'))
-        ;;                           WHERE id=old.id;
-        ;;                       END;")
-	(sqlite3:execute db "CREATE TABLE IF NOT EXISTS run_stats (
-                              id     INTEGER PRIMARY KEY,
-                              run_id INTEGER,
-                              state  TEXT,
-                              status TEXT,
-                              count  INTEGER,
-                              last_update INTEGER DEFAULT (strftime('%s','now')))")
-         ;; All triggers created at once in end
-         ;; (sqlite3:execute db "CREATE TRIGGER  IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats
-         ;;                   FOR EACH ROW
-         ;;                     BEGIN 
-         ;;                       UPDATE run_stats SET last_update=(strftime('%s','now'))
-         ;;                         WHERE id=old.id;
-         ;;                      END;")
-	(sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta (
-                                     id          INTEGER PRIMARY KEY,
-                                     testname    TEXT DEFAULT '',
-                                     author      TEXT DEFAULT '',
-                                     owner       TEXT DEFAULT '',
-                                     description TEXT DEFAULT '',
-                                     reviewed    TIMESTAMP,
-                                     iterated    TEXT DEFAULT '',
-                                     avg_runtime REAL,
-                                     avg_disk    REAL,
-                                     tags        TEXT DEFAULT '',
-                                     jobgroup    TEXT DEFAULT 'default',
-                                CONSTRAINT test_meta_constraint UNIQUE (testname));")
-	(sqlite3:execute db "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY,
-                                action TEXT DEFAULT '',
-                                owner TEXT,
-                                state TEXT DEFAULT 'new',
-                                target TEXT DEFAULT '',
-                                name TEXT DEFAULT '',
-                                testpatt TEXT DEFAULT '',
-                                keylock TEXT,
-                                params TEXT,
-                                creation_time TIMESTAMP DEFAULT (strftime('%s','now')),
-                                execution_time TIMESTAMP);")
-	;; archive disk areas, cached info from [archive-disks]
-	(sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_disks (
-                                id INTEGER PRIMARY KEY,
-                                archive_area_name TEXT,
-                                disk_path TEXT,
-                                last_df INTEGER DEFAULT -1,
-                                last_df_time TIMESTAMP DEFAULT (strftime('%s','now')),
-                                creation_time TIMESTAMP DEFAULT (strftime('%s','now')));")
-	;; individual bup (or tar) data chunks
-	(sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_blocks (
-                                id INTEGER PRIMARY KEY,
-                                archive_disk_id INTEGER,
-                                disk_path TEXT,
-                                last_du INTEGER DEFAULT -1,
-                                last_du_time TIMESTAMP DEFAULT (strftime('%s','now')),
-                                creation_time TIMESTAMP DEFAULT (strftime('%s','now')));")
-	;; tests allocated to what chunks. reusing a chunk for a test/item_path is very efficient
-	;; NB// the per run/test recording of where the archive is stored is done in the test
-	;;      record. 
-	(sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_allocations (
-                                id INTEGER PRIMARY KEY,
-                                archive_block_id INTEGER,
-                                testname TEXT,
-                                item_path TEXT,
-                                creation_time TIMESTAMP DEFAULT (strftime('%s','now')));")
-	;; move this clean up call somewhere else
-	(sqlite3:execute db "DELETE FROM tasks_queue WHERE state='done' AND creation_time < ?;" (- (current-seconds)(* 24 60 60))) ;; remove older than 24 hrs
-	(sqlite3:execute db (conc "CREATE INDEX IF NOT EXISTS runs_index ON runs (runname" (if havekeys "," "") keystr ");"))
-	;; (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;")
-	(sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);")
-	(sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT,
-                                  CONSTRAINT metadat_constraint UNIQUE (var));")
-	(sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);")
-	;; Must do this *after* running patch db !! No more. 
-	;; cannot use db:set-var since it will deadlock, hardwire the code here
-	(sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" (common:version-signature))
-	(debug:print-info 11 *default-log-port* "db:initialize END") ;; ))))
-
-	;;======================================================================
-	;; R U N   S P E C I F I C   D B 
-	;;======================================================================
-	
-	;; (define (db:initialize-run-id-db db)
-	;;   (sqlite3:with-transaction 
-	;;    db
-	;;    (lambda ()
-	(sqlite3:execute db "CREATE TABLE IF NOT EXISTS tests 
-                    (id INTEGER PRIMARY KEY,
-                     run_id       INTEGER   DEFAULT -1,
-                     testname     TEXT      DEFAULT 'noname',
-                     host         TEXT      DEFAULT 'n/a',
-                     cpuload      REAL      DEFAULT -1,
-                     diskfree     INTEGER   DEFAULT -1,
-                     uname        TEXT      DEFAULT 'n/a', 
-                     rundir       TEXT      DEFAULT '/tmp/badname',
-                     shortdir     TEXT      DEFAULT '/tmp/badname',
-                     item_path    TEXT      DEFAULT '',
-                     state        TEXT      DEFAULT 'NOT_STARTED',
-                     status       TEXT      DEFAULT 'FAIL',
-                     attemptnum   INTEGER   DEFAULT 0,
-                     final_logf   TEXT      DEFAULT 'logs/final.log',
-                     logdat       TEXT      DEFAULT '', 
-                     run_duration INTEGER   DEFAULT 0,
-                     comment      TEXT      DEFAULT '',
-                     event_time   TIMESTAMP DEFAULT (strftime('%s','now')),
-                     fail_count   INTEGER   DEFAULT 0,
-                     pass_count   INTEGER   DEFAULT 0,
-                     archived     INTEGER   DEFAULT 0, -- 0=no, > 1=archive block id where test data can be found
-                     last_update  INTEGER DEFAULT (strftime('%s','now')),
-                        CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path));")
-	;; deprecated -- (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path, uname);")
-        
-        (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_run_id_index ON tests (run_id);")  ;; new
-        (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_testname_index ON tests (testname,item_path);") ;; new
-        (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_state_status_index ON tests (state, status); ") ;; new
-
-         ;; All triggers created at once in end
-	;;(sqlite3:execute db "CREATE TRIGGER  IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests
-        ;;                     FOR EACH ROW
-        ;;                       BEGIN 
-        ;;                         UPDATE tests SET last_update=(strftime('%s','now'))
-        ;;                           WHERE id=old.id;
-        ;;                       END;")
-	(sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps 
-                              (id INTEGER PRIMARY KEY,
-                               test_id INTEGER, 
-                               stepname TEXT, 
-                               state TEXT DEFAULT 'NOT_STARTED', 
-                               status TEXT DEFAULT 'n/a',
-                               event_time TIMESTAMP,
-                               comment TEXT DEFAULT '',
-                               logfile TEXT DEFAULT '',
-                               last_update  INTEGER DEFAULT (strftime('%s','now')),
-                               CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));")
-	(sqlite3:execute db "CREATE INDEX IF NOT EXISTS teststeps_index ON tests (run_id, testname, item_path);")
-        ;; All triggers created at once in end
-	;;(sqlite3:execute db "CREATE TRIGGER  IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps
-        ;;                     FOR EACH ROW
-        ;;                       BEGIN 
-        ;;                         UPDATE test_steps SET last_update=(strftime('%s','now'))
-        ;;                           WHERE id=old.id;
-        ;;                       END;")
-	(sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY,
-                                test_id INTEGER,
-                                category TEXT DEFAULT '',
-                                variable TEXT,
-	                        value REAL,
-	                        expected REAL,
-	                        tol REAL,
-                                units TEXT,
-                                comment TEXT DEFAULT '',
-                                status TEXT DEFAULT 'n/a',
-                                type TEXT DEFAULT '',
-                                last_update  INTEGER DEFAULT (strftime('%s','now')),
-                              CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));")
-	(sqlite3:execute db "CREATE INDEX IF NOT EXISTS test_data_index ON test_data (test_id);")
-        ;; All triggers created at once in end
-	;;(sqlite3:execute db "CREATE TRIGGER  IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data
-        ;;                     FOR EACH ROW
-        ;;                       BEGIN 
-        ;;                         UPDATE test_data SET last_update=(strftime('%s','now'))
-        ;;                           WHERE id=old.id;
-        ;;                       END;")
-	(sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat (
-                              id           INTEGER PRIMARY KEY,
-                              test_id      INTEGER,
-                              update_time  TIMESTAMP,
-                              cpuload      INTEGER DEFAULT -1,
-                              diskfree     INTEGER DEFAULT -1,
-                              diskusage    INTGER DEFAULT -1,
-                              run_duration INTEGER DEFAULT 0);")
-	(sqlite3:execute db "CREATE TABLE IF NOT EXISTS archives (
-                              id           INTEGER PRIMARY KEY,
-                              test_id      INTEGER,
-                              state        TEXT DEFAULT 'new',
-                              status       TEXT DEFAULT 'n/a',
-                              archive_type TEXT DEFAULT 'bup',
-                              du           INTEGER,
-                              archive_path TEXT);")))
-         (print "creating triggers from init") 
-        (db:create-triggers db)    
-     db)) ;; )
-
-;;======================================================================
-;; A R C H I V E S
-;;======================================================================
-
-;; dneeded is minimum space needed, scan for existing archives that 
-;; are on disks with adequate space and already have this test/itempath
-;; archived
-;;
-(define (db:archive-get-allocations dbstruct testname itempath dneeded)
-  (let* ((dbdat        (db:get-db dbstruct)) ;; archive tables are in main.db
-	 (db           (db:dbdat-get-db dbdat))
-	 (res          '())
-	 (blocks       '())) ;; a block is an archive chunck that can be added too if there is space
-    (sqlite3:for-each-row
-     (lambda (id archive-disk-id disk-path last-du last-du-time)
-       (set! res (cons (vector id archive-disk-id disk-path last-du last-du-time) res)))
-     db
-     "SELECT b.id,b.archive_disk_id,b.disk_path,b.last_du,b.last_du_time FROM archive_blocks AS b
-        INNER JOIN archive_allocations AS a ON a.archive_block_id=b.id
-        WHERE a.testname=? AND a.item_path=?;" 
-     testname itempath)
-    ;; Now res has list of candidate paths, look in archive_disks for candidate with potential free space
-    (if (null? res)
-	'()
-	(sqlite3:for-each-row
-	 (lambda (id archive-area-name disk-path last-df last-df-time)
-	   (set! blocks (cons (vector id archive-area-name disk-path last-df last-df-time) blocks)))
-	 db 
-	 (conc
-	  "SELECT d.id,d.archive_area_name,disk_path,last_df,last_df_time FROM archive_disks AS d
-             INNER JOIN archive_blocks AS b ON d.id=b.archive_disk_id
-             WHERE b.id IN (" (string-intersperse (map conc res) ",") ") AND
-         last_df > ?;")
-	 dneeded))
-    (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)
-    blocks))
-    
-;; returns id of the record, register a disk allocated to archiving and record it's last known
-;; available space
-;;
-(define (db:archive-register-disk dbstruct bdisk-name bdisk-path df)
-  (let* ((dbdat        (db:get-db dbstruct)) ;; archive tables are in main.db
-	 (db           (db:dbdat-get-db dbdat))
-	 (res          #f))
-    (sqlite3:for-each-row
-     (lambda (id)
-       (set! res id))
-     db
-     "SELECT id FROM archive_disks WHERE archive_area_name=? AND disk_path=?;"
-     bdisk-name bdisk-path)
-    (if res ;; record exists, update df and return id
-	(begin
-	  (sqlite3:execute db "UPDATE archive_disks SET last_df=?,last_df_time=(strftime('%s','now'))
-                                  WHERE archive_area_name=? AND disk_path=?;"
-			   df bdisk-name bdisk-path)
-          (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)
-	  res)
-	(begin
-	  (sqlite3:execute
-	   db
-	   "INSERT OR REPLACE INTO archive_disks (archive_area_name,disk_path,last_df)
-                VALUES (?,?,?);"
-	   bdisk-name bdisk-path df)
-          (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)
-	  (db:archive-register-disk dbstruct bdisk-name bdisk-path df)))))
-
-;; record an archive path created on a given archive disk (identified by it's bdisk-id)
-;; if path starts with / then it is full, otherwise it is relative to the archive disk
-;; preference is to store the relative path.
-;;
-(define (db:archive-register-block-name dbstruct bdisk-id archive-path #!key (du #f))
-  (let* ((dbdat        (db:get-db dbstruct)) ;; archive tables are in main.db
-	 (db           (db:dbdat-get-db dbdat))
-	 (res          #f))
-    ;; first look to see if this path is already registered
-    (sqlite3:for-each-row
-     (lambda (id)
-       (set! res id))
-     db
-     "SELECT id FROM archive_blocks WHERE archive_disk_id=? AND disk_path=?;"
-     bdisk-id archive-path)
-    (if res ;; record exists, update du if applicable and return res
-	(if du (sqlite3:execute db "UPDATE archive_blocks SET last_du=?,last_du_time=(strftime('%s','now'))
-                                          WHERE archive_disk_id=? AND disk_path=?;"
-				bdisk-id archive-path du))
-	(begin
-	  (sqlite3:execute db "INSERT OR REPLACE INTO archive_blocks (archive_disk_id,disk_path,last_du)
-                                                        VALUES (?,?,?);"
-			   bdisk-id archive-path (or du 0))
-	  (set! res (db:archive-register-block-name dbstruct bdisk-id archive-path du: du))))
-    (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)
-    res))
-
-
-;; The "archived" field in tests is overloaded; 0 = not archived, > 0 archived in block with given id
-;;
-(define (db:test-set-archive-block-id dbstruct run-id test-id archive-block-id)
-  (db:with-db
-   dbstruct
-   run-id
-   #f
-   (lambda (db)
-     (sqlite3:execute db "UPDATE tests SET archived=? WHERE id=?;"
-		      archive-block-id test-id))))
- 
-;; Look up the archive block info given a block-id
-;;
-(define (db:test-get-archive-block-info dbstruct archive-block-id)
-  (db:with-db
-   dbstruct
-   #f
-   #f
-   (lambda (db)
-     (let ((res #f))
-       (sqlite3:for-each-row 
-	;;        0         1           2        3          4           5
-	(lambda (id archive-disk-id disk-path last-du last-du-time creation-time)
-	  (set! res (vector id archive-disk-id disk-path last-du last-du-time creation-time)))
-	db
-	"SELECT id,archive_disk_id,disk_path,last_du,last_du_time,creation_time FROM archive_blocks WHERE id=?;"
-	archive-block-id)
-       res))))
-
-;; (define (db:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey)
-;;   (let* ((dbdat        (db:get-db dbstruct #f)) ;; archive tables are in main.db
-;; 	 (db           (db:dbdat-get-db dbdat))
-;; 	 (res          '())
-;; 	 (blocks       '())) ;; a block is an archive chunck that can be added too if there is space
-;;     (sqlite3:for-each-row  #f)
-
-;;======================================================================
-;; L O G G I N G    D B 
-;;======================================================================
-
-(define (open-logging-db)
-  (let* ((dbpath    (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname)
-	 (dbexists  (common:file-exists? dbpath))
-	 (db        (sqlite3:open-database dbpath))
-	 (handler   (sqlite3:make-busy-timeout (if (args:get-arg "-override-timeout")
-					   (string->number (args:get-arg "-override-timeout"))
-					   136000)))) ;; 136000)))
-    (sqlite3:set-busy-handler! db handler)
-    (if (not dbexists)
-	(begin
-	  (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log (id INTEGER PRIMARY KEY,event_time TIMESTAMP DEFAULT (strftime('%s','now')),logline TEXT,pwd TEXT,cmdline TEXT,pid INTEGER);")
-	  (db:set-sync db) ;; (sqlite3:execute db (conc "PRAGMA synchronous = 0;"))
-	  ))
-    db))
-
-(define (db:log-local-event . loglst)
-  (let ((logline (apply conc loglst)))
-    (db:log-event logline)))
-
-(define (db:log-event logline)
-  (let ((db (open-logging-db)))
-    (sqlite3:execute db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);"
-		     logline
-		     (current-directory)
-		     (string-intersperse (argv) " ")
-		     (current-process-id))
-    (sqlite3:finalize! db)
-    logline))
-
-;;======================================================================
-;; D B   U T I L S
-;;======================================================================
-
-;;======================================================================
-;; M A I N T E N A N C E
-;;======================================================================
-
-(define (db:have-incompletes? dbstruct run-id ovr-deadtime)
-  (let* ((incompleted '())
-	 (oldlaunched '())
-	 (toplevels   '())
-	 (deadtime-str (configf:lookup *configdat* "setup" "deadtime"))
-	 (deadtime     (if (and deadtime-str
-				(string->number deadtime-str))
-			   (string->number deadtime-str)
-			   72000))) ;; twenty hours
-    (db:with-db
-     dbstruct #f #f
-     (lambda (db)
-       (if (number? ovr-deadtime)(set! deadtime ovr-deadtime))
-       
-       ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes
-       ;;
-       ;; HOWEVER: this code in run:test seems to work fine
-       ;;              (> (- (current-seconds)(+ (db:test-get-event_time testdat)
-       ;;                     (db:test-get-run_duration testdat)))
-       ;;                    600) 
-       ;; (db:delay-if-busy dbdat)
-       (sqlite3:for-each-row 
-        (lambda (test-id run-dir uname testname item-path)
-          (if (and (equal? uname "n/a")
-                   (equal? item-path "")) ;; this is a toplevel test
-              ;; what to do with toplevel? call rollup?
-              (begin
-                (set! toplevels   (cons (list test-id run-dir uname testname item-path run-id) toplevels))
-                (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id))
-              (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted))))
-        db
-        "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');"
-        run-id deadtime)
-
-       ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config
-       ;;
-       ;; (db:delay-if-busy dbdat)
-       (sqlite3:for-each-row
-        (lambda (test-id run-dir uname testname item-path)
-          (if (and (equal? uname "n/a")
-                   (equal? item-path "")) ;; this is a toplevel test
-              ;; what to do with toplevel? call rollup?
-              (set! toplevels   (cons (list test-id run-dir uname testname item-path run-id) toplevels))
-              (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched))))
-        db
-        "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');"
-        run-id)
-       
-       (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.")
-       (if (and (null? incompleted)
-                (null? oldlaunched)
-                (null? toplevels))
-           #f
-           #t)))))
-
-(define (db:get-status-from-final-status-file run-dir)
-  (let ((infile (conc run-dir "/.final-status")))
-    ;; first verify we are able to write the output file
-    (if (not (file-read-access? infile))
-        (begin 
-	  (debug:print 0 *default-log-port* "ERROR: cannot read " infile)
-          (debug:print 0 *default-log-port* "ERROR: run-dir is " run-dir)
-          #f
-          )
-        (with-input-from-file infile read-lines)
-	)))
-
-;;  select end_time-now from
-;;      (select testname,item_path,event_time+run_duration as
-;;                          end_time,strftime('%s','now') as now from tests where state in
-;;      ('RUNNING','REMOTEHOSTSTART','LAUNCHED'));
+;; MUST RESOLVE mt:process-triggers before these can move to dbmod.
+
+;; set tests with state currstate and status currstatus to newstate and newstatus
+;; use currstate = #f and or currstatus = #f to apply to any state or status respectively
+;; WARNING: SQL injection risk. NB// See new but not yet used "faster" version below
+;;
+;;  AND NOT (item_path='' AND testname in (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")))
+;;  (debug:print 0 *default-log-port* "QRY: " qry)
+;;  (db:delay-if-busy)
+;;
+;; NB// This call only operates on toplevel tests. Consider replacing it with more general call
+;;
+(define (db:set-tests-state-status dbstruct run-id testnames currstate currstatus newstate newstatus)
+  (let ((test-ids '()))
+    (for-each
+     (lambda (testname)
+       (let ((qry (conc "UPDATE tests SET state=?,status=? WHERE "
+			(if currstate  (conc "state='" currstate "' AND ") "")
+			(if currstatus (conc "status='" currstatus "' AND ") "")
+			" run_id=? AND testname LIKE ?;"))
+	     (test-id (db:get-test-id dbstruct run-id testname "")))
+	 (db:with-db
+	  dbstruct
+	  run-id
+	  #t
+	  (lambda (db)
+	    (sqlite3:execute db qry
+			     (or newstate  currstate "NOT_STARTED")
+			     (or newstatus currstate "UNKNOWN")
+			     run-id testname)))
+	 (if test-id
+	     (begin
+	       (set! test-ids (cons test-id test-ids))
+	       (mt:process-triggers dbstruct run-id test-id newstate newstatus)))))
+     testnames)
+    test-ids))
+
+;; state is the priority rollup of all states
+;; status is the priority rollup of all completed statesfu
+;;
+;; if test-name is an integer work off that instead of test-name test-path
+;;
+(define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment)
+  ;; establish info on incoming test followed by info on top level test
+  ;; BBnote - for mode itemwait, linkage between upstream test & matching item status is propagated to run queue in db:prereqs-not-met
+  (let* ((testdat      (if (number? test-name)
+			   (db:get-test-info-by-id dbstruct run-id test-name) ;; test-name is actually a test-id
+			   (db:get-test-info       dbstruct run-id test-name item-path)))
+	 (test-id      (db:test-get-id testdat))
+	 (test-name    (if (number? test-name)
+			   (db:test-get-testname testdat)
+			   test-name))
+	 (item-path    (db:test-get-item-path testdat))
+         (tl-testdat   (db:get-test-info dbstruct run-id test-name ""))
+         (tl-test-id   (if tl-testdat
+			   (db:test-get-id tl-testdat)
+			   #f)))
+    (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) 
+	(db:general-call dbstruct 'set-test-start-time (list test-id)))
+    (mutex-lock! *db-transaction-mutex*)
+    (db:with-db
+     dbstruct #f #f
+     (lambda (db)
+       (let ((tr-res
+              (sqlite3:with-transaction
+               db
+               (lambda ()
+                 ;; NB// Pass the db so it is part fo the transaction
+                 (db:test-set-state-status db run-id test-id state status comment) ;; this call sets the item state/status
+                 (if (not (equal? item-path "")) ;; only roll up IF incoming test is an item
+                     (let* ((state-status-counts  (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path state status)) ;; item-path is used to exclude current state/status of THIS test
+			      						  (state-stauses (db:roll-up-rules state-status-counts state status))
+                          (newstate (car state-stauses))
+                          (newstatus (cadr state-stauses)))
+                       (debug:print 4 *default-log-port* "BB> tl-test-id="tl-test-id" ; "test-name":"item-path" newstate="newstate" newstatus="newstatus" len(sscs)="(length state-status-counts)  " state-status-counts: "
+							(apply conc
+                  (map (lambda (x)
+                     (conc
+                     		(with-output-to-string (lambda () (pp (dbr:counts->alist x)))) " | "))
+                              state-status-counts))); end debug:print
+   
+                       (if tl-test-id
+			   (db:test-set-state-status db run-id tl-test-id newstate newstatus #f)) ;; we are still in the transaction - must access the db and not the dbstruct
+		       ))))))
+         (mutex-unlock! *db-transaction-mutex*)
+         (if (and test-id state status (equal? status "AUTO")) 
+             (db:test-data-rollup dbstruct run-id test-id status))
+         tr-res)))))
+
+;; ;; speed up for common cases with a little logic
+;; ;; NB// Ultimately this will be deprecated in deference to mt:test-set-state-status-by-id
+;;
+;;      NOTE: run-id is not used
+;; ;;
+(define (db:test-set-state-status dbstruct run-id test-id newstate newstatus newcomment)
+  (db:with-db
+   dbstruct
+   ;; run-id
+   #f
+   #t
+   (lambda (db)
+     (cond
+      ((and newstate newstatus newcomment)
+       (sqlite3:execute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus newcomment ;; (sdb:qry 'getid newcomment)
+			test-id))
+      ((and newstate newstatus)
+       (sqlite3:execute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id))
+      (else
+       (if newstate   (sqlite3:execute db "UPDATE tests SET state=?   WHERE id=?;" newstate   test-id))
+       (if newstatus  (sqlite3:execute db "UPDATE tests SET status=?  WHERE id=?;" newstatus  test-id))
+       (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment ;; (sdb:qry 'getid newcomment)
+				       test-id))))))
+  (mt:process-triggers dbstruct run-id test-id newstate newstatus))
 
 (define (db:find-and-mark-incomplete dbstruct run-id ovr-deadtime)
   (let* ((incompleted '())
 	 (oldlaunched '())
 	 (toplevels   '())
@@ -1921,3083 +299,105 @@
 				   dbstruct run-id test-id 'foo "COMPLETED" "DEAD"
 				   "Test stopped responding while in RUNNING or REMOTEHOSTSTART; presumed dead.")))))))
 		  ;; call end of eud of run detection for posthook - from merge, is it needed?
 		  ;; (launch:end-of-run-check run-id)
 		  all-ids)
-		 ;;call end of eud of run detection for posthook
-		 (launch:end-of-run-check run-id)
+
+		 ;; MOVE TO rmt:find-and-mark-incomplete - for now always call launch:end-of-run-check after
+		 ;; calling rmt:find-and-mark-incompletes
+		 
+		 ;;ALWAYS CALL after rmt:find-and-mark-incompletes
+		 ;; call end of eud of run detection for posthook
+		 ;; (launch:end-of-run-check run-id)
+
 		 )))))))
 
-;; BUG: Probably broken - does not explicitly use run-id in the query
-;;
-(define (db:top-test-set-per-pf-counts dbstruct run-id test-name)
-  (db:general-call dbstruct 'top-test-set-per-pf-counts (list test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name)))
-
-;; Clean out old junk and vacuum the database
-;;
-;; Ultimately do something like this:
-;;
-;; 1. Look at test records either deleted or part of deleted run:
-;;    a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown'
-;;    b. If test dir gone, delete the test record
-;; 2. Look at run records
-;;    a. If have tests that are not deleted, set state='unknown'
-;;    b. ....
-;;
-(define (db:clean-up dbdat)
-  ;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db")
-  (let* ((keep-record-age ( - (current-seconds) (common:hms-string->seconds (or (configf:lookup *configdat* "setup" "delete-record-age") "30d"))))
-	 (db         (db:dbdat-get-db dbdat))
-	 (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);"))
-	(statements
-	 (map (lambda (stmt)
-		(sqlite3:prepare db stmt))
-	      (list
-	       ;; delete all tests that belong to runs that are 'deleted'
-	       (conc "DELETE FROM tests WHERE run_id in (SELECT id FROM runs WHERE state='deleted') and last_update < " keep-record-age ";")
-	       ;; delete all tests that are 'DELETED'
-	       (conc "DELETE FROM tests WHERE state='DELETED' and last_update < " keep-record-age " ;")
-	       ;; delete all tests that have no run
-	       (conc "DELETE FROM tests WHERE run_id NOT IN (SELECT DISTINCT id FROM runs) and last_update < " keep-record-age "; ")
-	       ;; delete all runs that are state='deleted'
-	       (conc "DELETE FROM runs WHERE state='deleted' and last_update < " keep-record-age ";")
-	       ;; delete empty runs
-	       (conc "DELETE FROM runs WHERE id NOT IN (SELECT DISTINCT r.id FROM runs AS r INNER JOIN tests AS t ON t.run_id=r.id) and last_update < " keep-record-age ";")
-	       ;; remove orphaned test_rundat entries
-	       (conc "DELETE FROM test_rundat where test_id NOT IN (SELECT id FROM tests);")
-	       ;; remove orphaned test_steps entries
-	       (conc "DELETE FROM test_steps WHERE test_id NOT IN (SELECT id FROM tests);")
-               ;; remove orphaned test_dat entries
-	       (conc "DELETE FROM test_data WHERE test_id NOT IN (SELECT id FROM tests);")
-
-	       ))))
-    ;; (db:delay-if-busy dbdat)
-    ;(debug:print-info 0 *default-log-port*  statements) 
-    (sqlite3:with-transaction 
-     db
-     (lambda ()
-       (sqlite3:for-each-row (lambda (tot)
-			       (debug:print-info 0 *default-log-port* "Records count before clean: " tot))
-			     count-stmt)
-       (map sqlite3:execute statements)
-       (sqlite3:for-each-row (lambda (tot)
-			       (debug:print-info 0 *default-log-port* "Records count after  clean: " tot))
-			     count-stmt)))
-    (map sqlite3:finalize! statements)
-    (sqlite3:finalize! count-stmt)
-    ;; (db:find-and-mark-incomplete db)
-    ;; (db:delay-if-busy dbdat)
-    (sqlite3:execute db "VACUUM;")))
-
-;; Clean out old junk and vacuum the database
-;;
-;; Ultimately do something like this:
-;;
-;; 1. Look at test records either deleted or part of deleted run:
-;;    a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown'
-;;    b. If test dir gone, delete the test record
-;; 2. Look at run records
-;;    a. If have tests that are not deleted, set state='unknown'
-;;    b. ....
-;;
-(define (db:clean-up-rundb dbdat)
-  ;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db")
-  (let* ((db         (db:dbdat-get-db dbdat))
-	 (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests);"))
-	(statements
-	 (map (lambda (stmt)
-		(sqlite3:prepare db stmt))
-	      (list
-	       ;; delete all tests that belong to runs that are 'deleted'
-	       ;; (conc "DELETE FROM tests WHERE run_id NOT IN (" (string-intersperse (map conc valid-runs) ",") ");")
-	       ;; delete all tests that are 'DELETED'
-	       "DELETE FROM tests WHERE state='DELETED';"
-	       ))))
-    ;; (db:delay-if-busy dbdat)
-    (sqlite3:with-transaction 
-     db
-     (lambda ()
-       (sqlite3:for-each-row (lambda (tot)
-			       (debug:print-info 0 *default-log-port* "Records count before clean: " tot))
-			     count-stmt)
-       (map sqlite3:execute statements)
-       (sqlite3:for-each-row (lambda (tot)
-			       (debug:print-info 0 *default-log-port* "Records count after  clean: " tot))
-			     count-stmt)))
-    (map sqlite3:finalize! statements)
-    (sqlite3:finalize! count-stmt)
-    ;; (db:find-and-mark-incomplete db)
-    ;; (db:delay-if-busy dbdat)
-    (sqlite3:execute db "VACUUM;")))
-
-;; Clean out old junk and vacuum the database
-;;
-;; Ultimately do something like this:
-;;
-;; 1. Look at test records either deleted or part of deleted run:
-;;    a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown'
-;;    b. If test dir gone, delete the test record
-;; 2. Look at run records
-;;    a. If have tests that are not deleted, set state='unknown'
-;;    b. ....
-;;
-(define (db:clean-up-maindb dbdat)
-  ;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db")
-  (let* ((db         (db:dbdat-get-db dbdat))
-	 (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM runs);"))
-	 (statements
-	  (map (lambda (stmt)
-		 (sqlite3:prepare db stmt))
-	       (list
-		;; delete all tests that belong to runs that are 'deleted'
-		;; (conc "DELETE FROM tests WHERE run_id NOT IN (" (string-intersperse (map conc valid-runs) ",") ");")
-		;; delete all tests that are 'DELETED'
-		"DELETE FROM runs WHERE state='deleted';"
-		)))
-	 (dead-runs '()))
-    (sqlite3:for-each-row
-     (lambda (run-id)
-       (set! dead-runs (cons run-id dead-runs)))
-       db
-       "SELECT id FROM runs WHERE state='deleted';")
-    ;; (db:delay-if-busy dbdat)
-    (sqlite3:with-transaction 
-     db
-     (lambda ()
-       (sqlite3:for-each-row (lambda (tot)
-			       (debug:print-info 0 *default-log-port* "Records count before clean: " tot))
-			     count-stmt)
-       (map sqlite3:execute statements)
-       (sqlite3:for-each-row (lambda (tot)
-			       (debug:print-info 0 *default-log-port* "Records count after  clean: " tot))
-			     count-stmt)))
-    (map sqlite3:finalize! statements)
-    (sqlite3:finalize! count-stmt)
-    ;; (db:find-and-mark-incomplete db)
-    ;; (db:delay-if-busy dbdat)
-    (sqlite3:execute db "VACUUM;")
-    dead-runs))
-
-;;======================================================================
-;; M E T A   G E T   A N D   S E T   V A R S
-;;======================================================================
-
-;; returns number if string->number is successful, string otherwise
-;; also updates *global-delta*
-;;
-(define (db:get-var dbstruct var)
-  (let* ((res      #f))
-    (db:with-db
-     dbstruct #f #f
-     (lambda (db)
-       (sqlite3:for-each-row
-        (lambda (val)
-          (set! res val))
-        db
-        "SELECT val FROM metadat WHERE var=?;" var)
-       ;; convert to number if can
-       (if (string? res)
-           (let ((valnum (string->number res)))
-             (if valnum (set! res valnum))))
-       res))))
-
-(define (db:inc-var dbstruct var)
-  (db:with-db dbstruct #f #t 
-	      (lambda (db)
-		(sqlite3:execute db "UPDATE metadat SET val=val+1 WHERE var=?;" var))))
-
-(define (db:dec-var dbstruct var)
-  (db:with-db dbstruct #f #t 
-	      (lambda (db)
-		(sqlite3:execute db "UPDATE metadat SET val=val-1 WHERE var=?;" var))))
-
-;; This was part of db:get-var. It was used to estimate the load on
-;; the database files.
-;;
-;; scale by 10, average with current value.
-;;     (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms)
-;; 						 (if throttle throttle 0.01)))
-;; 			    2))
-;;     (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit
-;; 	(begin
-;; 	  (debug:print-info 4 *default-log-port* "launch throttle factor=" *global-delta*)
-;; 	  (set! *last-global-delta-printed* *global-delta*)))
-
-(define (db:set-var dbstruct var val)
-  (db:with-db dbstruct #f #t 
-	      (lambda (db)
-		(sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val))))
-
-(define (db:add-var dbstruct var val)
-  (db:with-db dbstruct #f #t 
-	      (lambda (db)
-		(sqlite3:execute db "UPDATE metadat SET val=val+? WHERE var=?;" val var))))
-
-(define (db:del-var dbstruct var)
-  (db:with-db dbstruct #f #t 
-	      (lambda (db)
-		(sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var))))
-
-;;======================================================================
-;; no-sync.db - small bits of data to be shared between servers
-;;======================================================================
-
-(define (db:open-no-sync-db)
-  (let* ((dbpath (db:dbfile-path))
-	 (dbname (conc dbpath "/no-sync.db"))
-	 (db-exists (common:file-exists? dbname))
-	 (db     (sqlite3:open-database dbname)))
-    (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
-    (if (not db-exists)
-	(begin
-	  (sqlite3:execute db "PRAGMA synchronous = 0;")
-	  (sqlite3:execute db "CREATE TABLE IF NOT EXISTS no_sync_metadat (var TEXT,val TEXT, CONSTRAINT no_sync_metadat_constraint UNIQUE (var));")
-	  (sqlite3:execute db "PRAGMA journal_mode=WAL;")))
-    db))
-
-;; if we are not a server create a db handle. this is not finalized
-;; so watch for problems. I'm still not clear if it is needed to manually
-;; finalize sqlite3 dbs with the sqlite3 egg.
-;;
-(define (db:no-sync-db db-in)
-  (mutex-lock! *db-access-mutex*)
-  (let ((res (if db-in
-                 db-in
-                 (let ((db (db:open-no-sync-db)))
-                   (set! *no-sync-db* db)
-                   db))))
-    (mutex-unlock! *db-access-mutex*)
-    res))
-
-(define (db:no-sync-set db var val)
-  (sqlite3:execute (db:no-sync-db db) "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES (?,?);" var val))
-
-(define (db:no-sync-del! db var)
-  (sqlite3:execute (db:no-sync-db db) "DELETE FROM no_sync_metadat WHERE var=?;" var))
-
-(define (db:no-sync-get/default db var default)
-  (let ((res default))
-    (sqlite3:for-each-row
-     (lambda (val)
-       (set! res val))
-     (db:no-sync-db db)
-     "SELECT val FROM no_sync_metadat WHERE var=?;"
-     var)
-    (if res
-        (let ((newres (if (string? res)
-			  (string->number res)
-			  #f)))
-          (if newres
-              newres
-              res))
-        res)))
-
-(define (db:no-sync-close-db db stmt-cache)
-  (db:safely-close-sqlite3-db db stmt-cache))
-
-;; transaction protected lock aquisition
-;; either:
-;;    fails    returns  (#f . lock-creation-time)
-;;    succeeds (returns (#t . lock-creation-time)
-;; use (db:no-sync-del! db keyname) to release the lock
-;;
-(define (db:no-sync-get-lock db-in keyname)
-  (let ((db (db:no-sync-db db-in)))
-    (sqlite3:with-transaction
-     db
-     (lambda ()
-       (handle-exceptions
-	   exn
-	 (let ((lock-time (current-seconds)))
-	   (debug:print-info 2 *default-log-port* "db:no-sync-get-lock keyname=" keyname ", lock-time=" lock-time ", exn=" exn)
-	   (sqlite3:execute db "INSERT INTO no_sync_metadat (var,val) VALUES(?,?);" keyname lock-time)
-	   `(#t . ,lock-time))
-	 `(#f . ,(sqlite3:first-result db "SELECT val FROM no_sync_metadat WHERE var=?;" keyname)))))))
-
-
-
-;; use a global for some primitive caching, it is just silly to
-;; re-read the db over and over again for the keys since they never
-;; change
-
-;; why get the keys from the db? why not get from the *configdat*
-;; using keys:config-get-fields?
-
-(define (db:get-keys dbstruct)
-  (if *db-keys* *db-keys* 
-      (let ((res '()))
-	(db:with-db dbstruct #f #f
-		    (lambda (db)
-		      (sqlite3:for-each-row 
-		       (lambda (key)
-			 (set! res (cons key res)))
-		       db
-		       "SELECT fieldname FROM keys ORDER BY id DESC;")))
-	(set! *db-keys* res)
-	res)))
-
-;; extract index number given a header/data structure
-(define (db:get-index-by-header header field)
-  (list-index (lambda (x)(equal? x field)) header))
-
-;; look up values in a header/data structure
-(define (db:get-value-by-header row header field)
-  (if (or (null? header) (not row))
-      #f
-      (let loop ((hed (car header))
-                 (tal (cdr header))
-                 (n   0))
-        (if (equal? hed field)
-            (handle-exceptions
-             exn
-             (begin
-               (debug:print 0 *default-log-port* "WARNING: attempt to read non-existant field, row="
-			    row " header=" header " field=" field ", exn=" exn)
-               #f)
-             (vector-ref row n))
-	    (if (null? tal) #f (loop (car tal)(cdr tal)(+ n 1)))))))
-
-;; Accessors for the header/data structure
-;; get rows and header from 
-(define (db:get-header vec)(vector-ref vec 0))
-(define (db:get-rows   vec)(vector-ref vec 1))
-
-;;======================================================================
-;;  R U N S
-;;======================================================================
-
-
-
-
-
-(define (db:get-run-times dbstruct run-patt target-patt)
-(let ((res `())
-           (qry 	(conc "select runname, (max(end_time)-min(event_time))/60 as runtime, target from (select runname, run_id,tests.event_time,tests.event_time+run_duration AS end_time, " (string-join (db:get-keys dbstruct) " || '/' || ") " as target from tests inner join runs on tests.run_id = runs.id where runs.runname like ? and target like ?) group by run_id ;")))
-;(print qry)
-(db:with-db 
-   dbstruct
-   #f ;; this is for the main runs db
-   #f ;; does not modify db
-   (lambda (db)
-            (sqlite3:for-each-row
-	(lambda (runname runtime target )
-	  (set! res (cons (vector runname runtime target) res)))
-	db
-        qry 
-	run-patt target-patt)
-       
-       res))))
-
-
-
-(define (db:get-run-name-from-id dbstruct run-id)
-  (db:with-db 
-   dbstruct
-   #f ;; this is for the main runs db
-   #f ;; does not modify db
-   (lambda (db)
-     (let ((res #f))
-       (sqlite3:for-each-row
-	(lambda (runname)
-	  (set! res runname))
-	db
-	"SELECT runname FROM runs WHERE id=?;"
-	run-id)
-       res))))
-
-(define (db:get-run-key-val dbstruct run-id key)
-  (db:with-db
-   dbstruct
-   #f
-   #f
-   (lambda (db)
-     (let ((res #f))
-       (sqlite3:for-each-row
-	(lambda (val)
-	  (set! res val))
-	db
-	(conc "SELECT " key " FROM runs WHERE id=?;")
-	run-id)
-       res))))
-
-;; keys list to key1,key2,key3 ...
-(define (runs:get-std-run-fields keys remfields)
-  (let* ((header    (append keys remfields))
-	 (keystr    (conc (keys->keystr keys) ","
-			  (string-intersperse remfields ","))))
-    (list keystr header)))
-
-;; make a query (fieldname like 'patt1' OR fieldname 
-(define (db:patt->like fieldname pattstr #!key (comparator " OR "))
-  (let ((patts (if (string? pattstr)
-		   (string-split pattstr ",")
-		   '("%"))))
-    (string-intersperse (map (lambda (patt)
-			       (let ((wildtype (if (substring-index "%" patt) "LIKE" "GLOB")))
-				 (conc fieldname " " wildtype " '" patt "'")))
-			     (if (null? patts)
-				 '("")
-				 patts))
-			comparator)))
-
-
-;; register a test run with the db, this accesses the main.db and does NOT
-;; use server api
-;;
-(define (db:register-run dbstruct keyvals runname state status user contour-in)
-  (let* ((keys      (map car keyvals))
-	 (keystr    (keys->keystr keys))
-	 (contour   (or contour-in ""))  ;; empty string to force no hierarcy and be backwards compatible.
-	 (comma     (if (> (length keys) 0) "," ""))
-	 (andstr    (if (> (length keys) 0) " AND " ""))
-	 (valslots  (keys->valslots keys)) ;; ?,?,? ...
-	 (allvals   (append (list runname state status user contour) (map cadr keyvals)))
-	 (qryvals   (append (list runname) (map cadr keyvals)))
-	 (key=?str  (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND ")))
-    (debug:print 3 *default-log-port* "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str)
-    (debug:print 2 *default-log-port* "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run")
-    (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and"
-	(db:with-db
-	 dbstruct #f #f
-	 (lambda (db)
-	   (let ((res #f))
-	     (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time,contour" comma keystr ") VALUES (?,?,?,?,strftime('%s','now'),?" comma valslots ");")
-		    allvals)
-	     (apply sqlite3:for-each-row 
-		    (lambda (id)
-		      (set! res id))
-		    db
-		    (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");")))
-		      qry)
-		    qryvals)
-	     (sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res)
-	     res))) 
-	(begin
-	  (debug:print-error 0 *default-log-port* "Called without all necessary keys")
-	  #f))))
-
-;; replace header and keystr with a call to runs:get-std-run-fields
-;;
-;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
-;; runpatts: patt1,patt2 ...
-;;
-(define (db:get-runs dbstruct runpatt count offset keypatts)
-  (let* ((res       '())
-	 (keys       (db:get-keys dbstruct))
-	 (runpattstr (db:patt->like "runname" runpatt))
-	 (remfields  (list "id" "runname" "state" "status" "owner" "event_time"))
-	 (header     (append keys remfields))
-	 (keystr     (conc (keys->keystr keys) ","
-			   (string-intersperse remfields ",")))
-	 (qrystr     (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? "
-			   ;; Generate: " AND x LIKE 'keypatt' ..."
-			   (if (null? keypatts) ""
-			       (conc " AND "
-				     (string-join 
-				      (map (lambda (keypatt)
-					     (let ((key  (car keypatt))
-						   (patt (cadr keypatt)))
-					       (db:patt->like key patt)))
-					   keypatts)
-				      " AND ")))
-			   " AND state != 'deleted' ORDER BY event_time DESC "
-			   (if (number? count)
-			       (conc " LIMIT " count)
-			       "")
-			   (if (number? offset)
-			       (conc " OFFSET " offset)
-			       ""))))
-    (debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count)
-    (db:with-db dbstruct #f #f
-		(lambda (db)		
-		  (sqlite3:for-each-row
-		   (lambda (a . x)
-		     (set! res (cons (apply vector a x) res)))
-		   db
-		   qrystr
-		   )))
-    (debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count)
-    (vector header res)))
-
-
-(define-record simple-run target id runname state status owner event_time)
-(define-record-printer (simple-run x out)
-  (fprintf out "#,(simple-run ~S ~S ~S ~S)"
-	   (simple-run-target x) (simple-run-id x) (simple-run-runname x) (time->string (seconds->local-time (simple-run-event_time x) ))))
-
-;; simple get-runs
-;;
-(define (db:simple-get-runs dbstruct runpatt count offset target last-update)
-    (let* ((res       '())
-	   (keys       (db:get-keys dbstruct))
-	   (runpattstr (db:patt->like "runname" runpatt))
-	   (remfields  (list "id" "runname" "state" "status" "owner" "event_time"))
-	   (targstr    (string-intersperse keys "||'/'||"))
-	   (keystr     (conc targstr " AS target,"
-			     (string-intersperse remfields ",")))
-	   (qrystr     (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? "
-			     ;; Generate: " AND x LIKE 'keypatt' ..."
-			     " AND target LIKE '" target "'"
-			     " AND state != 'deleted' "
-			     (if (number? last-update)
-				 (conc " AND last_update >= " last-update)
-				 "")
-			     " ORDER BY event_time DESC "
-			     (if (number? count)
-				 (conc " LIMIT " count)
-				 "")
-			     (if (number? offset)
-				 (conc " OFFSET " offset)
-				 "")))
-	   )
-    (debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " target: " target " offset: " offset " limit: " count)
-    (db:with-db dbstruct #f #f
-		(lambda (db)		
-		  (sqlite3:for-each-row
-		   (lambda (target id runname state status owner event_time)
-		     (set! res (cons (make-simple-run target id runname state status owner event_time) res)))
-		   db
-		   qrystr
-		   )))
-    (debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " target: " target " offset: " offset " limit: " count)
-    res))
-
-;; TODO: Switch this to use max(update_time) from each run db? Then if using a server there is no disk traffic (using inmem db)
-;;
-(define (db:get-changed-run-ids since-time)
-  (let* ((dbdir      (db:dbfile-path)) ;; (configf:lookup *configdat* "setup" "dbdir"))
-	 (alldbs     (glob (conc dbdir "/[0-9]*.db")))
-	 (changed    (filter (lambda (dbfile)
-			       (> (file-modification-time dbfile) since-time))
-			     alldbs)))
-    (delete-duplicates
-     (map (lambda (dbfile)
-	    (let* ((res (string-match ".*\\/(\\d)*\\.db" dbfile)))
-	      (if res
-		  (string->number (cadr res))
-		  (begin
-		    (debug:print 2 *default-log-port* "WARNING: Failed to process " dbfile " for run-id")
-		    0))))
-	  changed))))
-
-;; Get all targets from the db
-;;
-(define (db:get-targets dbstruct)
-  (let* ((res       '())
-	 (keys       (db:get-keys dbstruct))
-	 (header     keys) ;; (map key:get-fieldname keys))
-	 (keystr     (keys->keystr keys))
-	 (qrystr     (conc "SELECT " keystr " FROM runs WHERE state != 'deleted';"))
-	 (seen       (make-hash-table)))
-    (db:with-db
-     dbstruct
-     #f
-     #f
-     (lambda (db)
-       (sqlite3:for-each-row
-	(lambda (a . x)
-	  (let ((targ (cons a x)))
-	    (if (not (hash-table-ref/default seen targ #f))
-		(begin
-		  (hash-table-set! seen targ #t)
-		  (set! res (cons (apply vector targ) res))))))
-	db
-	qrystr)
-       (debug:print-info 11 *default-log-port* "db:get-targets END qrystr: " qrystr )
-       (vector header res)))))
-
-;; just get count of runs
-(define (db:get-num-runs dbstruct runpatt)
-  (db:with-db
-   dbstruct
-   #f
-   #f
-   (lambda (db)
-     (let ((numruns 0))
-       (debug:print-info 11 *default-log-port* "db:get-num-runs START " runpatt)
-       (sqlite3:for-each-row 
-	(lambda (count)
-	  (set! numruns count))
-	db
-	"SELECT COUNT(id) FROM runs WHERE runname LIKE ? AND state != 'deleted';" runpatt)
-       (debug:print-info 11 *default-log-port* "db:get-num-runs END " runpatt)
-       numruns))))
-
-;; just get count of runs
-(define (db:get-runs-cnt-by-patt dbstruct runpatt targetpatt keys)
-  (db:with-db
-   dbstruct
-   #f
-   #f
-   (lambda (db)
-     (let ((numruns 0)
-           (qry-str #f)
-           (key-patt "")
-	     	   (keyvals  (if targetpatt (keys:target->keyval keys targetpatt) '())))
-     
-    (for-each (lambda (keyval)
-		(let* ((key    (car keyval))
-		       (patt   (cadr keyval))
-		       (fulkey (conc ":" key))
-		       (wildtype (if (substring-index "%" patt) "like" "glob")))
-         
-		  (if patt
-		      (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'"))
-		      (begin
-			(debug:print-error 0 *default-log-port* "searching for runs with no pattern set for " fulkey)
-			(exit 6)))))
-	      keyvals)
-    ;(print  runpatt " -- " key-patt)
-    (set! qry-str (conc "SELECT COUNT(id) FROM runs WHERE state != 'deleted' AND runname  like '" runpatt "'" key-patt))
-    ;(print qry-str )
-       
-       (sqlite3:for-each-row 
-					 (lambda (count)
-	  			    (set! numruns count))
-				db
-				qry-str)
-       (debug:print-info 11 *default-log-port* "db:get-num-runs END " runpatt)
-       numruns))))
-
-
-;; (sqlite3#fold-row proc3670 init3671 db-or-stmt3672 . params3673)>
-;; 
-(define (db:get-raw-run-stats dbstruct run-id)
-  (db:with-db
-   dbstruct
-   run-id
-   #f
-   (lambda (db)
-     (sqlite3:fold-row
-	(lambda (res state status count)
-	  (cons (list state status count) res))
-	'()
-	db
-	"SELECT state,status,count(id) AS count FROM tests WHERE run_id=? AND NOT(uname='n/a' AND item_path='') GROUP BY state,status;"
-	run-id))))
-
-;; Update run_stats for given run_id
-;; input data is a list (state status count)
-;;
-(define (db:update-run-stats dbstruct run-id stats)
-  ;; (mutex-lock! *db-transaction-mutex*)
-  (db:with-db
-   dbstruct
-   #f
-   #f
-
-   (lambda (db)
-     ;; remove previous data
-     
-     (let* ((stmt1 (sqlite3:prepare db "DELETE FROM run_stats WHERE run_id=? AND state=? AND status=?;"))
-	    (stmt2 (sqlite3:prepare db "INSERT INTO run_stats (run_id,state,status,count) VALUES (?,?,?,?);"))
-	    (res
-	     (sqlite3:with-transaction
-	      db
-	      (lambda ()
-		(for-each
-		 (lambda (dat)
-		   (sqlite3:execute stmt1 run-id (car dat)(cadr dat))
-		   (apply sqlite3:execute stmt2 run-id dat))
-		 stats)))))
-       (sqlite3:finalize! stmt1)
-       (sqlite3:finalize! stmt2)
-       ;; (mutex-unlock! *db-transaction-mutex*)
-       res))))
-
-(define (db:get-main-run-stats dbstruct run-id)
-  (db:with-db
-   dbstruct
-   #f ;; this data comes from main
-   #f
-   (lambda (db)
-     (sqlite3:fold-row
-	(lambda (res state status count)
-	  (cons (list state status count) res))
-	'()
-	db
-	"SELECT state,status,count FROM run_stats WHERE run_id=? AND run_id IN (SELECT id FROM runs WHERE state NOT IN ('DELETED','deleted'));"
-	run-id))))
-
-(define (db:print-current-query-stats)
-  ;; generate stats from *db-api-call-time*
-  (let ((ordered-keys (sort (hash-table-keys *db-api-call-time*)
-			    (lambda (a b)
-			      (let ((sum-a (common:sum (hash-table-ref *db-api-call-time* a)))
-				    (sum-b (common:sum (hash-table-ref *db-api-call-time* b))))
-				(> sum-a sum-b)))))
-	(total        0))
-    (for-each
-     (lambda (cmd-key)
-       (let* ((dat  (hash-table-ref *db-api-call-time* cmd-key))
-	      (num  (length dat))
-	      (avg  (if (> num 0)
-			(/ (common:sum dat)(length dat)))))
-	 (set! total (+ total num))
-	 (debug:print-info 0 *default-log-port* cmd-key "\tavg: " avg " max: " (common:max dat) " min: " (common:min-max < dat) " num: " (length dat))))
-     ordered-keys)
-    (debug:print-info 0 *default-log-port* "TOTAL: " total " api calls since start.")))
-
-(define (db:get-all-run-ids dbstruct)
-  (db:with-db
-   dbstruct
-   #f
-   #f
-   (lambda (db)
-     (let ((run-ids '()))
-       (sqlite3:for-each-row
-	(lambda (run-id)
-	  (set! run-ids (cons run-id run-ids)))
-	db
-	"SELECT id FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;")
-    (reverse run-ids)))))
-
-;; get some basic run stats
-;;
-;; data structure:
-;;
-;; ( (runname (( state  count ) ... ))
-;;   (   ...
-;;
-(define (db:get-run-stats dbstruct)
-  (let* ((totals       (make-hash-table))
-	 (curr         (make-hash-table))
-	 (res          '())
-	 (runs-info    '()))
-    ;; First get all the runname/run-ids
-    (db:with-db
-     dbstruct #f #f
-     (lambda (db)
-       (sqlite3:for-each-row
-	(lambda (run-id runname)
-	  (set! runs-info (cons (list run-id runname) runs-info)))
-	db
-	"SELECT id,runname FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;"))) ;; If you change this to the more logical ASC please adjust calls to db:get-run-stats
-    ;; for each run get stats data
-    (for-each
-     (lambda (run-info)
-       ;; get the net state/status counts for this run
-       (let* ((run-id   (car  run-info))
-	      (run-name (cadr run-info)))
-	 (db:with-db
-	  dbstruct
-	  run-id
-	  #f
-	  (lambda (db)
-	    (sqlite3:for-each-row
-	     (lambda (state status count)
-	       (let ((netstate (if (equal? state "COMPLETED") status state)))
-		 (if (string? netstate)
-		     (begin
-		       (hash-table-set! totals netstate (+ (hash-table-ref/default totals netstate 0) count))
-		       (hash-table-set! curr   netstate (+ (hash-table-ref/default curr   netstate 0) count))))))
-	     db
-	     "SELECT state,status,count(id) FROM tests AS t WHERE run_id=? GROUP BY state,status ORDER BY state,status DESC;"
-             run-id)
-	    ;; add the per run counts to res
-	    (for-each (lambda (state)
-			(set! res (cons (list run-name state (hash-table-ref curr state)) res)))
-		      (sort (hash-table-keys curr) string>=))
-	    (set! curr (make-hash-table))))))
-     runs-info)
-    (for-each (lambda (state)
-		(set! res (cons (list "Totals" state (hash-table-ref totals state)) res)))
-	      (sort (hash-table-keys totals) string>=))
-    res))
-
-;; db:get-runs-by-patt
-;; get runs by list of criteria
-;; register a test run with the db
-;;
-;; Use: (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
-;;  to extract info from the structure returned
-;;
-(define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit fields last-update  sort-order ) ;; test-name)
-  (let* ((tmp      (runs:get-std-run-fields keys (or fields '("id" "runname" "state" "status" "owner" "event_time"))))
-	 (keystr   (car tmp))
-	 (header   (cadr tmp))
-	 (key-patt "")
-	 (runwildtype (if (substring-index "%" runnamepatt) "like" "glob"))
-	 (qry-str  #f)
-	 (keyvals  (if targpatt (keys:target->keyval keys targpatt) '())))
-    (for-each (lambda (keyval)
-		(let* ((key    (car keyval))
-		       (patt   (cadr keyval))
-		       (fulkey (conc ":" key))
-		       (wildtype (if (substring-index "%" patt) "like" "glob")))
-		  (if patt
-		      (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'"))
-		      (begin
-			(debug:print-error 0 *default-log-port* "searching for runs with no pattern set for " fulkey)
-			(exit 6)))))
-	      keyvals)
-    (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt 
-			(if last-update
-			       (conc " AND last_update >= " last-update " ")
-			       " ")
-			" ORDER BY event_time " sort-order " " 
-			(if limit  (conc " LIMIT " limit)   "")
-			(if offset (conc " OFFSET " offset) "")
-			";"))
-    (debug:print-info 4 *default-log-port* "runs:get-runs-by-patt qry=" qry-str " " runnamepatt)
-    ;(print "runs:get-runs-by-patt qry=" qry-str " " runnamepatt)
-
-    (vector header 
-            (reverse
-             (db:with-db dbstruct #f #f ;; reads db, does not write to it.
-                         (lambda (db)
-                           (sqlite3:fold-row
-                            (lambda (res . r)
-                              (cons (list->vector r) res))
-                            '()
-                            db
-                            qry-str
-                            runnamepatt)))))))
-
-;; use (get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
-;; NOTE: Does NOT return a list of rows (or one row) for the first slot of the vector
-;;       this is inconsistent with get-runs but it makes some sense.
-;;
-(define (db:get-run-info dbstruct run-id)
-  ;;(if (hash-table-ref/default *run-info-cache* run-id #f)
-  ;;    (hash-table-ref *run-info-cache* run-id)
-  (let* ((res       (vector #f #f #f #f))
-	 (keys      (db:get-keys dbstruct))
-	 (remfields (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour" "last_update")) ;;  "area_id"))
-	 (header    (append keys remfields))
-	 (keystr    (conc (keys->keystr keys) ","
-			  (string-intersperse remfields ","))))
-    (debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)
-    
-    (db:with-db
-     dbstruct #f #f
-     (lambda (db)
-       (sqlite3:for-each-row
-	(lambda (a . x)
-	  (set! res (apply vector a x)))
-	db 
-	(conc "SELECT " keystr " FROM runs WHERE id=?;")
-	run-id)))
-    (debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)
-    (let ((finalres (vector header res)))
-      ;; (hash-table-set! *run-info-cache* run-id finalres)
-      finalres)))
-
-(define (db:set-comment-for-run dbstruct run-id comment)
-  (db:with-db
-   dbstruct #f #f
-   (lambda (db)
-     (sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment ;; (sdb:qry 'getid comment)
-		      run-id))))
-
-;; does not (obviously!) removed dependent data. But why not!!?
-(define (db:delete-run dbstruct run-id)
-  (db:with-db
-   dbstruct #f #f
-   (lambda (db)
-     (sqlite3:with-transaction
-      db
-      (lambda ()
-        (sqlite3:execute db "DELETE FROM test_steps WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);" run-id)
-        (sqlite3:execute db "DELETE FROM test_data WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);"  run-id)
-        (sqlite3:execute db "UPDATE tests SET state='DELETED',comment='' WHERE run_id=?;" run-id)
-        ;; (db:delay-if-busy dbdat)
-        (sqlite3:execute db "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id))))))
-
-(define (db:update-run-event_time dbstruct run-id)
-  (db:with-db
-   dbstruct #f #t
-   (lambda (db)
-     (sqlite3:execute db "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id))))
-
-(define (db:lock/unlock-run dbstruct run-id lock unlock user)
-  (db:with-db
-   dbstruct #f #t
-   (lambda (db)
-     (let ((newlockval (if lock "locked"
-			   (if unlock
-			       "unlocked"
-			       "locked")))) ;; semi-failsafe
-       (sqlite3:execute db "UPDATE runs SET state=? WHERE id=?;" newlockval run-id)
-       (sqlite3:execute db "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);"
-			user (conc newlockval " " run-id))
-       (debug:print-info 1 *default-log-port* "" newlockval " run number " run-id)))))
-
-(define (db:set-run-status dbstruct run-id status msg)
-  (db:with-db
-   dbstruct #f #f
-   (lambda (db)
-       (if msg
-         (sqlite3:execute db "UPDATE runs SET status=?,comment=? WHERE id=?;" status msg run-id)
-         (sqlite3:execute db "UPDATE runs SET status=? WHERE id=?;" status run-id)))))
-
-(define (db:set-run-state-status dbstruct run-id state status )
-  (db:with-db
-   dbstruct #f #f
-   (lambda (db)
-          (sqlite3:execute db "UPDATE runs SET status=?,state=? WHERE id=?;" status state run-id))))
-
-
-
-(define (db:get-run-status dbstruct run-id)
-  (let ((res "n/a"))
-    (db:with-db
-     dbstruct #f #f
-     (lambda (db)
-       (sqlite3:for-each-row 
-	(lambda (status)
-	  (set! res status))
-	db
-	"SELECT status FROM runs WHERE id=?;" 
-	run-id)
-       res))))
-
-(define (db:get-run-state dbstruct run-id)
-  (let ((res "n/a"))
-    (db:with-db
-     dbstruct #f #f
-     (lambda (db)
-       (sqlite3:for-each-row 
-	(lambda (status)
-	  (set! res status))
-	db
-	"SELECT state FROM runs WHERE id=?;" 
-	run-id)
-       res))))
-
-
-;;======================================================================
-;; K E Y S
-;;======================================================================
-
-;; get key val pairs for a given run-id
-;; ( (FIELDNAME1 keyval1) (FIELDNAME2 keyval2) ... )
-(define (db:get-key-val-pairs dbstruct run-id)
-  (let* ((keys (db:get-keys dbstruct))
-	 (res  '()))
-    (db:with-db
-     dbstruct #f #f
-     (lambda (db)
-       (for-each 
-	(lambda (key)
-	  (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
-	    (sqlite3:for-each-row 
-	     (lambda (key-val)
-	       (set! res (cons (list key (if (string? key-val) key-val "")) res))) ;; replace non-string bad values with empty string to prevent crashes. This scenario can happen when Megatest is killed on updating the db
-	     db qry run-id)))
-	keys)))
-       (reverse res)))
-
-;; get key vals for a given run-id
-(define (db:get-key-vals dbstruct run-id)
-  (let* ((keys (db:get-keys dbstruct))
-	 (res  '()))
-    (db:with-db
-     dbstruct #f #f
-     (lambda (db)
-       (for-each 
-	(lambda (key)
-	  (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
-	    ;; (db:delay-if-busy dbdat)
-	    (sqlite3:for-each-row 
-	     (lambda (key-val)
-	       (set! res (cons (if (string? key-val) key-val "") res))) ;; check that the key-val is a string for cases where a crash injected bad data in the megatest.db
-	     db qry run-id)))
-	keys)))
-    (let ((final-res (reverse res)))
-      (hash-table-set! *keyvals* run-id final-res)
-      final-res)))
-
-;; The target is keyval1/keyval2..., cached in *target* as it is used often
-(define (db:get-target dbstruct run-id)
-  (let* ((keyvals (db:get-key-vals dbstruct run-id))
-	 (thekey  (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/")))
-    thekey))
-
-;; Get run-ids for runs with same target but different runnames and NOT run-id
-;;
-(define (db:get-prev-run-ids dbstruct run-id)
-  (let* ((keyvals (db:get-key-val-pairs dbstruct run-id))
-	 (kvalues (map cadr keyvals))
-	 (keys    (db:get-keys dbstruct))
-	 (qrystr  (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")))
-    (let ((prev-run-ids '()))
-      (if (null? keyvals)
-          '()
-          (begin
-            (db:with-db dbstruct #f #f ;; #f means work with the zeroth db - i.e. the runs db
-                        (lambda (db)
-                          (apply sqlite3:for-each-row
-                                 (lambda (id)
-                                   (set! prev-run-ids (cons id prev-run-ids)))
-                                 db
-                                 (conc "SELECT id FROM runs WHERE " qrystr " AND state != 'deleted' AND id != ?;")
-                                 (append kvalues (list run-id)))))
-            prev-run-ids)))))
-
-;;======================================================================
-;;  T E S T S
-;;======================================================================
-
-;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN
-;; i.e. these lists define what to NOT show.
-;; states and statuses are required to be lists, empty is ok
-;; not-in #t = above behaviour, #f = must match
-;; mode:
-;;  'dashboard - use state = 'COMPLETED' AND status in ( statuses ) OR state in ( states )
-;;
-(define (db:get-tests-for-run dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode)
-  (let* ((qryvalstr       (case qryvals
-			    ((shortlist) "id,run_id,testname,item_path,state,status")
-			    ((#f)        db:test-record-qry-selector) ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")
-			    (else        qryvals)))
-	 (res            '())
-	 ;; if states or statuses are null then assume match all when not-in is false
-	 (states-qry      (if (null? states) 
-			      #f
-			      (conc " state "  
-				    (if (eq? mode 'dashboard)
-					" IN ('"
-					(if not-in
-					    " NOT IN ('"
-					    " IN ('")) 
-				    (string-intersperse states   "','")
-				    "')")))
-	 (statuses-qry    (if (null? statuses)
-			      #f
-			      (conc " status "
-				    (if (eq? mode 'dashboard)
-					" IN ('"
-					(if not-in 
-					    " NOT IN ('"
-					    " IN ('") )
-				    (string-intersperse statuses "','")
-				    "')")))
-	 (interim-qry       (conc " AND " (if not-in "NOT " "") "( state='COMPLETED' " (if statuses-qry (conc " AND " statuses-qry " ) ") " ) ")
-				  (if states-qry
-				      (conc (if not-in " AND " " OR ") states-qry ) ;; " ) ")
-				      "")))
-	 (states-statuses-qry 
-	  (cond 
-	   ((and states-qry statuses-qry)
-	    (case mode
-	      ((dashboard) 
-	       (if not-in
-		   (conc " AND (state='COMPLETED' AND status NOT IN ('" (string-intersperse statuses "','") "')) "
-			 " OR (state != 'COMPLETED' AND state NOT IN ('" (string-intersperse states "','") "')) ")
-		   (conc " AND (state='COMPLETED' AND status IN ('" (string-intersperse statuses "','") "')) "
-			 " OR (state NOT IN ('COMPLETED','DELETED') AND state IN ('" (string-intersperse states "','") "')) ")))
-	      (else       (conc " AND ( " states-qry " AND " statuses-qry " ) "))))
-	   (states-qry  
-	    (case mode
-	      ((dashboard) (conc " AND " (if not-in "NOT " "") " state IN ('" (string-intersperse states    "','") "') ")) ;; interim-qry)
-	      (else        (conc " AND " states-qry))))
-	   (statuses-qry 
-	    (case mode
-	      ((dashboard) (conc " AND " (if not-in "NOT " "") " status IN ('" (string-intersperse statuses "','") "') ")) ;; interim-qry)
-	      (else        (conc " AND " statuses-qry))))
-	   (else "")))
-	 (tests-match-qry (tests:match->sqlqry testpatt))
-	 (qry             (conc "SELECT " qryvalstr
-				(if run-id
-				    " FROM tests WHERE run_id=? "
-				    " FROM tests WHERE ? > 0 ") ;; should work?
-				(if last-update " " " AND state != 'DELETED' ") ;; if using last-update we want deleted tests?
-				states-statuses-qry
-				(if tests-match-qry (conc " AND (" tests-match-qry ") ") "")
-				(if last-update (conc " AND last_update >= " last-update " ") "")
-				(case sort-by
-				  ((rundir)      " ORDER BY length(rundir) ")
-				  ((testname)    (conc " ORDER BY testname " (if sort-order (conc sort-order ",") "") " item_path "))
-				  ((statestatus) (conc " ORDER BY state " (if  sort-order (conc sort-order ",") "") " status "))
-				  ((event_time)  " ORDER BY event_time ")
-				  (else          (if (string? sort-by)
-						     (conc " ORDER BY " sort-by " ")
-						     " ")))
-				(if sort-order sort-order " ")
-				(if limit  (conc " LIMIT " limit)   " ")
-				(if offset (conc " OFFSET " offset) " ")
-				";"
-				)))
-    (debug:print-info 8 *default-log-port* "db:get-tests-for-run run-id=" run-id ", qry=" qry)
-    (let* ((res (db:with-db dbstruct run-id #f
-			    (lambda (db)
-			      ;; (let* ((stmth (db:get-cache-stmth dbstruct db qry))) ;; due to use of last-update we can't efficiently cache this query
-				(reverse
-				 (sqlite3:fold-row
-				  (lambda (res . row)
-				    ;; id run-id testname state status event-time host cpuload
-				    ;;     diskfree uname rundir item-path run-duration final-logf comment)
-				    (cons (list->vector row) res))
-				  '()
-				  db qry ;; stmth
-				  (or run-id 1) ;; 1 > 0 , for the case where we are seeking tests matching criteral for all runs
-				  ))))))
-      (case qryvals
-	((shortlist)(map db:test-short-record->norm res))
-	((#f)       res)
-	(else       res)))))
-
-(define (db:test-short-record->norm inrec)
-  ;;  "id,run_id,testname,item_path,state,status"
-  ;;  "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
-  (vector (vector-ref inrec 0) ;; id
-	  (vector-ref inrec 1) ;; run_id
-	  (vector-ref inrec 2) ;; testname
-	  (vector-ref inrec 4) ;; state
-	  (vector-ref inrec 5) ;; status
-	  -1 "" -1 -1 "" "-" 
-	  (vector-ref inrec 3) ;; item-path
-	  -1 "-" "-"))
-
-;;
-;; 1. cache tests-match-qry
-;; 2. compile qry and store in hash
-;; 3. convert for-each-row to fold
-;;
-;; (define (db:get-tests-for-run-state-status dbstruct run-id testpatt)
-;;   (db:with-db
-;;    dbstruct run-id #f
-;;    (lambda (db)
-;;      (let* ((res            '())
-;; 	    (stmt-cache      (dbr:dbstruct-stmt-cache dbstruct))
-;; 	    (stmth           (let* ((sh (db:hoh-get stmt-cache db testpatt)))
-;; 			       (or sh
-;; 				   (let* ((tests-match-qry (tests:match->sqlqry testpatt))
-;; 					  (qry             (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? " 
-;; 								 (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")))
-;; 					  (newsh           (sqlite3:prepare db qry)))
-;; 				     (debug:print-info 8 *default-log-port* "db:get-tests-for-run qry=" qry)
-;; 				     (db:hoh-set! stmt-cache db testpatt newsh)
-;; 				     newsh)))))
-;;        (reverse
-;; 	(sqlite3:fold-row
-;; 	 (lambda (res id testname item-path state status)
-;; 	   ;;  id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
-;; 	   (cons (vector id run-id testname state status -1         ""     -1      -1       ""    "-"  item-path -1           "-"         "-") res))
-;; 	 '()
-;; 	 stmth
-;; 	 run-id))))))
-
-(define (db:get-tests-for-run-state-status dbstruct run-id testpatt #!optional (last-update 0))
-  (let* ((res            '())
-	 (tests-match-qry (tests:match->sqlqry testpatt))
-	 (qry             (conc "SELECT id,testname,item_path,state,status,event_time,run_duration FROM tests WHERE run_id=? " 
-				" AND last_update > ? "
-				(if tests-match-qry (conc " AND (" tests-match-qry ") ") "")
-				)))
-    (debug:print-info 8 *default-log-port* "db:get-tests-for-run qry=" qry)
-    (db:with-db dbstruct run-id #f
-		(lambda (db)
-		  (sqlite3:fold-row
-		   (lambda (res id testname item-path state status event-time run-duration)
-		     ;;            id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
-		     (cons (vector id run-id testname state status event-time  ""     -1      -1       ""    "-"  item-path run-duration  "-"         "-") res))
-		   '()
-		   db 
-		   qry
-		   run-id
-		   (or last-update 0))))))
-
-(define (db:get-testinfo-state-status dbstruct run-id test-id)
-  (let ((res            #f))
-    (db:with-db dbstruct run-id #f
-		(lambda (db)
-		  (sqlite3:for-each-row
-		   (lambda (run-id testname item-path state status)
-		     ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
-		     (set! res (vector test-id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-")))
-		   db 
-		   "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=?;" 
-		   test-id)))
-    res))
-
-;; get a useful subset of the tests data (used in dashboard
-;; use db:mintest-get-{id ,run_id,testname ...}
-;;
-(define (db:get-tests-for-run-mindata dbstruct run-id testpatt states statuses not-in)
-  (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f "id,run_id,testname,state,status,event_time,item_path" 0 #f))
-
-;; do not use.
-;;
-(define (db:get-tests-for-runs dbstruct run-ids testpatt states statuses #!key (not-in #f)(qryvals #f))
-  ;; (db:delay-if-busy)
-  (let ((res '()))
-    (for-each 
-     (lambda (run-id)
-       (set! res (append 
-		  res 
-		  (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f qryvals #f 'normal))))
-     (if run-ids
-	 run-ids
-	 (db:get-all-run-ids dbstruct)))
-    res))
-
-;; Convert calling routines to get list of run-ids and loop, do not use the get-tests-for-runs
-;;
-
-(define (db:delete-test-records dbstruct run-id test-id)
-  (db:general-call dbstruct 'delete-test-step-records (list test-id))
-  (db:general-call dbstruct 'delete-test-data-records (list test-id))
-  (db:with-db
-   dbstruct #f #f
-   (lambda (db)
-     (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id))))
-
-;; 
-(define (db:delete-old-deleted-test-records dbstruct)
-  (let ((targtime (- (current-seconds)
-		     (or (configf:lookup-number *configdat* "setup" "keep-deleted-records")
-			 (* 30 24 60 60))))) ;; one month in the past
-    (db:with-db
-     dbstruct
-     0
-     #t
-     (lambda (db)
-       (sqlite3:with-transaction
-	db
-	(lambda ()
-	  (sqlite3:execute db "DELETE FROM test_steps WHERE test_id IN (SELECT id FROM tests WHERE state='DELETED' AND event_time<?);" targtime)
-	  (sqlite3:execute db "DELETE FROM test_data WHERE test_id IN (SELECT id FROM tests WHERE state='DELETED' AND event_time<?);" targtime)
-	  (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED' AND event_time<?;" targtime)))))))
-
-;; set tests with state currstate and status currstatus to newstate and newstatus
-;; use currstate = #f and or currstatus = #f to apply to any state or status respectively
-;; WARNING: SQL injection risk. NB// See new but not yet used "faster" version below
-;;
-;;  AND NOT (item_path='' AND testname in (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")))
-;;  (debug:print 0 *default-log-port* "QRY: " qry)
-;;  (db:delay-if-busy)
-;;
-;; NB// This call only operates on toplevel tests. Consider replacing it with more general call
-;;
-(define (db:set-tests-state-status dbstruct run-id testnames currstate currstatus newstate newstatus)
-  (let ((test-ids '()))
-    (for-each
-     (lambda (testname)
-       (let ((qry (conc "UPDATE tests SET state=?,status=? WHERE "
-			(if currstate  (conc "state='" currstate "' AND ") "")
-			(if currstatus (conc "status='" currstatus "' AND ") "")
-			" run_id=? AND testname LIKE ?;"))
-	     (test-id (db:get-test-id dbstruct run-id testname "")))
-	 (db:with-db
-	  dbstruct
-	  run-id
-	  #t
-	  (lambda (db)
-	    (sqlite3:execute db qry
-			     (or newstate  currstate "NOT_STARTED")
-			     (or newstatus currstate "UNKNOWN")
-			     run-id testname)))
-	 (if test-id
-	     (begin
-	       (set! test-ids (cons test-id test-ids))
-	       (mt:process-triggers dbstruct run-id test-id newstate newstatus)))))
-     testnames)
-    test-ids))
-
-;; ;; speed up for common cases with a little logic
-;; ;; NB// Ultimately this will be deprecated in deference to mt:test-set-state-status-by-id
-;;
-;;      NOTE: run-id is not used
-;; ;;
-(define (db:test-set-state-status dbstruct run-id test-id newstate newstatus newcomment)
-  (db:with-db
-   dbstruct
-   ;; run-id
-   #f
-   #t
-   (lambda (db)
-     (cond
-      ((and newstate newstatus newcomment)
-       (sqlite3:execute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus newcomment ;; (sdb:qry 'getid newcomment)
-			test-id))
-      ((and newstate newstatus)
-       (sqlite3:execute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id))
-      (else
-       (if newstate   (sqlite3:execute db "UPDATE tests SET state=?   WHERE id=?;" newstate   test-id))
-       (if newstatus  (sqlite3:execute db "UPDATE tests SET status=?  WHERE id=?;" newstatus  test-id))
-       (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment ;; (sdb:qry 'getid newcomment)
-				       test-id))))))
+(define (db:test-set-state-status-process-triggers  dbstruct run-id test-id newstate newstatus newcomment)
+  (db:test-set-state-status dbstruct run-id test-id newstate newstatus newcomment)
   (mt:process-triggers dbstruct run-id test-id newstate newstatus))
 
-;; NEW BEHAVIOR: Count tests running in all runs!
-;;
-(define (db:get-count-tests-running dbstruct run-id) ;; fastmode)
-  (let* ((qry ;; (if fastmode
-		;;   "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND NOT (uname = 'n/a' AND item_path = '') LIMIT 1;"
-		  "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND NOT (uname = 'n/a' AND item_path = '');")) ;; )
-  (db:with-db
-   dbstruct
-   run-id
-   #f
-   (lambda (db)
-     (let* ((stmth (db:get-cache-stmth dbstruct  db qry)))
-       (sqlite3:first-result stmth))))))
-
-;; NEW BEHAVIOR: Count tests running in only one run!
-;;
-(define (db:get-count-tests-actually-running dbstruct run-id)
-  (db:with-db
-   dbstruct
-   run-id
-   #f
-   (lambda (db)
-     (sqlite3:first-result
-      db
-      ;; WARNING BUG EDIT ME - merged from v1.55 - not sure what is right here ...
-      ;; "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id NOT IN (SELECT id FROM runs WHERE state='deleted') AND NOT (uname = 'n/a' AND item_path = '');")
-      "SELECT count(id) FROM tests WHERE state in ('RUNNING','REMOTEHOSTSTART','LAUNCHED') AND run_id=?;" 
-      run-id)))) ;; NOT IN (SELECT id FROM runs WHERE state='deleted');")
-
-;; NEW BEHAVIOR: Look only at single run with run-id
-;; 
-;; (define (db:get-running-stats dbstruct run-id)
-(define (db:get-count-tests-running-for-run-id dbstruct run-id) ;; fastmode)
-  (let* ((qry ;; (if fastmode
-		 ;;  "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=? LIMIT 1;"
-		  "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=?;")) ;; )
-    (db:with-db
-     dbstruct
-     run-id
-     #f
-     (lambda (db)
-       (let* ((stmth (db:get-cache-stmth dbstruct db qry)))
-	 (sqlite3:first-result stmth run-id))))))
-
-;; For a given testname how many items are running? Used to determine
-;; probability for regenerating html
-;;
-(define (db:get-count-tests-running-for-testname dbstruct run-id testname)
-  (db:with-db
-   dbstruct
-   run-id
-   #f
-   (lambda (db)
-     (let* ((stmt "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=? AND NOT (uname = 'n/a' AND item_path = '') AND testname=?;")
-	    (stmth (db:get-cache-stmth dbstruct db stmt)))
-       (sqlite3:first-result
-	stmth run-id testname)))))
-
-(define (db:get-not-completed-cnt dbstruct run-id)
-(db:with-db
-   dbstruct
-   run-id
-   #f
-   (lambda (db)
-      ;(print "SELECT count(id) FROM tests WHERE state not in ('COMPLETED', 'DELETED') AND run_id=" run-id)  
-     (sqlite3:first-result
-      db
-      "SELECT count(id) FROM tests WHERE state not in ('COMPLETED', 'DELETED') AND run_id=?;" run-id))))
-
-(define (db:get-count-tests-running-in-jobgroup dbstruct run-id jobgroup)
-  (if (not jobgroup)
-      0 ;; 
-      (let ((testnames '()))
-	;; get the testnames
-	(db:with-db
-	 dbstruct #f #f
-	 (lambda (db)
-	   (sqlite3:for-each-row
-	    (lambda (testname)
-	      (set! testnames (cons testname testnames)))
-	    db
-	    "SELECT testname FROM test_meta WHERE jobgroup=?"
-	    jobgroup)))
-	;; get the jobcount NB// EXTEND THIS TO OPPERATE OVER ALL RUNS?
-	(if (not (null? testnames))
-	    (db:with-db
-	     dbstruct
-	     run-id
-	     #f
-	     (lambda (db)
-	       (sqlite3:first-result
-		db
-		(conc "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND testname in ('"
-		      (string-intersperse testnames "','")
-		      "') AND NOT (uname = 'n/a' AND item_path='');")) ;; should this include the (uname = 'n/a' ...) ???
-	       ))
-	    0))))
-
-;; tags: '("tag%" "tag2" "%ag6")
-;;
-
-;; done with run when:
-;;   0 tests in LAUNCHED, NOT_STARTED, REMOTEHOSTSTART, RUNNING
-(define (db:estimated-tests-remaining dbstruct run-id)
-  (db:with-db
-   dbstruct
-   run-id
-   #f
-   (lambda (db)
-     (sqlite3:first-result
-      db
-      "SELECT count(id) FROM tests WHERE state in ('LAUNCHED','NOT_STARTED','REMOTEHOSTSTART','RUNNING','KILLREQ') AND run_id=?;")
-     run-id)))
-
-;; map run-id, testname item-path to test-id
-(define (db:get-test-id dbstruct run-id testname item-path)
-  (db:with-db
-   dbstruct
-   run-id
-   #f
-   (lambda (db)
-     (db:first-result-default
-      db
-      "SELECT id FROM tests WHERE testname=? AND item_path=? AND run_id=?;"
-      #f ;; the default
-      testname item-path run-id))))
-
-;; overload the unused attemptnum field for the process id of the runscript or 
-;; ezsteps step script in progress
-;;
-(define (db:test-set-top-process-pid dbstruct run-id test-id pid)
-  (db:with-db
-   dbstruct
-   run-id
-   #f
-   (lambda (db)
-     (sqlite3:execute db "UPDATE tests SET attemptnum=? WHERE id=?;"
-		      pid test-id))))
-
-(define (db:test-get-top-process-pid dbstruct run-id test-id)
-  (db:with-db
-   dbstruct
-   run-id
-   #f
-   (lambda (db)
-     (db:first-result-default 
-      db
-      "SELECT attemptnum FROM tests WHERE id=?;"
-      #f
-      test-id))))
-
-(define db:test-record-fields '("id"           "run_id"        "testname"  "state"      "status"      "event_time"
-				"host"         "cpuload"       "diskfree"  "uname"      "rundir"      "item_path"
-                                "run_duration" "final_logf"    "comment"   "shortdir"   "attemptnum"  "archived" "last_update"))
-
-;; fields *must* be a non-empty list
-;;
-(define (db:field->number fieldname fields)
-  (if (null? fields)
-      #f
-      (let loop ((hed  (car fields))
-		 (tal  (cdr fields))
-		 (indx 0))
-	(if (equal? fieldname hed)
-	    indx
-	    (if (null? tal)
-		#f
-		(loop (car tal)(cdr tal)(+ indx 1)))))))
-
-(define db:test-record-qry-selector (string-intersperse db:test-record-fields ","))
-
-(define (db:update-tesdata-on-repilcate-db dbstruct old-lt new-lt)
-  (db:with-db
-   dbstruct   #f   #f
-   (lambda (db)
-     (sqlite3:execute db "UPDATE tests SET rundir= replace(rundir,?,?), shortdir=replace(shortdir,?,?);"
-		      old-lt new-lt  old-lt new-lt))))
-
-;; NOTE: Use db:test-get* to access records
-;; NOTE: This needs rundir decoding? Decide, decode here or where used? For the moment decode where used.
-(define (db:get-all-tests-info-by-run-id dbstruct run-id)
-  (let* ((res '()))
-    (db:with-db
-     dbstruct #f #f
-     (lambda (db)
-       (sqlite3:for-each-row
-	(lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived)
-	  ;;                 0    1       2      3      4        5       6      7        8     9     10      11          12          13       14     15        16
-	  (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived)
-			  res)))
-	db
-	(conc "SELECT " db:test-record-qry-selector " FROM tests WHERE state != 'DELETED' AND run_id=?;")
-	run-id)))
-    res))
-
-(define (db:replace-test-records dbstruct run-id testrecs)
-  (db:with-db dbstruct run-id #t 
-	      (lambda (db)
-		(let* ((qmarks (string-intersperse (make-list (length db:test-record-fields) "?") ","))
-		       (qrystr (conc "INSERT OR REPLACE INTO tests (" db:test-record-qry-selector ") VALUES (" qmarks ") WHERE run_id=?;"))
-		       (qry    (sqlite3:prepare db qrystr)))
-		  (debug:print 0 *default-log-port* "INFO: migrating test records for run with id " run-id)
-		  (sqlite3:with-transaction
-		   db
-		   (lambda ()
-		     (for-each 
-		      (lambda (rec)
-			;; (debug:print 0 *default-log-port* "INFO: Inserting values: " (string-intersperse (map conc (vector->list rec)) ",") "\n")
-			(apply sqlite3:execute qry (append (vector->list rec)(list run-id))))
-		      testrecs)))
-		  (sqlite3:finalize! qry)))))
-
-;; map a test-id into the proper range
-;;
-(define (db:adj-test-id mtdb min-test-id test-id)
-  (if (>= test-id min-test-id)
-      test-id
-      (let loop ((new-id min-test-id))
-	(let ((test-id-found #f))
-	  (sqlite3:for-each-row 
-	   (lambda (id)
-	     (set! test-id-found id))
-	   (db:dbdat-get-db mtdb)
-	   "SELECT id FROM tests WHERE id=?;"
-	   new-id)
-	  ;; if test-id-found then need to try again
-	  (if test-id-found
-	      (loop (+ new-id 1))
-	      (begin
-		(debug:print-info 0 *default-log-port* "New test id " new-id " selected for test with id " test-id)
-		(sqlite3:execute mtdb "UPDATE tests SET id=? WHERE id=?;" new-id test-id)))))))
-
-;; move test ids into the 30k * run_id range
-;;
-(define (db:prep-megatest.db-adj-test-ids mtdb run-id testrecs)
-  (debug:print-info 0 *default-log-port* "Adjusting test ids in megatest.db for run " run-id)
-  (let ((min-test-id (* run-id 30000)))
-    (for-each 
-     (lambda (testrec)
-       (let* ((test-id (vector-ref testrec (db:field->number "id" db:test-record-fields))))
-	 (db:adj-test-id (db:dbdat-get-db mtdb) min-test-id test-id)))
-     testrecs)))
-	
-;; 1. move test ids into the 30k * run_id range
-;; 2. move step ids into the 30k * run_id range
-;;
-(define (db:prep-megatest.db-for-migration mtdb)
-  (let* ((run-ids (db:get-all-run-ids mtdb)))
-    (for-each 
-     (lambda (run-id)
-       (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id)))
-	 (db:prep-megatest.db-adj-test-ids (db:dbdat-get-db mtdb) run-id testrecs)))
-     run-ids)))
-
-;; Get test data using test_id, run-id is not used
-;; 
-(define (db:get-test-info-by-id dbstruct run-id test-id)
-  (db:with-db
-   dbstruct
-   #f ;; run-id
-   #f
-   (lambda (db)
-     (let ((res #f))
-       (sqlite3:for-each-row ;; attemptnum added to hold pid of top process (not Megatest) controlling a test
-	(lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived last-update)
-	  ;;                0    1       2      3      4        5       6      7        8     9     10      11          12          13           14         15          16
-	  (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived last-update)))
-	db
-	(conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=?;")
-	test-id)
-       res))))
-
-;; Use db:test-get* to access
-;; Get test data using test_ids. NB// Only works within a single run!!
-;;
-(define (db:get-test-info-by-ids dbstruct run-id test-ids)
-  (db:with-db
-   dbstruct
-   run-id
-   #f
-   (lambda (db)
-     (let ((res '()))
-       (sqlite3:for-each-row
-	(lambda (a . b)
-	  ;;                 0    1       2      3      4        5       6      7        8     9     10      11          12          13       14
-	  (set! res (cons (apply vector a b) res)))
-	db
-	(conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id in ("
-	      (string-intersperse (map conc test-ids) ",") ");"))
-       res))))
-
-(define (db:get-test-info dbstruct run-id test-name item-path)
-  (db:with-db
-   dbstruct
-   run-id
-   #f
-   (lambda (db)
-     (let ((res #f))
-       (sqlite3:for-each-row
-	(lambda (a . b)
-	  (set! res (apply vector a b)))
-	db
-	(conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=? AND run_id=?;")
-	test-name item-path run-id)
-       res))))
-
-(define (db:test-get-rundir-from-test-id dbstruct run-id test-id)
-  (db:with-db
-   dbstruct
-   run-id
-   #f
-   (lambda (db)
-     (db:first-result-default
-      db
-      "SELECT rundir FROM tests WHERE id=?;"
-      #f ;; default result
-      test-id))))
-
-(define (db:get-test-times dbstruct run-name target)
-  (let ((res `())
-        (qry 	(conc "select testname, item_path, run_duration, "
-		      (string-join (db:get-keys dbstruct) " || '/' || ")
-		      " as target from tests inner join runs on tests.run_id = runs.id where runs.runname = ? and target = ?  ;")))
-  (db:with-db 
-    dbstruct
-    #f ;; this is for the main runs db
-    #f ;; does not modify db
-    (lambda (db)
-            (sqlite3:for-each-row
-	(lambda (test-name item-path test-time target )
-	  (set! res (cons (vector test-name item-path test-time) res)))
-	db
-        qry 
-	run-name target)
-       res))))
-
-;;======================================================================
-;; S T E P S
-;;======================================================================
-
-(define (db:teststep-set-status! dbstruct run-id test-id teststep-name state-in status-in comment logfile)
-  (db:with-db
-   dbstruct
-   run-id
-   #t
-   (lambda (db)
-     (sqlite3:execute 
-      db
-      "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);"
-      test-id teststep-name state-in status-in (current-seconds)
-      (if comment comment "")
-      (if logfile logfile "")))))
-
-
-
-(define (db:delete-steps-for-test! dbstruct run-id test-id)
-  ;; TODO: figure out why status is the key field rather than state (note:  CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state) )
-  (db:with-db
-   dbstruct
-   run-id
-   #t
-   (lambda (db)
-     (sqlite3:execute 
-      db
-      "UPDATE test_steps set status='DELETED' where test_id=?" ;;  and run_id=? !! - run_id not in table (bummer) TODO: get run_id into schema for test_steps
-      test-id))))
-
-
-;; db-get-test-steps-for-run
-(define (db:get-steps-for-test dbstruct run-id test-id)
-  (db:with-db
-   dbstruct
-   run-id
-   #f
-   (lambda (db)
-     (let* ((res '()))
-       (sqlite3:for-each-row 
-	(lambda (id test-id stepname state status event-time logfile comment)
-	  (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment) res)))
-	db
-	"SELECT id,test_id,stepname,state,status,event_time,logfile,comment FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
-	test-id)
-       (reverse res)))))
-
- (define (db:get-steps-info-by-id dbstruct  test-step-id)
-   (db:with-db
-    dbstruct
-    #f 
-    #f
-    (lambda (db)
-      (let* ((res (vector #f #f #f #f #f #f #f #f #f)))
-        (sqlite3:for-each-row 
-       (lambda (id test-id stepname state status event-time logfile comment last-update)
-         (set! res (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment last-update)))
-       db
-       "SELECT id,test_id,stepname,state,status,event_time,logfile,comment,last_update FROM test_steps WHERE id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
-       test-step-id)
-        res))))
-
-(define (db:get-steps-data dbstruct run-id test-id)
-  (db:with-db
-   dbstruct
-   run-id
-   #f
-   (lambda (db)
-     (let ((res '()))
-       (sqlite3:for-each-row 
-	(lambda (id test-id stepname state status event-time logfile)
-	  (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res)))
-	db
-	"SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
-	test-id)
-       (reverse res)))))
-
-;;======================================================================
-;; T E S T  D A T A 
-;;======================================================================
-
-(define (db:get-data-info-by-id dbstruct  test-data-id)
-  (let* ((stmt        "SELECT id,test_id, category, variable, value, expected, tol, units, comment, status, type, last_update FROM test_data WHERE id=? ORDER BY id ASC;")) ;; event_time DESC,id ASC;
-    (db:with-db
-     dbstruct
-     #f 
-     #f
-     (lambda (db)
-       (let* ((stmth (db:get-cache-stmth dbstruct db stmt))
-	      (res   (sqlite3:fold-row
-		      (lambda (res id test-id  category variable value expected tol units comment status type last-update)
-			(vector id test-id  category variable value expected tol units comment status type last-update))
-		      (vector #f #f #f #f #f #f #f #f #f #f #f #f)
-		      stmth
-		      test-data-id)))
-        res)))))
-
-;; WARNING: Do NOT call this for the parent test on an iterated test
-;; Roll up test_data pass/fail results
-;; look at the test_data status field, 
-;;    if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS.
-;;    if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored
-(define (db:test-data-rollup dbstruct run-id test-id status)
-  (let* ((fail-count 0)
-	 (pass-count 0))
-    (db:with-db
-     dbstruct #f #f
-     (lambda (db)
-       (sqlite3:for-each-row
-	(lambda (fcount pcount)
-	  (set! fail-count fcount)
-	  (set! pass-count pcount))
-	db 
-	"SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count,
-             (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'pass') AS pass_count;"
-	test-id test-id)
-       ;; Now rollup the counts to the central megatest.db
-       (db:general-call dbstruct 'pass-fail-counts (list pass-count fail-count test-id))
-       ;; if the test is not FAIL then set status based on the fail and pass counts.
-       (db:general-call dbstruct 'test_data-pf-rollup (list test-id test-id test-id test-id))))))
-
-;; each section is a rule except "final" which is the final result
-;;
-;; [rule-5]
-;; operator in
-;; section LogFileBody
-;; desc Output voltage
-;; status OK
-;; expected 1.9
-;; measured 1.8
-;; type +/-
-;; tolerance 0.1
-;; pass 1
-;; fail 0
-;; 
-;; [final]
-;; exit-code 6
-;; exit-status SKIP
-;; message If flagged we are asking for this to exit with code 6
-;;
-;; recorded in steps table:
-;;   category: stepname
-;;   variable: rule-N
-;;   value:    measured
-;;   expected: expected
-;;   tol:      tolerance
-;;   units:    -
-;;   comment:  desc or message
-;;   status:   status
-;;   type:     type
-;; 
-(define (db:logpro-dat->csv dat stepname)
-  (let ((res '()))
-    (for-each
-     (lambda (entry-name)
-       (if (equal? entry-name "final")
-	   (set! res (append 
-		      res
-		      (list
-		       (list stepname
-			     entry-name
-			     (configf:lookup dat entry-name "exit-code")    ;; 0 ;; Value
-			     0                                              ;; 1 ;; Expected
-			     0                                              ;; 2 ;; Tolerance
-			     "n/a"					    ;; 3 ;; Units
-			     (configf:lookup dat entry-name "message")      ;; 4 ;; Comment
-			     (configf:lookup dat entry-name "exit-status")  ;; 5 ;; Status
-			     "logpro"                                       ;; 6 ;; Type
-			     ))))
-	   (let* ((value     (or (configf:lookup dat entry-name "measured")  "n/a"))
-		  (expected  (or (configf:lookup dat entry-name "expected")  0.0))
-		  (tolerance (or (configf:lookup dat entry-name "tolerance") 0.0))
-		  (comment   (or (configf:lookup dat entry-name "comment")
-				 (configf:lookup dat entry-name "desc")      "n/a"))
-		  (status    (or (configf:lookup dat entry-name "status")    "n/a"))
-		  (type      (or (configf:lookup dat entry-name "expected")  "n/a")))
-	     (set! res (append
-			res  
-			(list (list stepname
-				    entry-name 
-				    value        ;; 0
-				    expected     ;; 1
-				    tolerance    ;; 2
-				    "n/a"        ;; 3 Units
-				    comment      ;; 4
-				    status       ;; 5
-				    type         ;; 6
-				    )))))))
-     (hash-table-keys dat))
-    res))
-
-;; $MT_MEGATEST -load-test-data << EOF
-;; foo,bar,   1.2,  1.9, >
-;; foo,rab, 1.0e9, 10e9, 1e9
-;; foo,bla,   1.2,  1.9, <
-;; foo,bal,   1.2,  1.2, <   ,     ,Check for overload
-;; foo,alb,   1.2,  1.2, <=  , Amps,This is the high power circuit test
-;; foo,abl,   1.2,  1.3, 0.1
-;; foo,bra,   1.2, pass, silly stuff
-;; faz,bar,    10,  8mA,     ,     ,"this is a comment"
-;; EOF
-
-(define (db:csv->test-data dbstruct run-id test-id csvdata)
-  (debug:print 4 *default-log-port* "test-id " test-id ", csvdata: " csvdata)
-  (db:with-db
-   dbstruct #f #f
-   (lambda (db)
-     (let* ((csvlist (csv->list (make-csv-reader
-				 (open-input-string csvdata)
-				 '((strip-leading-whitespace? #t)
-				   (strip-trailing-whitespace? #t)))))) ;; (csv->list csvdata)))
-       (for-each
-	(lambda (csvrow)
-	  (let* ((padded-row  (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9))
-		 (category    (list-ref padded-row 0))
-		 (variable    (list-ref padded-row 1))
-		 (value       (any->number-if-possible (list-ref padded-row 2)))
-		 (expected    (any->number-if-possible (list-ref padded-row 3)))
-		 (tol         (any->number-if-possible (list-ref padded-row 4))) ;; >, <, >=, <=, or a number
-		 (units       (list-ref padded-row 5))
-		 (comment     (list-ref padded-row 6))
-		 (status      (let ((s (list-ref padded-row 7)))
-				(if (and (string? s)(or (string-match (regexp "^\\s*$") s)
-							(string-match (regexp "^n/a$") s)))
-				    #f
-				    s))) ;; if specified on the input then use, else calculate
-		 (type        (list-ref padded-row 8)))
-	    ;; look up expected,tol,units from previous best fit test if they are all either #f or ''
-	    (debug:print 4 *default-log-port* "BEFORE: category: " category " variable: " variable " value: " value 
-			 ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment " type: " type)
-	    
-	    (if (and (or (not expected)(equal? expected ""))
-		     (or (not tol)     (equal? expected ""))
-		     (or (not units)   (equal? expected "")))
-		(let-values (((new-expected new-tol new-units)(tdb:get-prev-tol-for-test #f test-id category variable)))
-		  (set! expected new-expected)
-		  (set! tol      new-tol)
-		  (set! units    new-units)))
-	    
-	    (debug:print 4 *default-log-port* "AFTER:  category: " category " variable: " variable " value: " value 
-			 ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment)
-	    ;; calculate status if NOT specified
-	    (if (and (not status)(number? expected)(number? value)) ;; need expected and value to be numbers
-		(if (number? tol) ;; if tol is a number then we do the standard comparison
-		    (let* ((max-val (+ expected tol))
-			   (min-val (- expected tol))
-			   (result  (and (>=  value min-val)(<= value max-val))))
-		      (debug:print 4 *default-log-port* "max-val: " max-val " min-val: " min-val " result: " result)
-		      (set! status (if result "pass" "fail")))
-		    (set! status ;; NB// need to assess each one (i.e. not return operator since need to act if not valid op.
-		      (case (string->symbol tol) ;; tol should be >, <, >=, <=
-			((>)  (if (>  value expected) "pass" "fail"))
-			((<)  (if (<  value expected) "pass" "fail"))
-			((>=) (if (>= value expected) "pass" "fail"))
-			((<=) (if (<= value expected) "pass" "fail"))
-			(else (conc "ERROR: bad tol comparator " tol))))))
-	    (debug:print 4 *default-log-port* "AFTER2: category: " category " variable: " variable " value: " value 
-			 ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment)
-	    ;; (db:delay-if-busy dbdat)
-	    (sqlite3:execute db "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);"
-			     test-id category variable value expected tol units (if comment comment "") status type)))
-	csvlist)))))
-
-;; This routine moved from tdb.scm, tdb:read-test-data
-;;
-(define (db:read-test-data dbstruct run-id test-id categorypatt)
-  (let* ((res '()))
-    (db:with-db
-     dbstruct #f #f
-     (lambda (db)
-       (sqlite3:for-each-row 
-	(lambda (id test_id category variable value expected tol units comment status type)
-	  (set! res (cons (vector id test_id category variable value expected tol units comment status type) res)))
-	db
-	"SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt)
-       (reverse res)))))
-
-;; This routine moved from tdb.scm, :read-test-data
-;;
-(define (db:read-test-data-varpatt dbstruct run-id test-id categorypatt varpatt)
-  (let* ((res '()))
-    (db:with-db
-     dbstruct #f #f
-     (lambda (db)
-       (sqlite3:for-each-row 
-	(lambda (id test_id category variable value expected tol units comment status type)
-	  (set! res (cons (vector id test_id category variable value expected tol units comment status type) res)))
-	db
-	"SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? AND variable LIKE ? ORDER BY category,variable;" test-id categorypatt varpatt)
-       (reverse res)))))
-
-
-;;======================================================================
-;; Misc. test related queries
-;;======================================================================
-
-(define (db:get-run-ids-matching-target dbstruct keynames target res runname testpatt statepatt statuspatt)
-  (db:with-db
-   dbstruct #f #f
-   (lambda (db)
-     (let* ((row-ids '())
-	    (keystr (string-intersperse 
-		     (map (lambda (key val)
-			    (conc key " like '" val "'"))
-			  keynames 
-			  (string-split target "/"))
-		     " AND "))
-	    ;; (testqry (tests:match->sqlqry testpatt))
-	    (runsqry (sqlite3:prepare db (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';"))))
-       ;; (debug:print 8 *default-log-port* "db:test-get-paths-matching-keynames-target-new\n  runsqry=" runsqry "\n  tstsqry=" testqry)
-       (sqlite3:for-each-row
-	(lambda (rid)
-	  (set! row-ids (cons rid row-ids)))
-	runsqry)
-       (sqlite3:finalize! runsqry)
-       row-ids))))
-
-;; finds latest matching all patts for given run-id
-;;
-(define (db:test-get-paths-matching-keynames-target-new dbstruct run-id keynames target res testpatt statepatt statuspatt runname)
-  (let* ((testqry (tests:match->sqlqry testpatt))
-	 (tstsqry (conc "SELECT rundir FROM tests WHERE run_id=? AND " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;")))
-    (db:with-db
-     dbstruct
-     run-id
-     #f
-     (lambda (db)
-       (sqlite3:for-each-row 
-	(lambda (p)
-	  (set! res (cons p res)))
-	db
-	tstsqry
-	run-id)
-       res))))
-
-(define (db:test-toplevel-num-items dbstruct run-id testname)
-  (db:with-db
-   dbstruct
-   run-id
-   #f
-   (lambda (db)
-     (let ((res 0))
-       (sqlite3:for-each-row
-	(lambda (num-items)
-	  (set! res num-items))
-	db
-	"SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND state NOT IN ('DELETED');"
-	run-id
-	testname)
-       res))))
-
-;;======================================================================
-;; QUEUE UP META, TEST STATUS AND STEPS REMOTE ACCESS
-;;======================================================================
-
-;; NOTE: Can remove the regex and base64 encoding for zmq
-(define (db:obj->string obj #!key (transport 'http))
-  (case transport
-    ;; ((fs) obj)
-    ((http fs)
-     (string-substitute
-      (regexp "=") "_"
-      (base64:base64-encode 
-       (z3:encode-buffer
-	(with-output-to-string
-	  (lambda ()(serialize obj))))) ;; BB: serialize - this is what causes problems between different builds of megatest communicating.  serialize is sensitive to binary image of mtest.
-      #t))
-    ((zmq nmsg)(with-output-to-string (lambda ()(serialize obj))))
-    (else obj))) ;; rpc
-
-(define (db:string->obj msg #!key (transport 'http))
-  (case transport
-    ;; ((fs) msg)
-    ((http fs)
-     (if (string? msg)
-	 (with-input-from-string 
-	     (z3:decode-buffer
-	      (base64:base64-decode
-	       (string-substitute 
-		(regexp "_") "=" msg #t)))
-	   (lambda ()(deserialize)))
-	 (begin
-	   (debug:print-error 0 *default-log-port* "reception failed. Received \"" msg "\" but cannot translate it.")
-           (print-call-chain (current-error-port))
-	   msg))) ;; crude reply for when things go awry
-    ((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize))))
-    (else msg))) ;; rpc
-
-;; ; This is to be the big daddy call NOPE: Replaced by db:set-state-status-and-roll-up-items
-;; ;
-;; define (db:test-set-state-status dbstruct run-id test-id state status msg)
-;;  (let ((dbdat  (db:get-db dbstruct run-id)))
-;;    (if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
-;; 	(db:general-call dbdat 'set-test-start-time (list test-id)))
-;;    ;; (if msg
-;;    ;; 	(db:general-call dbdat 'state-status-msg (list state status msg test-id))
-;;    ;; 	(db:general-call dbdat 'state-status     (list state status test-id)))
-;;    (db:set-state-status-and-roll-up-items dbstruct run-id test-id #f state status msg)
-;;    ;; process the test_data table
-;;    (if (and test-id state status (equal? status "AUTO")) 
-;; 	(db:test-data-rollup dbstruct run-id test-id status))
-;;    (mt:process-triggers dbstruct run-id test-id state status)))
-
-;; state is the priority rollup of all states
-;; status is the priority rollup of all completed statesfu
-;;
-;; if test-name is an integer work off that instead of test-name test-path
-;;
-(define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment)
-  ;; establish info on incoming test followed by info on top level test
-  ;; BBnote - for mode itemwait, linkage between upstream test & matching item status is propagated to run queue in db:prereqs-not-met
-  (let* ((testdat      (if (number? test-name)
-			   (db:get-test-info-by-id dbstruct run-id test-name) ;; test-name is actually a test-id
-			   (db:get-test-info       dbstruct run-id test-name item-path)))
-	 (test-id      (db:test-get-id testdat))
-	 (test-name    (if (number? test-name)
-			   (db:test-get-testname testdat)
-			   test-name))
-	 (item-path    (db:test-get-item-path testdat))
-         (tl-testdat   (db:get-test-info dbstruct run-id test-name ""))
-         (tl-test-id   (if tl-testdat
-			   (db:test-get-id tl-testdat)
-			   #f)))
-    (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) 
-	(db:general-call dbstruct 'set-test-start-time (list test-id)))
-    (mutex-lock! *db-transaction-mutex*)
-    (db:with-db
-     dbstruct #f #f
-     (lambda (db)
-       (let ((tr-res
-              (sqlite3:with-transaction
-               db
-               (lambda ()
-                 ;; NB// Pass the db so it is part fo the transaction
-                 (db:test-set-state-status db run-id test-id state status comment) ;; this call sets the item state/status
-                 (if (not (equal? item-path "")) ;; only roll up IF incoming test is an item
-                     (let* ((state-status-counts  (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path state status)) ;; item-path is used to exclude current state/status of THIS test
-			      						  (state-stauses (db:roll-up-rules state-status-counts state status))
-                          (newstate (car state-stauses))
-                          (newstatus (cadr state-stauses)))
-                       (debug:print 4 *default-log-port* "BB> tl-test-id="tl-test-id" ; "test-name":"item-path" newstate="newstate" newstatus="newstatus" len(sscs)="(length state-status-counts)  " state-status-counts: "
-							(apply conc
-                  (map (lambda (x)
-                     (conc
-                     		(with-output-to-string (lambda () (pp (dbr:counts->alist x)))) " | "))
-                              state-status-counts))); end debug:print
-   
-                       (if tl-test-id
-			   (db:test-set-state-status db run-id tl-test-id newstate newstatus #f)) ;; we are still in the transaction - must access the db and not the dbstruct
-		       ))))))
-         (mutex-unlock! *db-transaction-mutex*)
-         (if (and test-id state status (equal? status "AUTO")) 
-             (db:test-data-rollup dbstruct run-id test-id status))
-         tr-res)))))
-
-(define (db:roll-up-rules state-status-counts state status)
-		(let* ((running     (length (filter (lambda (x)
-                          (member (dbr:counts-state x) *common:running-states*))
-                                 state-status-counts)))
-           (bad-not-started      (length (filter (lambda (x)
-                                      (and (equal? (dbr:counts-state x) "NOT_STARTED") 
-                                        (not (member (dbr:counts-status x)  *common:not-started-ok-statuses*))))
-																	state-status-counts)))
-           (all-curr-states      (common:special-sort  ;; worst -> best (sort of)
-                                    (delete-duplicates
-                                      (if (and state (not (member state *common:dont-roll-up-states*)))
-                                          (cons state (map dbr:counts-state state-status-counts))
-                                          (map dbr:counts-state state-status-counts)))
-                                                  *common:std-states* >))
-           (all-curr-statuses    (common:special-sort  ;; worst -> best
-                                    (delete-duplicates
-                                      (if (and state status (not (member state *common:dont-roll-up-states*)))
-                                          (cons status (map dbr:counts-status state-status-counts))
-                                          (map dbr:counts-status state-status-counts)))
-                                                   *common:std-statuses* >))
-           (non-completes        (filter (lambda (x)
-							 										 (not (member x (cons "COMPLETED" *common:dont-roll-up-states*))))
-						       									all-curr-states))
-			     (preq-fails        (filter (lambda (x)
-							 								(equal? x "PREQ_FAIL"))
-						       							all-curr-statuses))
-           (num-non-completes (length non-completes))
- 					 (newstate          (cond
-															((> running 0)           "RUNNING")            ;; anything running, call the situation running
-                              ((> (length preq-fails) 0) "NOT_STARTED")
-															((> bad-not-started 0)   "COMPLETED")          ;; we have an ugly situation, it is completed in the sense we cannot do more.
-															((> num-non-completes 0) (car non-completes))  ;;  (remove (lambda (x)(equal? "COMPLETED" x)) all-curr-states))) ;; only rollup DELETED if all DELETED
-															(else                    (car all-curr-states))))
-           (newstatus         (cond
-                              ((> (length preq-fails) 0)  "PREQ_FAIL")
-                              ((or (> bad-not-started 0)
-                                   (and (equal? newstate "NOT_STARTED")
-                                      (> num-non-completes 0)))
-                                            "STARTED")
-                              (else (car all-curr-statuses)))))
- 					(debug:print-info 2 *default-log-port*
-                                         "\n--> probe db:set-state-status-and-roll-up-items: "
-                                         "\n--> state-status-counts: "(map dbr:counts->alist state-status-counts)
-                                         "\n--> running:             "running
-                                         "\n--> bad-not-started:     "bad-not-started
-                                         "\n--> non-non-completes:   "num-non-completes
-                                         "\n--> non-completes:       "non-completes
-                                         "\n--> all-curr-states:     "all-curr-states
-                                         "\n--> all-curr-statuses:     "all-curr-statuses
-                                         "\n--> newstate              "newstate
-                                         "\n--> newstatus            "newstatus
-                                         "\n\n")
-
-                        ;; NB// Pass the db so it is part of the transaction
-         (list newstate newstatus)))
-
-(define (db:set-state-status-and-roll-up-run dbstruct run-id curr-state curr-status)
-    (mutex-lock! *db-transaction-mutex*)
-    (db:with-db
-     dbstruct #f #f
-     (lambda (db)
-       (let ((tr-res
-              (sqlite3:with-transaction
-               db
-               (lambda ()
-                   (let* ((state-status-counts  (db:get-all-state-status-counts-for-run dbstruct run-id))
-													(state-stauses (db:roll-up-rules state-status-counts #f #f ))
-                          (newstate (car state-stauses))
-                          (newstatus (cadr state-stauses))) 
-                    (if (or (not (eq? newstate curr-state)) (not (eq?  newstatus curr-status)))
-                   (db:set-run-state-status dbstruct run-id newstate newstatus )))))))
-         (mutex-unlock! *db-transaction-mutex*)
-         tr-res))))
-
-
-(define (db:get-all-state-status-counts-for-run dbstruct run-id)
- (let* ((test-count-recs (db:with-db
-                                  dbstruct #f #f
-                                  (lambda (db)
-                                    (sqlite3:map-row
-                                     (lambda (state status count)
-                                        (make-dbr:counts state: state status: status count: count))
-                                     db
-                                     "SELECT state,status,count(id) FROM tests WHERE run_id=?  GROUP BY state,status;"
-                                     run-id )))))
-   test-count-recs))
-
-
-;; BBnote: db:get-all-state-status-counts-for-test returns dbr:counts object aggregating state and status of items of a given test, *not including rollup state/status*
-;;
-;; NOTE: This is called within a transaction
-;;
-(define (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path item-state-in item-status-in)
-  (let* ((test-info   (db:get-test-info dbstruct run-id test-name item-path))
-         (item-state  (or item-state-in (db:test-get-state test-info))) 
-         (item-status (or item-status-in (db:test-get-status test-info)))
-         (other-items-count-recs (db:with-db
-                                  dbstruct #f #f
-                                  (lambda (db)
-                                    (sqlite3:map-row
-                                     (lambda (state status count)
-                                       (make-dbr:counts state: state status: status count: count))
-                                     db
-                                     ;; ignore current item because we have changed its value in the current transation so this select will see the old value.
-                                     "SELECT state,status,count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND item_path !=? GROUP BY state,status;"
-                                     run-id test-name item-path))))
-
-         ;; add current item to tally outside of sql query
-         (match-countrec-lambda (lambda (countrec) 
-                                  (and (equal? (dbr:counts-state  countrec) item-state)
-                                       (equal? (dbr:counts-status countrec) item-status))))
-
-         (already-have-count-rec-list
-          (filter match-countrec-lambda other-items-count-recs)) ;; will have either 0 or 1 count recs depending if another item shares this item's state/status
-         
-         (updated-count-rec    (if (null? already-have-count-rec-list)
-                                   (make-dbr:counts state: item-state status: item-status count: 1)
-                                   (let* ((our-count-rec (car already-have-count-rec-list))
-                                          (new-count (add1 (dbr:counts-count our-count-rec))))
-                                     (make-dbr:counts state: item-state status: item-status count: new-count))))
-
-         (nonmatch-countrec-lambda (lambda (countrec) (not (match-countrec-lambda countrec))))
-         
-         (unrelated-rec-list   
-          (filter nonmatch-countrec-lambda other-items-count-recs)))
-    
-    (cons updated-count-rec unrelated-rec-list)))
-
-;; (define (db:get-all-item-states db run-id test-name)
-;;   (sqlite3:map-row 
-;;    (lambda (a) a)
-;;    db
-;;    "SELECT DISTINCT state FROM tests WHERE item_path != '' AND state != 'DELETED' AND run_id=? AND testname=?"
-;;    run-id test-name))
-;; 
-;; (define (db:get-all-item-statuses db run-id test-name)
-;;   (sqlite3:map-row 
-;;    (lambda (a) a)
-;;    db
-;;    "SELECT DISTINCT status FROM tests WHERE item_path != '' AND state != 'DELETED' AND state='COMPLETED' AND run_id=? AND testname=?"
-;;    run-id test-name))
-
-(define (db:test-get-logfile-info dbstruct run-id test-name)
-  (db:with-db
-   dbstruct
-   run-id
-   #f
-   (lambda (db)
-     (let ((res #f))
-       (sqlite3:for-each-row 
-	(lambda (path final_logf)
-	  ;; (let ((path       (sdb:qry 'getstr path-id))
-	  ;;       (final_logf (sdb:qry 'getstr final_logf-id)))
-	  (set! logf final_logf)
-	  (set! res (list path final_logf))
-	  (if (directory? path)
-	      (debug:print 2 *default-log-port* "Found path: " path)
-	      (debug:print 2 *default-log-port* "No such path: " path))) ;; )
-	db
-	"SELECT rundir,final_logf FROM tests WHERE testname=? AND item_path='' AND run_id=?;"
-	test-name run-id)
-       res))))
-
-;;======================================================================
-;; A G R E G A T E D   T R A N S A C T I O N   D B   W R I T E S 
-;;======================================================================
-
-(define db:queries 
-  (list '(update-run-duration     "UPDATE tests SET run_duration=? WHERE id=?;")
-
-	;; TESTS
-	'(register-test          "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');")
-	;; Test state and status
-	'(set-test-state         "UPDATE tests SET state=?   WHERE id=?;")
-	'(set-test-status        "UPDATE tests SET state=?   WHERE id=?;")
-	'(state-status           "UPDATE tests SET state=?,status=? WHERE id=?;") ;; D/ONE
-	'(state-status-msg       "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;") ;; DONE
-	;; Test comment
-	'(set-test-comment       "UPDATE tests SET comment=? WHERE id=?;")
-	'(set-test-start-time    "UPDATE tests SET event_time=strftime('%s','now') WHERE id=?;") ;; DONE
-	'(pass-fail-counts       "UPDATE tests SET pass_count=?,fail_count=? WHERE id=?;")
-	;; test_data-pf-rollup is used to set a tests PASS/FAIL based on the pass/fail info from the steps
-	'(test_data-pf-rollup    "UPDATE tests
-                                    SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 
-                                      THEN 'FAIL'
-                                    WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND 
-                                      (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL')
-                                    THEN 'PASS'
-                                    ELSE status
-                                    END WHERE id=?;") ;; DONE
-	'(test-set-log            "UPDATE tests SET final_logf=? WHERE id=?;")      ;; DONE
-	;; '(test-set-rundir-by-test-id "UPDATE tests SET rundir=? WHERE id=?")        ;; DONE
-	;; '(test-set-rundir         "UPDATE tests SET rundir=? AND testname=? AND item_path=?;") ;; DONE
-	'(test-set-rundir-shortdir "UPDATE tests SET rundir=?,shortdir=? WHERE testname=? AND item_path=? AND run_id=?;")    ;; BROKEN!!! NEEDS run-id
-	'(delete-tests-in-state   ;; "DELETE FROM tests WHERE state=?;")                  ;; DONE
-	  "UPDATE tests SET state='DELETED' WHERE state=?")
-	'(tests:test-set-toplog   "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';")
-	'(update-cpuload-diskfree "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;") ;; DONE
-	'(update-uname-host       "UPDATE tests SET uname=?,host=? WHERE id=?;")       ;; DONE
-        '(update-test-rundat      "INSERT INTO test_rundat (test_id,update_time,cpuload,diskfree,diskusage,run_duration) VALUES (?,?,?,?,?,?);")
-	'(update-test-state       "UPDATE tests SET state=? WHERE state=? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")
-	'(update-test-status      "UPDATE tests SET status=? WHERE status like ? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")
-	;; stuff for set-state-status-and-roll-up-items
-	'(update-pass-fail-counts "UPDATE tests 
-             SET fail_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('FAIL','CHECK','INCOMPLETE','ABORT')),
-                 pass_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED'))
-             WHERE testname=? AND item_path='' AND run_id=?;") ;; DONE  ;; BROKEN!!! NEEDS run-id
-	'(top-test-set-running  "UPDATE tests SET state='RUNNING' WHERE testname=? AND item_path='' AND run_id=?;") ;; DONE   ;; BROKEN!!! NEEDS run-id
-
-	;; NOT USED
-	;;
-	;; Might be the following top-test-set-per-pf-counts query could be better based off of something like this:
-	;;
-	;; select state,status,count(state) from tests where run_id=59 AND testname='runfirst' group by state,status;
-	;;
-	'(top-test-set-per-pf-counts "UPDATE tests
-                       SET state=CASE 
-                                   WHEN (SELECT count(id) FROM tests 
-                                                WHERE testname=?
-                                                     AND item_path != '' 
-                                                     AND status NOT IN ('n/a')
-                                                     AND state in ('NOT_STARTED')) > 0 THEN 'UNKNOWN'
-                                   WHEN (SELECT count(id) FROM tests 
-                                                WHERE testname=?
-                                                     AND item_path != '' 
-                                                     AND (status NOT IN ('TEN_STRIKES','BLOCKED') OR status IN ('INCOMPLETE'))
-                                                     AND state in ('RUNNING','NOT_STARTED','LAUNCHED','REMOTEHOSTSTART')) > 0 THEN 'RUNNING'
-                                   WHEN (SELECT count(id) FROM tests 
-                                                WHERE testname=?
-                                                     AND item_path != '' 
-                                                     AND state NOT IN ('COMPLETED','DELETED')) = 0 THEN 'COMPLETED'
-                                   WHEN (SELECT count(id) FROM tests 
-                                                WHERE testname=?
-                                                     AND item_path != '' 
-                                                     AND state = 'NOT_STARTED') > 0 THEN 'NOT_STARTED'
-                                   ELSE 'UNKNOWN' END,
-                            status=CASE 
-                                  WHEN fail_count > 0 THEN 'FAIL' 
-                                  WHEN (SELECT count(id) FROM tests
-                                         WHERE testname=?
-                                              AND item_path != ''
-                                              AND state IN ('BLOCKED','INCOMPLETE')) > 0 THEN 'FAIL'
-                                  WHEN (SELECT count(id) FROM tests
-                                         WHERE testname=?
-                                              AND item_path != ''
-                                              AND state NOT IN ('DELETED')
-                                              AND status IN ('INCOMPLETE','ABORT')) > 0 THEN 'ABORT'
-                                  WHEN (SELECT count(id) FROM tests
-                                         WHERE testname=?
-                                              AND item_path != ''
-                                              AND state NOT IN ('DELETED')
-                                              AND status = 'AUTO') > 0 THEN 'AUTO'
-                                  WHEN (SELECT count(id) FROM tests
-                                         WHERE testname=?
-                                              AND item_path != ''
-                                              AND state NOT IN ('DELETED')
-                                              AND status IN ('STUCK/INCOMPLETE', 'INCOMPLETE')) > 0 THEN 'INCOMPLETE'
-                                  WHEN (SELECT count(id) FROM tests
-                                         WHERE testname=?
-                                              AND item_path != ''
-                                              AND state IN ('COMPLETED','STUCK/INCOMPLETE','INCOMPLETE')
-                                              AND status = 'FAIL') > 0 THEN 'FAIL'
-                                  WHEN (SELECT count(id) FROM tests
-                                         WHERE testname=?
-                                              AND item_path != ''
-                                              AND state NOT IN ('DELETED')
-                                              AND status = 'CHECK') > 0 THEN 'CHECK'
-                                  WHEN (SELECT count(id) FROM tests
-                                         WHERE testname=?
-                                              AND item_path != ''
-                                              AND state NOT IN ('DELETED')
-                                              AND status = 'SKIP') > 0 THEN 'SKIP'
-                                  WHEN (SELECT count(id) FROM tests
-                                         WHERE testname=?
-                                              AND item_path != ''
-                                              AND state NOT IN ('DELETED')
-                                              AND status = 'WARN') > 0 THEN 'WARN'
-                                  WHEN (SELECT count(id) FROM tests
-                                         WHERE testname=?
-                                              AND item_path != ''
-                                              AND state NOT IN ('DELETED')
-                                              AND status = 'WAIVED') > 0 THEN 'WAIVED'
-                                  WHEN (SELECT count(id) FROM tests
-                                         WHERE testname=? 
-                                              AND item_path != ''
-                                              AND state NOT IN ('DELETED')
-                                              AND status NOT IN ('PASS','FAIL','WARN','WAIVED')) > 0 THEN 'ABORT'
-                                  WHEN (SELECT count(id) FROM tests
-                                         WHERE testname=?
-                                              AND item_path != ''
-                                              AND state='NOT_STARTED') > 0 THEN 'n/a'
-                                  WHEN (SELECT count(id) FROM tests
-                                         WHERE testname=?
-                                              AND item_path != ''
-                                              AND state = 'COMPLETED'
-                                              AND status = 'PASS') > 0 THEN 'PASS'
-                                  WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' 
-                                  ELSE 'UNKNOWN' END
-                       WHERE testname=? AND item_path='';") ;; DONE  ;; BROKEN!!! NEEDS run-id
-
-	;; STEPS
-	'(delete-test-step-records "UPDATE test_steps SET status='DELETED' WHERE test_id=?;")
-	'(delete-test-data-records "UPDATE test_data  SET status='DELETED' WHERE test_id=?;") ;; using status since no state field
-	))
-
-(define (db:lookup-query qry-name)
-  (let ((q (alist-ref qry-name db:queries)))
-    (if q (car q) #f)))
-
-;; do not run these as part of the transaction
-(define db:special-queries   '(rollup-tests-pass-fail
-			       ;; db:set-state-status-and-roll-up-items  ;; WHY NOT!?
-			       login
-			       immediate
-			       flush
-			       sync
-			       set-verbosity
-			       killserver
-			       ))
-
-(define (db:login dbstruct calling-path calling-version client-signature)
-   (cond 
-   ((not (equal? calling-path *toppath*))
-    (list #f "Login failed due to mismatch paths: " calling-path ", " *toppath*))
-   ;; ((not (equal? *run-id* run-id))
-   ;;  (list #f "Login failed due to mismatch run-id: " run-id ", " *run-id*))
-   ((not (equal? megatest-version calling-version))
-    (list #t (conc "Login warning due to mismatch megatest version: " calling-version ", " megatest-version)))
-   
-    (else
-    (hash-table-set! *logged-in-clients* client-signature (current-seconds))
-    '(#t "successful login"))))
-
-(define (db:general-call dbstruct stmtname params)
-  (let ((query (let ((q (alist-ref (if (string? stmtname)
-				       (string->symbol stmtname)
-				       stmtname)
-				   db:queries)))
- 		 (if q (car q) #f))))
-    (db:with-db
-     dbstruct #f #f
-     (lambda (db)
-       (apply sqlite3:execute db query params)
-       #t))))
-
-;; get a summary of state and status counts to calculate a rollup
-;;
-(define (db:get-state-status-summary dbstruct run-id testname)
-  (let ((res   '()))
-    (db:with-db
-     dbstruct #f #f
-     (lambda (db)
-       (sqlite3:for-each-row
-	(lambda (state status count)
-	  (set! res (cons (vector state status count) res)))
-	db
-	"SELECT state,status,count(state) FROM tests WHERE run_id=? AND testname=? AND item_path='' GROUP BY state,status;"
-	run-id testname)
-       res))))
-
-(define (db:get-latest-host-load dbstruct raw-hostname)
-  (let* ((hostname (string-substitute "\\..*$" "" raw-hostname))
-         (res  (cons -1 0)))
-    (db:with-db
-     dbstruct #f #f
-     (lambda (db)
-       (sqlite3:for-each-row
-        (lambda (cpuload update-time)  (set! res (cons cpuload update-time)))
-        db
-        "SELECT tr.cpuload, tr.update_time FROM test_rundat tr, tests t WHERE t.host=? AND tr.cpuload != -1  AND tr.test_id=t.id ORDER BY tr.update_time DESC LIMIT 1;"
-        hostname))) res ))
-
-(define (db:set-top-level-from-items dbstruct run-id testname)
-  (let* ((summ  (db:get-state-status-summary dbstruct run-id testname))
-	 (find  (lambda (state status)
-		  (if (null? summ) 
-		      #f
-		      (let loop ((hed (car summ))
-				 (tal (cdr summ)))
-			(if (and (string-match state  (vector-ref hed 0))
-				 (string-match status (vector-ref hed 1)))
-			    hed
-			    (if (null? tal)
-				#f
-				(loop (car tal)(cdr tal)))))))))
-
-
-      ;;;     E D I T M E ! !
-
-
-    (cond
-     ((> (find "COMPLETED" ".*") 0) #f))))
-		   
-    
-
-;; get the previous records for when these tests were run where all keys match but runname
-;; NB// Merge this with test:get-previous-test-run-records? This one looks for all matching tests
-;; can use wildcards. Also can likely be factored in with get test paths?
-;;
-;; Run this remotely!!
-;;
-(define (db:get-matching-previous-test-run-records dbstruct run-id test-name item-path)
-  (let* ((keys    (db:get-keys dbstruct))
-	 (selstr  (string-intersperse keys ","))
-	 (qrystr  (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND "))
-	 (keyvals #f)
-	 (tests-hash (make-hash-table)))
-    ;; first look up the key values from the run selected by run-id
-    (db:with-db
-     dbstruct #f #f
-     (lambda (db)
-       (sqlite3:for-each-row 
-	(lambda (a . b)
-	  (set! keyvals (cons a b)))
-	db
-	(conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id)))
-    (if (not keyvals)
-	'()
-	(let ((prev-run-ids '()))
-	  (db:with-db
-	   dbstruct #f #f
-	   (lambda (db)
-	     (apply sqlite3:for-each-row
-		    (lambda (id)
-		      (set! prev-run-ids (cons id prev-run-ids)))
-		    db
-		    (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id)))))
-	  ;; collect all matching tests for the runs then
-	  ;; extract the most recent test and return that.
-	  (debug:print 4 *default-log-port* "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals 
-		       ", previous run ids found: " prev-run-ids)
-	  (if (null? prev-run-ids) '()  ;; no previous runs? return null
-	      (let loop ((hed (car prev-run-ids))
-			 (tal (cdr prev-run-ids)))
-		(let ((results (db:get-tests-for-run dbstruct hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f #f 'normal)))
-		  (debug:print 4 *default-log-port* "Got tests for run-id " run-id ", test-name " test-name 
-			       ", item-path " item-path " results: " (intersperse results "\n"))
-		  ;; Keep only the youngest of any test/item combination
-		  (for-each 
-		   (lambda (testdat)
-		     (let* ((full-testname (conc (db:test-get-testname testdat) "/" (db:test-get-item-path testdat)))
-			    (stored-test   (hash-table-ref/default tests-hash full-testname #f)))
-		       (if (or (not stored-test)
-			       (and stored-test
-				    (> (db:test-get-event_time testdat)(db:test-get-event_time stored-test))))
-			   ;; this test is younger, store it in the hash
-			   (hash-table-set! tests-hash full-testname testdat))))
-		   results)
-		  (if (null? tal)
-		      (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests
-		      (loop (car tal)(cdr tal))))))))))
-
-;; Function recursively checks if <db>.journal exists; if yes means db busy; call itself after delayed interval
-;; return the sqlite3 db handle if possible
-;; 
-(define (db:delay-if-busy dbdat #!key (count 6))
-  (if (not (configf:lookup *configdat* "server" "delay-on-busy")) 
-      (and dbdat (db:dbdat-get-db dbdat))
-      (if dbdat
-	  (let* ((dbpath (db:dbdat-get-path dbdat))
-		 (db     (db:dbdat-get-db   dbdat)) ;; we'll return this so (db:delay--if-busy can be called inline
-		 (dbfj   (conc dbpath "-journal")))
-	    (if (handle-exceptions
-		 exn
-		 (begin
-		   (debug:print-info 0 *default-log-port* "WARNING: failed to test for existance of " dbfj ", exn=" exn)
-		   (thread-sleep! 1)
-		   (db:delay-if-busy count (- count 1))) 
-		 (common:file-exists? dbfj))
-		(case count
-		  ((6)
-		   (thread-sleep! 0.2)
-		   (db:delay-if-busy count: 5))
-		  ((5)
-		   (thread-sleep! 0.4)
-		   (db:delay-if-busy count: 4))
-		  ((4)
-		   (thread-sleep! 0.8)
-		   (db:delay-if-busy count: 3))
-		  ((3)
-		   (thread-sleep! 1.6)
-		   (db:delay-if-busy count: 2))
-		  ((2)
-		   (thread-sleep! 3.2)
-		   (db:delay-if-busy count: 1))
-		  ((1)
-		   (thread-sleep! 6.4)
-		   (db:delay-if-busy count: 0))
-		  (else
-		   (debug:print-info 0 *default-log-port* "delaying db access due to high database load.")
-		   (thread-sleep! 12.8))))
-	    db) 
-	  "bogus result from db:delay-if-busy")))
-
-(define (db:test-get-records-for-index-file dbstruct run-id test-name)
-  (let ((res '()))
-    (db:with-db
-     dbstruct
-     run-id
-     #f
-     (lambda (db)
-       (sqlite3:for-each-row 
-	(lambda (id itempath state status run_duration logf comment)
-	  (set! res (cons (vector id itempath state status run_duration logf comment) res)))
-	db
-	"SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE testname=? AND item_path != '' AND run_id=?;" ;; BUG! WHY NO run_id?
-	test-name
-	run-id)
-       res))))
-
-;;======================================================================
-;; Tests meta data
-;;======================================================================
-
-;; returns a hash table of tags to tests
-;;
-(define (db:get-tests-tags dbstruct)
-  (db:with-db
-   dbstruct #f #f
-   (lambda (db)
-     (let* ((res     (make-hash-table)))
-       (sqlite3:for-each-row
-	(lambda (testname tags-in)
-	  (let ((tags (string-split tags-in ",")))
-	    (for-each
-	     (lambda (tag)
-	       (hash-table-set! res tag
-				(delete-duplicates
-				 (cons testname (hash-table-ref/default res tag '())))))
-	     tags)))
-	db
-	"SELECT testname,tags FROM test_meta")
-       (hash-table->alist res)))))
-
-;; read the record given a testname
-(define (db:testmeta-get-record dbstruct testname)
-  (let ((res   #f))
-    (db:with-db
-     dbstruct
-     #f
-     #f
-     (lambda (db)
-       (sqlite3:for-each-row
-	(lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup)
-	  (set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup)))
-	db
-	"SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE testname=?;"
-	testname)
-       res))))
-
-;; create a new record for a given testname
-(define (db:testmeta-add-record dbstruct testname)
-  (db:with-db dbstruct #f #f 
-	      (lambda (db)
-		(sqlite3:execute 
-		 db
-		 "INSERT OR IGNORE INTO test_meta (testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags) VALUES (?,'','','','','','','','');" testname))))
-
-;; update one of the testmeta fields
-(define (db:testmeta-update-field dbstruct testname field value)
-  (db:with-db dbstruct #f #f 
-	      (lambda (db)
-		(sqlite3:execute 
-		 db
-		 (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname))))
-
-(define (db:testmeta-get-all dbstruct)
-  (db:with-db dbstruct #f #f 
-	      (lambda (db)
-		(let ((res '()))
-		  (sqlite3:for-each-row
-		   (lambda (a . b)
-		     (set! res (cons (apply vector a b) res)))
-		   db
-		   "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta;")
-		  res))))
-
-;;======================================================================
-;; M I S C   M A N A G E M E N T   I T E M S 
-;;======================================================================
-
-;; A routine to map itempaths using a itemmap
-;; patha and pathb must be strings or this will fail
-;;
-;; path-b is waiting on path-a
-;;
-(define (db:compare-itempaths test-b-name path-a path-b itemmaps )
-  (debug:print-info 6 *default-log-port* "ITEMMAPS: " itemmaps)
-  (let* ((itemmap    (tests:lookup-itemmap itemmaps test-b-name)))
-    (if itemmap
-	(let ((path-b-mapped (db:multi-pattern-apply path-b itemmap)))
-	  (debug:print-info 6 *default-log-port* "ITEMMAP is " itemmap ", path: " path-b ", mapped path: " path-b-mapped)
-	  (equal? path-a path-b-mapped))
-	(equal? path-b path-a))))
-
-;; A routine to convert test/itempath using a itemmap
-;; NOTE: to process only an itempath (i.e. no prepended testname)
-;;       just call db:multi-pattern-apply
-;;
-(define (db:convert-test-itempath path-in itemmap)
-  (debug:print-info 6 *default-log-port* "ITEMMAP is " itemmap)
-  (let* ((path-parts  (string-split path-in "/"))
-	 (test-name   (if (null? path-parts) "" (car path-parts)))
-	 (item-path   (string-intersperse (if (null? path-parts) '() (cdr path-parts)) "/")))
-    (conc test-name "/" 
-	  (db:multi-pattern-apply item-path itemmap))))
-
-;; patterns are:
-;;    "rx1"  "replacement1"\n
-;;    "rx2"  "replacement2"
-;; etc.
-;;
-(define (db:multi-pattern-apply item-path itemmap)
-  (let ((all-patts (string-split itemmap "\n")))
-    (if (null? all-patts)
-	item-path
-	(let loop ((hed (car all-patts))
-		   (tal (cdr all-patts))
-		   (res item-path))
-	  (let* ((parts (string-split hed))
-		 (patt  (car parts))
-
-		 (repl  (if (> (length parts) 1)(cadr parts) ""))
-
-		 (newr  (if (and patt repl)
-			    (begin
-                              (handle-exceptions
-                               exn
-                               (begin
-                                  (debug:print 0 *default-log-port*
-                                  "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl ", exn=" exn)
-                                 res)
-                              (string-substitute patt repl res))
-
-
-                              )
-			    (begin
-                              (debug:print 0 *default-log-port*
-                               "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl)
-			      res))))
-	    (if (null? tal)
-		newr
-		(loop (car tal)(cdr tal) newr)))))))
-
-
-
-
-;; the new prereqs calculation, looks also at itempath if specified
-;; all prereqs must be met
-;;    if prereq test with itempath='' is COMPLETED and PASS, WARN, CHECK, or WAIVED then prereq is met
-;;    if prereq test with itempath=ref-item-path and COMPLETED with PASS, WARN, CHECK, or WAIVED then prereq is met
-;;
-;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK, SKIP or WAIVED)
-;;       mode 'toplevel means that tests must be COMPLETED only
-;;       mode 'itemmatch or 'itemwait means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]]
-;;       mode 'exclusive means this test/item cannot run if the same test/item is LAUNCHED,REMOTEHOSTSTART or RUNNING
-;;
-;; IDEA for consideration:
-;;    1. collect all tests "upstream"
-;;    2. any NOT completed and good? if yes => return those as prereqs not met, if no => return null list
-;; 
-;; (define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path mode)
-(define (db:get-prereqs-not-met dbstruct run-id waitons ref-test-name ref-item-path mode itemmaps) ;; #!key (mode '(normal))(itemmap #f))
-  ;; BBnote - rollup of an itemized test's overall state/status done in db:set-state-status-and-roll-up-items
-  (append
-   (if (member 'exclusive mode)
-       (let ((running-tests (db:get-tests-for-run dbstruct
-						  #f  ;; run-id of #f means for all runs. 
-						  (if (string=? ref-item-path "")   ;; testpatt
-						      ref-test-name
-						      (conc ref-test-name "/" ref-item-path))
-						  '("LAUNCHED" "REMOTEHOSTSTART" "RUNNING") ;; states
-						  '()          ;; statuses
-						  #f           ;; offset
-						  #f           ;; limit
-						  #f           ;; not-in
-						  #f           ;; sort by
-						  #f           ;; sort order
-						  'shortlist   ;; query type
-						  0            ;; last update, beginning of time ....
-						  #f           ;; mode
-						  )))
-	;;(map (lambda (testdat)
-	;;	(if (equal? (db:test-get-item-path testdat) "")
-	;;	    (db:test-get-testname testdat)
-	;;	    (conc (db:test-get-testname testdat)
-	;;		  "/"
-	;;		  (db:test-get-item-path testdat))))
-	 running-tests) ;; calling functions want the entire data
-       '())
-
-   ;; collection of: for each waiton -
-   ;;   if this ref-test-name is an item in an itemized test and mode is itemwait/itemmatch:
-   ;;     if waiton is not itemized - if waiton is not both completed and in ok status, add as unmet prerequisite
-   ;;     if waiton is itemized:
-   ;;           and waiton's items are not expanded, add as unmet prerequisite
-   ;;           else if matching waiton item is not both completed and in an ok status, add as unmet prerequisite
-   ;;   else
-   ;;    if waiton toplevel is not in both completed and ok status, add as unmet prerequisite
-
-   (if (or (not waitons)
-	   (null? waitons))
-       '()
-       (let* ((ref-test-itemized-mode (not (null? (lset-intersection eq? mode '(itemmatch itemwait))))) ;; how is this different from using member?
-              (ref-test-toplevel-mode (not (null? (lset-intersection eq? mode '(toplevel)))))
-              (ref-test-is-toplevel   (equal? ref-item-path ""))
-              (ref-test-is-item       (not ref-test-is-toplevel))
-              (unmet-pre-reqs '())
-	      (result         '())
-              (unmet-prereq-items '())
-              )
-	 (for-each  ; waitons
-	  (lambda (waitontest-name)
-	    ;; by getting the tests with matching name we are looking only at the matching test 
-	    ;; and related sub items
-	    ;; next should be using mt:get-tests-for-run?
-
-            (let (;(waiton-is-itemized ...)
-                  ;(waiton-items-are-expanded ...)
-                  (waiton-tests             (db:get-tests-for-run-state-status dbstruct run-id waitontest-name))
-		  (ever-seen         #f)
-		  (parent-waiton-met #f)
-		  (item-waiton-met   #f)
-
-                  )
-	      (for-each ; test expanded from waiton
-	       (lambda (waiton-test) 
-		 (let* ((waiton-state             (db:test-get-state waiton-test))
-			(waiton-status            (db:test-get-status waiton-test))
-			(waiton-item-path         (db:test-get-item-path waiton-test)) ;; BB- this is the upstream itempath
-			(waiton-test-name         (db:test-get-testname waiton-test))
-                        (waiton-is-toplevel       (equal? waiton-item-path ""))
-                        (waiton-is-item           (not waiton-is-toplevel))
-			(waiton-is-completed      (member waiton-state  *common:ended-states*))
-			(waiton-is-running        (member waiton-state  *common:running-states*))
-			(waiton-is-killed         (member waiton-state  *common:badly-ended-states*))
-			(waiton-is-ok             (member waiton-status *common:well-ended-states*)) 
-			;;                                              testname-b    path-a    path-b
-			(same-itempath            (db:compare-itempaths ref-test-name waiton-item-path ref-item-path itemmaps)) ;; (equal? ref-item-path waiton-item-path)))
-			(real-ref-test-name       (car (string-split ref-test-name "/"))) ;; I THINK ref-test-name SHOULD NEVER HAVE THE ITEM_PATH!
-			(test-and-ref-are-same    (equal? real-ref-test-name waiton-test-name)))
-		   (debug:print 4 *default-log-port* "waiton-test-name " waiton-test-name " ref-test-name: " ref-test-name " test-and-ref-are-same: " test-and-ref-are-same)
-		   (set! ever-seen #t)
-                   ;;(BB> "***consider waiton "waiton-test"/"waiton-item-path"***")
-                   (cond
-                    ;; case 0 - toplevel of an itemized test, at least one item in prereq has completed
-                    ((and waiton-is-item ref-test-is-toplevel ref-test-itemized-mode waiton-is-completed)
-                     (set! parent-waiton-met #t))
-
-                    ;; case 1, non-item (parent test) is 
-		    ((and waiton-is-toplevel ;; this is the parent test of the waiton being examined
-			  waiton-is-completed
-                          ;;(BB> "cond1")
-			  (or waiton-is-ok ref-test-toplevel-mode)) ;;  itemmatch itemwait))))))
-		     (set! parent-waiton-met #t))
-		    ;; Special case for toplevel and KILLED
-		    ((and waiton-is-toplevel ;; this is the parent test
-			  waiton-is-killed
-			  (member 'toplevel mode))
-                     ;;(BB> "cond2")
-		     (set! parent-waiton-met #t))
-		    ;; For itemwait mode IFF the previous matching item is good the set parent-waiton-met
-                    ((and ref-test-itemized-mode ref-test-is-item same-itempath)
-                     ;;(BB> "cond3")
-		     (if (and waiton-is-completed (or waiton-is-ok ref-test-toplevel-mode)) 
-                         (set! item-waiton-met #t)
-                         (set! unmet-prereq-items (cons waiton-test unmet-prereq-items)))
-                     (if (and waiton-is-toplevel ;; if upstream rollup test is completed, parent-waiton-met is set
-			      (or waiton-is-completed waiton-is-running))
-			 (set! parent-waiton-met #t)))
-		    ;; normal checking of parent items, any parent or parent item not ok blocks running
-		    ((and waiton-is-completed
-			  (or waiton-is-ok 
-			      (member 'toplevel mode))              ;; toplevel does not block on FAIL
-			  (and waiton-is-ok (member 'itemmatch mode) ;; itemmatch blocks on not ok ;; TODO: THIS IS PROBABLY A BUG.  ITEMMATCH AND ITEMWAIT ARE SYNONYMS!! WHAT HAPPENED OT ITEMWAIT???
-                               ))
-                     ;;(BB> "cond4")
-		     (set! item-waiton-met #t))
-                    ((and waiton-is-completed waiton-is-ok same-itempath)
-                     ;;(BB> "cond5")
-                     (set! item-waiton-met #t))
-		    ((and waiton-is-completed waiton-is-ok test-and-ref-are-same) ;; probably from [waitons] table
-		     (set! item-waiton-met #t))
-                    (else
-                     #t
-                     ;;(BB> "condelse")
-                     ))))
-               waiton-tests)
-	      ;; both requirements, parent and item-waiton must be met to NOT add item to
-	      ;; prereq's not met list
-               ;; (BB>
-               ;;  "\n* waiton-tests           "waiton-tests
-               ;;  "\n* parent-waiton-met      "parent-waiton-met
-               ;;  "\n* item-waiton-met        "item-waiton-met
-               ;;  "\n* ever-seen              "ever-seen
-               ;;  "\n* ref-test-itemized-mode "ref-test-itemized-mode
-               ;;  "\n* unmet-prereq-items     "unmet-prereq-items
-               ;;  "\n* result (pre)           "result
-               ;;  "\n* ever-seen              "ever-seen
-               ;;  "\n")
-
-              (cond
-               ((and ref-test-itemized-mode ref-test-is-item (not (null? unmet-prereq-items)))
-                (set! result (append unmet-prereq-items result)))
-               ((not (or parent-waiton-met item-waiton-met))
-                (set! result (append (if (null? waiton-tests) (list waitontest-name) waiton-tests) result))) ;; appends the string if the full record is not available
-	      ;; if the test is not found then clearly the waiton is not met...
-	      ;; (if (not ever-seen)(set! result (cons waitontest-name result)))))
-               ((not ever-seen)
-                (set! result (append (if (null? waiton-tests)(list waitontest-name) waiton-tests) result))))))
-	  waitons)
-	 (delete-duplicates result)))))
-
-;;======================================================================
-;; To sync individual run
-;;======================================================================
-(define (db:get-run-record-ids dbstruct target run keynames test-patt)
-(let ((backcons (lambda (lst item)(cons item lst))))
-    (db:with-db
-     dbstruct #f #f 
-     (lambda (db)
-        (let* ((keystr (string-intersperse 
-		     (map (lambda (key val)
-			    (conc key " like '" val "'"))
-			  keynames 
-			  (string-split target "/"))
-		     " AND "))
-         (run-qry (conc "SELECT id FROM runs  WHERE " keystr  " and runname='" run"'"))
-         (test-qry (conc "SELECT id FROM tests WHERE run_id in (" run-qry ") and testname like '" test-patt "'")))
-         (print run-qry)
-         (print test-qry) 
-	 `((runs       . ,(sqlite3:fold-row backcons '() db run-qry))
-	   (tests      . ,(sqlite3:fold-row backcons '() db test-qry))
-	   (test_steps . ,(sqlite3:fold-row backcons '() db (conc "SELECT id FROM test_steps WHERE test_id in (" test-qry ")")))
-	   (test_data  . ,(sqlite3:fold-row backcons '() db (conc "SELECT id FROM test_data  WHERE test_id in (" test-qry ")" )))
-	   ))))))
-
-;;======================================================================
-;; Just for sync, procedures to make sync easy
-;;======================================================================
-
-;; get an alist of record ids changed since time since-time
-;;   '((runs . (1 2 3 ...))(steps . (5 6 7 ...) ...))
-;;
-(define (db:get-changed-record-ids dbstruct since-time)
-  ;; no transaction, allow the db to be accessed between the big queries
-  (let ((backcons (lambda (lst item)(cons item lst))))
-    (db:with-db
-     dbstruct #f #f 
-     (lambda (db)
-       `((runs       . ,(sqlite3:fold-row backcons '() db "SELECT id FROM runs  WHERE last_update>=?" since-time))
-	 (tests      . ,(sqlite3:fold-row backcons '() db "SELECT id FROM tests WHERE last_update>=?" since-time))
-	 (test_steps . ,(sqlite3:fold-row backcons '() db "SELECT id FROM test_steps WHERE last_update>=?" since-time))
-	 (test_data  . ,(sqlite3:fold-row backcons '() db "SELECT id FROM test_data  WHERE last_update>=?" since-time))
-	 ;; (test_meta  . ,(fold-row backcons '() db "SELECT id FROM test_meta  WHERE last_update>?" since-time))
-	 (run_stats  . ,(sqlite3:fold-row backcons '() db "SELECT id FROM run_stats  WHERE last_update>=?" since-time))
-	 )))))
-
-;;======================================================================
-;; Extract ods file from the db
-;;======================================================================
-
-;; NOT REWRITTEN YET!!!!!
-
-;; runspatt is a comma delimited list of run patterns
-;; keypatt-alist must contain *all* keys with an associated pattern: '( ("KEY1" "%") .. )
-(define (db:extract-ods-file dbstruct outputfile keypatt-alist runspatt pathmod)
-  (let* ((keysstr  (string-intersperse (map car keypatt-alist) ","))
-	 (keyqry   (string-intersperse (map (lambda (p)(conc (car p) " LIKE ? ")) keypatt-alist) " AND "))
-	 (numkeys  (length keypatt-alist))
-	 (test-ids '())
-	 (dbdat    (db:get-db dbstruct))
-	 (db       (db:dbdat-get-db dbdat))
-	 (windows  (and pathmod (substring-index "\\" pathmod)))
-	 (tempdir  (conc "/tmp/" (current-user-name) "/" runspatt "_" (random 10000) "_" (current-process-id)))
-	 (runsheader (append (list "Run Id" "Runname") ; 0 1
-			     (map car keypatt-alist)   ; + N = length keypatt-alist
-			     (list "Testname"          ; 2
-				   "Item Path"         ; 3 
-				   "Description"       ; 4 
-				   "State"             ; 5 
-				   "Status"            ; 6  
-				   "Final Log"         ; 7 
-				   "Run Duration"      ; 8 
-				   "When Run"          ; 9 
-				   "Tags"              ; 10
-				   "Run Owner"         ; 11
-				   "Comment"           ; 12
-				   "Author"            ; 13
-				   "Test Owner"        ; 14
-				   "Reviewed"          ; 15
-				   "Diskfree"          ; 16
-				   "Uname"             ; 17
-				   "Rundir"            ; 18
-				   "Host"              ; 19
-				   "Cpu Load"          ; 20
-				   )))
-	 (results (list runsheader))			 
-	 (testdata-header (list "Run Id" "Testname" "Item Path" "Category" "Variable" "Value" "Expected" "Tol" "Units" "Status" "Comment"))
-	 (mainqry (conc "SELECT
-              t.testname,r.id,runname," keysstr ",t.testname,
-              t.item_path,tm.description,t.state,t.status,
-              final_logf,run_duration, 
-              strftime('%m/%d/%Y %H:%M:%S',datetime(t.event_time,'unixepoch'),'localtime'),
-              tm.tags,r.owner,t.comment,
-              author,
-              tm.owner,reviewed,
-              diskfree,uname,rundir,
-              host,cpuload
-            FROM tests AS t JOIN runs AS r ON t.run_id=r.id JOIN test_meta AS tm ON tm.testname=t.testname
-            WHERE runname LIKE ? AND " keyqry ";")))
-    (debug:print 2 *default-log-port* "Using " tempdir " for constructing the ods file. keyqry: " keyqry " keystr: " keysstr " with keys: " (map cadr keypatt-alist)
-		 "\n      mainqry: " mainqry)
-    ;; "Expected Value"
-    ;; "Value Found"
-    ;; "Tolerance"
-    (apply sqlite3:for-each-row
-	   (lambda (test-id . b)
-	     (set! test-ids (cons test-id test-ids))   ;; test-id is now testname
-	     (set! results (append results ;; note, drop the test-id
-				   (list
-				    (if pathmod
-					(let* ((vb        (apply vector b))
-					       (keyvals   (let loop ((i    0)
-								     (res '()))
-							    (if (>= i numkeys)
-								res
-								(loop (+ i 1)
-								      (append res (list (vector-ref vb (+ i 2))))))))
-					       (runname   (vector-ref vb 1))
-					       (testname  (vector-ref vb (+  2 numkeys)))
-					       (item-path (vector-ref vb (+  3 numkeys)))
-					       (final-log (vector-ref vb (+  7 numkeys)))
-					       (run-dir   (vector-ref vb (+ 18 numkeys)))
-					       (log-fpath (conc run-dir "/"  final-log))) ;; (string-intersperse keyvals "/") "/" testname "/" item-path "/"
-					  (debug:print 4 *default-log-port* "log: " log-fpath " exists: " (common:file-exists? log-fpath))
-					  (vector-set! vb (+ 7 numkeys) (if (common:file-exists? log-fpath)
-									    (let ((newpath (conc pathmod "/"
-												 (string-intersperse keyvals "/")
-												 "/" runname "/" testname "/"
-												 (if (string=? item-path "") "" (conc "/" item-path))
-												 final-log)))
-									      ;; for now throw away newpath and use the log-fpath conc'd with pathmod
-									      (set! newpath (conc pathmod log-fpath))
-									      (if windows (string-translate newpath "/" "\\") newpath))
-									    (if (debug:debug-mode 1)
-										(conc final-log " not-found")
-										"")))
-					  (vector->list vb))
-					b)))))
-	   db
-	   mainqry
-	   runspatt (map cadr keypatt-alist))
-    (debug:print 2 *default-log-port* "Found " (length test-ids) " records")
-    (set! results (list (cons "Runs" results)))
-    ;; now, for each test, collect the test_data info and add a new sheet
-    (for-each
-     (lambda (test-id)
-       (let ((test-data (list testdata-header))
-	     (curr-test-name #f))
-	 (sqlite3:for-each-row
-	  (lambda (run-id testname item-path category variable value expected tol units status comment)
-	    (set! curr-test-name testname)
-	    (set! test-data (append test-data (list (list run-id testname item-path category variable value expected tol units status comment)))))
-	  db 
-	  ;; "SELECT run_id,testname,item_path,category,variable,td.value AS value,expected,tol,units,td.status AS status,td.comment AS comment FROM test_data AS td INNER JOIN tests ON tests.id=td.test_id WHERE test_id=?;"
-	  "SELECT run_id,testname,item_path,category,variable,td.value AS value,td.expected,td.tol,td.units,td.status AS status,td.comment AS comment FROM test_data AS td INNER JOIN tests ON tests.id=td.test_id WHERE testname=?;"
-	  test-id)
-	 (if curr-test-name
-	     (set! results (append results (list (cons curr-test-name test-data)))))
-	 ))
-     (sort (delete-duplicates test-ids) string<=))
-    (system (conc "mkdir -p " tempdir))
-    ;; (pp results)
-    (ods:list->ods 
-     tempdir
-     (if (string-match (regexp "^[/~]+.*") outputfile) ;; full path?
-	 outputfile
-	 (begin
-	   (debug:print 0 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory")
-	   (conc (current-directory) "/" outputfile)))
-     results)
-    ;; brutal clean up
-    (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)
-    (system "rm -rf tempdir")))
-
-;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%")
-
+;; options:
+;;
+;;  'killservers  - kills all servers
+;;  'dejunk       - removes junk records
+;;  'adj-testids  - move test-ids into correct ranges
+;;  'old2new      - sync megatest.db to /tmp/.../megatest.db and /tmp/.../megatest_ref.db
+;;  'new2old      - sync /tmp/.../megatest.db to megatest.db and /tmp/.../megatest_ref.db (and update data_synced)
+;;  'closeall     - close all opened dbs
+;;  'schema       - attempt to apply schema changes
+;;  run-ids: '(1 2 3 ...) or #f (for all)
+;;
+(define (db:multi-db-sync dbstruct . options)
+  ;; (if (not (launch:setup))
+  ;;    (debug:print 0 *default-log-port* "ERROR: not able to setup up for megatest.")
+  (let* ((mtdb     (dbr:dbstruct-mtdb dbstruct))
+	 (tmpdb    (db:get-db dbstruct))
+	 (refndb   (dbr:dbstruct-refndb dbstruct))
+	 (allow-cleanup #t) ;; (if run-ids #f #t))
+	 (servers (server:get-list *toppath*)) ;; (tasks:get-all-servers (db:delay-if-busy tdbdat)))
+	 (data-synced 0)) ;; count of changed records (I hope)
+    
+    (for-each
+     (lambda (option)
+       
+       (case option
+	 ;; kill servers
+	 ((killservers)
+	  (for-each
+	   (lambda (server)
+             (handle-exceptions
+             exn
+             (begin 
+               (debug:print-info 0 *default-log-port*  "Unable to get host and/or port from " server ", exn=" exn)     
+               #f)
+	     (match-let (((mod-time host port start-time server-id pid) server))
+	       (if (and host pid)
+		   (tasks:kill-server host pid)))))
+	   servers)
+
+          ;; /tmp/bjbarcla/megatest_localdb/fullrun/.nfs.pdx.disks.icf_env_disk001.bjbarcla.gwa.issues.mtdev.matt-bisect.megatest.ext-tests.runs.all.v1.65.1.6524.dev.bb-24-justrollup-f8.rollup.fullrun/megatest.db.lock
+          (delete-file* (common:get-sync-lock-filepath))
+          )
+	 
+	 ;; clear out junk records
+	 ;;
+	 ((dejunk)
+	  ;; (db:delay-if-busy mtdb) ;; ok to delay on mtdb
+	  (when (file-write-access? (db:dbdat-get-path mtdb)) (db:clean-up mtdb))
+	  (db:clean-up tmpdb)
+	  (db:clean-up refndb))
+
+	 ;; sync runs, test_meta etc.
+	 ;;
+	 ((old2new)
+	  (set! data-synced
+	    (+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb tmpdb refndb)
+	       data-synced)))
+	 
+	 ;; now ensure all newdb data are synced to megatest.db
+	 ;; do not use the run-ids list passed in to the function
+	 ;;
+	 ((new2old)
+	  (set! data-synced
+	    (+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f tmpdb refndb mtdb)
+	       data-synced)))
+
+	 ((adj-target)
+	  (db:adj-target (db:dbdat-get-db mtdb))
+	  (db:adj-target (db:dbdat-get-db tmpdb))
+	  (db:adj-target (db:dbdat-get-db refndb)))
+	 
+	 ((schema)
+	  (db:patch-schema-maindb (db:dbdat-get-db mtdb))
+	  (db:patch-schema-maindb (db:dbdat-get-db tmpdb))
+	  (db:patch-schema-maindb (db:dbdat-get-db refndb))
+	  (db:patch-schema-rundb  (db:dbdat-get-db mtdb))
+	  (db:patch-schema-rundb  (db:dbdat-get-db tmpdb))
+	  (db:patch-schema-rundb  (db:dbdat-get-db refndb))))
+       
+       (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb))
+     options)
+    data-synced))
+
+(define (db:get-access-mode)
+  (if (args:get-arg "-use-db-cache") 'cached 'rmt))
 

Index: db_records.scm
==================================================================
--- db_records.scm
+++ db_records.scm
@@ -201,50 +201,10 @@
 (define-inline (db:test-data-set-units!           vec val)(vector-set!  vec 7  val))
 (define-inline (db:test-data-set-comment!         vec val)(vector-set!  vec 8  val))
 (define-inline (db:test-data-set-status!          vec val)(vector-set!  vec 9  val))
 (define-inline (db:test-data-set-type!            vec val)(vector-set!  vec 10 val))
 
-;;======================================================================
-;; S T E P S 
-;;======================================================================
-;; Run steps
-;; make-vector-record "Run steps" db step id test_id stepname step_complete step_pass event_time    
-(define (make-db:step)(make-vector 9))
-(define-inline (tdb:step-get-id              vec)    (vector-ref  vec 0))
-(define-inline (tdb:step-get-test_id         vec)    (vector-ref  vec 1))
-(define-inline (tdb:step-get-stepname        vec)    (vector-ref  vec 2))
-(define-inline (tdb:step-get-state           vec)    (vector-ref  vec 3))
-(define-inline (tdb:step-get-status          vec)    (vector-ref  vec 4))
-(define-inline (tdb:step-get-event_time      vec)    (vector-ref  vec 5))
-(define-inline (tdb:step-get-logfile         vec)    (vector-ref  vec 6))
-(define-inline (tdb:step-get-comment         vec)    (vector-ref  vec 7))
-(define-inline (tdb:step-get-last_update     vec)    (vector-ref  vec 8))
-(define-inline (tdb:step-set-id!             vec val)(vector-set! vec 0 val))
-(define-inline (tdb:step-set-test_id!        vec val)(vector-set! vec 1 val))
-(define-inline (tdb:step-set-stepname!       vec val)(vector-set! vec 2 val))
-(define-inline (tdb:step-set-state!          vec val)(vector-set! vec 3 val))
-(define-inline (tdb:step-set-status!         vec val)(vector-set! vec 4 val))
-(define-inline (tdb:step-set-event_time!     vec val)(vector-set! vec 5 val))
-(define-inline (tdb:step-set-logfile!        vec val)(vector-set! vec 6 val))
-(define-inline (tdb:step-set-comment!        vec val)(vector-set! vec 7 val))
-
-
-;; The steps table
-(define (make-db:steps-table)(make-vector 5))
-(define-inline (tdb:steps-table-get-stepname   vec)    (vector-ref  vec 0))
-(define-inline (tdb:steps-table-get-start      vec)    (vector-ref  vec 1))
-(define-inline (tdb:steps-table-get-end        vec)    (vector-ref  vec 2))
-(define-inline (tdb:steps-table-get-status     vec)    (vector-ref  vec 3))
-(define-inline (tdb:steps-table-get-runtime    vec)    (vector-ref  vec 4))
-(define-inline (tdb:steps-table-get-log-file   vec)    (vector-ref  vec 5))
-
-(define-inline (tdb:step-stable-set-stepname!  vec val)(vector-set! vec 0 val))
-(define-inline (tdb:step-stable-set-start!     vec val)(vector-set! vec 1 val))
-(define-inline (tdb:step-stable-set-end!       vec val)(vector-set! vec 2 val))
-(define-inline (tdb:step-stable-set-status!    vec val)(vector-set! vec 3 val))
-(define-inline (tdb:step-stable-set-runtime!   vec val)(vector-set! vec 4 val))
-
 ;; The data structure for handing off requests via wire
 (define (make-cdb:packet)(make-vector 6))
 (define-inline (cdb:packet-get-client-sig   vec)    (vector-ref  vec 0))
 (define-inline (cdb:packet-get-qtype        vec)    (vector-ref  vec 1))
 (define-inline (cdb:packet-get-immediate    vec)    (vector-ref  vec 2))

Index: dbmod.scm
==================================================================
--- dbmod.scm
+++ dbmod.scm
@@ -17,23 +17,4629 @@
 ;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
 
 ;;======================================================================
 
 (declare (unit dbmod))
+(declare (uses commonmod))
+(declare (uses ods))
+(declare (uses configfmod))
 
 (module dbmod
 	*
 	
-(import scheme chicken data-structures extras)
-(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18)
-
-(define (just-testing)
-  (print "JUST TESTING"))
-
-;; (define (debug:print . params) #f)
-;; (define (debug:print-info . params) #f)
+(import commonmod)
+(import ods)
+(import configfmod)
+
+(import scheme chicken data-structures extras ports)
+(import
+  (prefix base64 base64:)
+  (prefix sqlite3 sqlite3:)
+  csv
+  csv-xml
+  call-with-environment-variables
+  directory-utils
+  files
+  matchable
+  md5 
+  posix
+  typed-records
+  srfi-18
+  srfi-69
+  regex
+  s11n
+  srfi-1
+  srfi-13
+  stack
+  z3
+  )
+
+;;======================================================================
+;;  R E C O R D S
+;;======================================================================
+
+(include "db_records.scm")
+
+;; each db entry is a pair ( db . dbfilepath )
+;; I propose this record evolves into the area record
+;;
+(defstruct dbr:dbstruct 
+  (tmpdb       #f)
+  (dbstack     #f) ;; stack for tmp db handles, do not initialize with a stack
+  (mtdb        #f)
+  (refndb      #f)
+  (homehost    #f) ;; not used yet
+  (on-homehost #f) ;; not used yet
+  (read-only   #f)
+  (locdbs      #f)
+  (stmt-cache  (make-hash-table))
+  )                ;; goal is to converge on one struct for an area but for now it is too confusing
+  
+
+;; record for keeping state,status and count for doing roll-ups in
+;; iterated tests
+;;
+(defstruct dbr:counts
+  (state #f)
+  (status #f)
+  (count  0)) 
+
+;;======================================================================
+;; hash of hashs
+;;======================================================================
+
+(define (db:hoh-set! dat key1 key2 val)
+  (let* ((subhash (hash-table-ref/default dat key1 #f)))
+    (if subhash
+	(hash-table-set! subhash key2 val)
+	(begin
+	  (hash-table-set! dat key1 (make-hash-table))
+	  (db:hoh-set! dat key1 key2 val)))))
+
+(define (db:hoh-get dat key1 key2)
+  (let* ((subhash (hash-table-ref/default dat key1 #f)))
+    (and subhash
+	 (hash-table-ref/default subhash key2 #f))))
+
+(define (db:get-cache-stmth dbstruct db stmt)
+  (let* ((stmt-cache        (dbr:dbstruct-stmt-cache dbstruct))
+	 (stmth             (db:hoh-get stmt-cache db stmt)))
+    (or stmth
+	(let* ((newstmth (sqlite3:prepare db stmt)))
+	  (db:hoh-set! stmt-cache db stmt newstmth)
+	  newstmth))))
+
+;;======================================================================
+;; SQLITE3 HELPERS
+;;======================================================================
+
+(define (db:general-sqlite-error-dump  exn stmt . params)
+  (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) ;; RADT ... how does this work?
+    ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn)
+    ;; (print "err-status: " err-status)
+    (debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn))
+    (print-call-chain (current-error-port))))
+
+;; convert to -inline 
+;;
+(define (db:first-result-default db stmt default . params)
+  (handle-exceptions
+   exn
+   (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
+     ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn)
+     (if (eq? err-status 'done)
+	 default
+	 (begin
+	   (debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
+	   (print-call-chain (current-error-port))
+	   default)))
+   (apply sqlite3:first-result db stmt params)))
+
+;; Open the classic megatest.db file (defaults to open in toppath)
+;;
+;;   NOTE: returns a dbdat not a dbstruct!
+;;
+(define (db:open-megatest-db #!key (path #f)(name #f))
+  (let* ((dbdir        (or path *toppath*))
+         (dbpath       (conc  dbdir "/" (or name "megatest.db")))
+	 (dbexists     (file-exists? dbpath))
+	 (db           (db:lock-create-open dbpath
+					    (lambda (db)
+                                              (db:initialize-main-db db)
+					      ;;(db:initialize-run-id-db db)
+					      )))
+	 (write-access (file-write-access? dbpath)))
+    (debug:print-info 13 *default-log-port* "db:open-megatest-db "dbpath)
+    (if (and dbexists (not write-access))
+	(set! *db-write-access* #f))
+    (cons db dbpath)))
+
+;; open an sql database inside a file lock
+;; returns: db existed-prior-to-opening
+;; RA => Returns a db handler; sets the lock if opened in writable mode
+;;
+;; (define *db-open-mutex* (make-mutex))
+
+(define (db:lock-create-open fname initproc)
+  (let* ((parent-dir   (or (pathname-directory fname)(current-directory))) ;; no parent? go local
+         (raw-fname    (pathname-file fname))
+	 (dir-writable (file-write-access? parent-dir))
+	 (file-exists  (common:file-exists? fname))
+	 (file-write   (if file-exists
+			   (file-write-access? fname)
+			   dir-writable )))
+    ;; (mutex-lock! *db-open-mutex*) ;; tried this mutex, not clear it helped.
+    (if file-write ;; dir-writable
+	(condition-case
+         (let* ((lockfname   (conc fname ".lock"))
+                (readyfname  (conc parent-dir "/.ready-" raw-fname))
+                (readyexists (common:file-exists? readyfname)))
+           (if (not readyexists)
+               (common:simple-file-lock-and-wait lockfname))
+           (let ((db      (sqlite3:open-database fname)))
+             (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
+             (sqlite3:execute db "PRAGMA synchronous = 0;")
+             #;(if (and (configf:lookup *configdat* "setup" "tmp_mode") (string-match "^/tmp/.*" fname))
+                 (begin
+                   ;;(print "DEBUG: Setting tmp_mode for " fname) 
+                   (sqlite3:execute db (configf:lookup *configdat* "setup" "tmp_mode"))
+                   )
+                 )  
+             #;(if (and (configf:lookup *configdat* "setup" "nfs_mode") (not (string-match "^/tmp/.*" fname)))
+                 (begin
+                   ;;(print "DEBUG: Setting nfs_mode for " fname)
+                   (sqlite3:execute db (configf:lookup *configdat* "setup" "nfs_mode"))
+                   )
+                 )  
+             #;(if (and (not (or (configf:lookup *configdat* "setup" "tmp_mode") (configf:lookup *configdat* "setup" "nfs_mode")))  
+                      (configf:lookup *configdat* "setup" "use-wal")
+                      (string-match "^/tmp/.*" fname)) ;; this is a file in /tmp
+                 (sqlite3:execute db "PRAGMA journal_mode=WAL;")
+                 (debug:print 2 *default-log-port* "Creating " fname " in NON-WAL mode."))
+             (if (not file-exists)
+                 (initproc db))
+             (if (not readyexists)
+                 (begin
+                   (common:simple-file-release-lock lockfname)
+                   (with-output-to-file
+                       readyfname
+                     (lambda ()
+                       (print "Ready at " 
+                              (seconds->year-work-week/day-time 
+                               (current-seconds)))))))
+             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))))
+        
+	(condition-case
+         (begin
+           (debug:print 2 *default-log-port* "WARNING: opening db in non-writable dir " fname)
+           (let ((db (sqlite3:open-database fname)))
+             (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
+             (sqlite3:execute db "PRAGMA synchronous = 0;")
+	     ;; (mutex-unlock! *db-open-mutex*)
+             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))))
+	)))
+
+(define (db:initialize-main-db dbdat)
+  (assert *db-keys* "Attempt to initialize main db before configs are properly processed")
+  ;; (if (not *configinfo*)(launch:setup)) ;; added because Elena was getting stack dump because *configinfo* below was #f.
+  (let* ((keys     *db-keys*)
+	 (havekeys (> (length keys) 0))
+	 (keystr   (keys->keystr keys))
+	 (fieldstr (keys:make-key/field-string keys)) ;;; configdat))
+	 (db       (db:dbdat-get-db dbdat)))
+    (for-each (lambda (key)
+		(let ((keyn key))
+		  (if (member (string-downcase keyn)
+			      (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count"
+				    "pass_count" "contour"))
+		      (begin
+			(print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table, you must remove your megatest.db and <linktree>/.db before trying again.")
+			(exit 1)))))
+	      keys)
+    (sqlite3:with-transaction
+     db
+     (lambda ()
+      ;; handle-exceptions
+      ;; exn
+      ;; (begin
+      ;;   (debug:print 0 "ERROR: Failed to create tables. Look at your [fields] section, should be: fieldname TEXT DEFAULT 'yourdefault'")
+      ;;   (exit))
+	(sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));")
+	(for-each (lambda (key)
+		    (sqlite3:execute db "INSERT OR REPLACE INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT"))
+		  keys)
+	(sqlite3:execute db (conc 
+			     "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, \n			 " 
+			     fieldstr (if havekeys "," "") "
+			 runname    TEXT DEFAULT 'norun',
+                         contour    TEXT DEFAULT '',
+			 state      TEXT DEFAULT '',
+			 status     TEXT DEFAULT '',
+			 owner      TEXT DEFAULT '',
+			 event_time TIMESTAMP DEFAULT (strftime('%s','now')),
+			 comment    TEXT DEFAULT '',
+			 fail_count INTEGER DEFAULT 0,
+			 pass_count INTEGER DEFAULT 0,
+                         last_update INTEGER DEFAULT (strftime('%s','now')),
+			 CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));"))
+        ;; All triggers created at once in end
+	;;(sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs
+        ;;                    FOR EACH ROW
+        ;;                       BEGIN 
+        ;;                         UPDATE runs SET last_update=(strftime('%s','now'))
+        ;;                           WHERE id=old.id;
+        ;;                       END;")
+	(sqlite3:execute db "CREATE TABLE IF NOT EXISTS run_stats (
+                              id     INTEGER PRIMARY KEY,
+                              run_id INTEGER,
+                              state  TEXT,
+                              status TEXT,
+                              count  INTEGER,
+                              last_update INTEGER DEFAULT (strftime('%s','now')))")
+         ;; All triggers created at once in end
+         ;; (sqlite3:execute db "CREATE TRIGGER  IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats
+         ;;                   FOR EACH ROW
+         ;;                     BEGIN 
+         ;;                       UPDATE run_stats SET last_update=(strftime('%s','now'))
+         ;;                         WHERE id=old.id;
+         ;;                      END;")
+	(sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta (
+                                     id          INTEGER PRIMARY KEY,
+                                     testname    TEXT DEFAULT '',
+                                     author      TEXT DEFAULT '',
+                                     owner       TEXT DEFAULT '',
+                                     description TEXT DEFAULT '',
+                                     reviewed    TIMESTAMP,
+                                     iterated    TEXT DEFAULT '',
+                                     avg_runtime REAL,
+                                     avg_disk    REAL,
+                                     tags        TEXT DEFAULT '',
+                                     jobgroup    TEXT DEFAULT 'default',
+                                CONSTRAINT test_meta_constraint UNIQUE (testname));")
+	(sqlite3:execute db "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY,
+                                action TEXT DEFAULT '',
+                                owner TEXT,
+                                state TEXT DEFAULT 'new',
+                                target TEXT DEFAULT '',
+                                name TEXT DEFAULT '',
+                                testpatt TEXT DEFAULT '',
+                                keylock TEXT,
+                                params TEXT,
+                                creation_time TIMESTAMP DEFAULT (strftime('%s','now')),
+                                execution_time TIMESTAMP);")
+	;; archive disk areas, cached info from [archive-disks]
+	(sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_disks (
+                                id INTEGER PRIMARY KEY,
+                                archive_area_name TEXT,
+                                disk_path TEXT,
+                                last_df INTEGER DEFAULT -1,
+                                last_df_time TIMESTAMP DEFAULT (strftime('%s','now')),
+                                creation_time TIMESTAMP DEFAULT (strftime('%s','now')));")
+	;; individual bup (or tar) data chunks
+	(sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_blocks (
+                                id INTEGER PRIMARY KEY,
+                                archive_disk_id INTEGER,
+                                disk_path TEXT,
+                                last_du INTEGER DEFAULT -1,
+                                last_du_time TIMESTAMP DEFAULT (strftime('%s','now')),
+                                creation_time TIMESTAMP DEFAULT (strftime('%s','now')));")
+	;; tests allocated to what chunks. reusing a chunk for a test/item_path is very efficient
+	;; NB// the per run/test recording of where the archive is stored is done in the test
+	;;      record. 
+	(sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_allocations (
+                                id INTEGER PRIMARY KEY,
+                                archive_block_id INTEGER,
+                                testname TEXT,
+                                item_path TEXT,
+                                creation_time TIMESTAMP DEFAULT (strftime('%s','now')));")
+	;; move this clean up call somewhere else
+	(sqlite3:execute db "DELETE FROM tasks_queue WHERE state='done' AND creation_time < ?;" (- (current-seconds)(* 24 60 60))) ;; remove older than 24 hrs
+	(sqlite3:execute db (conc "CREATE INDEX IF NOT EXISTS runs_index ON runs (runname" (if havekeys "," "") keystr ");"))
+	;; (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;")
+	(sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);")
+	(sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT,
+                                  CONSTRAINT metadat_constraint UNIQUE (var));")
+	(sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);")
+	;; Must do this *after* running patch db !! No more. 
+	;; cannot use db:set-var since it will deadlock, hardwire the code here
+	(sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" (common:version-signature))
+	(debug:print-info 11 *default-log-port* "db:initialize END") ;; ))))
+
+	;;======================================================================
+	;; R U N   S P E C I F I C   D B 
+	;;======================================================================
+	
+	;; (define (db:initialize-run-id-db db)
+	;;   (sqlite3:with-transaction 
+	;;    db
+	;;    (lambda ()
+	(sqlite3:execute db "CREATE TABLE IF NOT EXISTS tests 
+                    (id INTEGER PRIMARY KEY,
+                     run_id       INTEGER   DEFAULT -1,
+                     testname     TEXT      DEFAULT 'noname',
+                     host         TEXT      DEFAULT 'n/a',
+                     cpuload      REAL      DEFAULT -1,
+                     diskfree     INTEGER   DEFAULT -1,
+                     uname        TEXT      DEFAULT 'n/a', 
+                     rundir       TEXT      DEFAULT '/tmp/badname',
+                     shortdir     TEXT      DEFAULT '/tmp/badname',
+                     item_path    TEXT      DEFAULT '',
+                     state        TEXT      DEFAULT 'NOT_STARTED',
+                     status       TEXT      DEFAULT 'FAIL',
+                     attemptnum   INTEGER   DEFAULT 0,
+                     final_logf   TEXT      DEFAULT 'logs/final.log',
+                     logdat       TEXT      DEFAULT '', 
+                     run_duration INTEGER   DEFAULT 0,
+                     comment      TEXT      DEFAULT '',
+                     event_time   TIMESTAMP DEFAULT (strftime('%s','now')),
+                     fail_count   INTEGER   DEFAULT 0,
+                     pass_count   INTEGER   DEFAULT 0,
+                     archived     INTEGER   DEFAULT 0, -- 0=no, > 1=archive block id where test data can be found
+                     last_update  INTEGER DEFAULT (strftime('%s','now')),
+                        CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path));")
+	;; deprecated -- (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path, uname);")
+        
+        (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_run_id_index ON tests (run_id);")  ;; new
+        (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_testname_index ON tests (testname,item_path);") ;; new
+        (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_state_status_index ON tests (state, status); ") ;; new
+
+         ;; All triggers created at once in end
+	;;(sqlite3:execute db "CREATE TRIGGER  IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests
+        ;;                     FOR EACH ROW
+        ;;                       BEGIN 
+        ;;                         UPDATE tests SET last_update=(strftime('%s','now'))
+        ;;                           WHERE id=old.id;
+        ;;                       END;")
+	(sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps 
+                              (id INTEGER PRIMARY KEY,
+                               test_id INTEGER, 
+                               stepname TEXT, 
+                               state TEXT DEFAULT 'NOT_STARTED', 
+                               status TEXT DEFAULT 'n/a',
+                               event_time TIMESTAMP,
+                               comment TEXT DEFAULT '',
+                               logfile TEXT DEFAULT '',
+                               last_update  INTEGER DEFAULT (strftime('%s','now')),
+                               CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));")
+	(sqlite3:execute db "CREATE INDEX IF NOT EXISTS teststeps_index ON tests (run_id, testname, item_path);")
+        ;; All triggers created at once in end
+	;;(sqlite3:execute db "CREATE TRIGGER  IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps
+        ;;                     FOR EACH ROW
+        ;;                       BEGIN 
+        ;;                         UPDATE test_steps SET last_update=(strftime('%s','now'))
+        ;;                           WHERE id=old.id;
+        ;;                       END;")
+	(sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY,
+                                test_id INTEGER,
+                                category TEXT DEFAULT '',
+                                variable TEXT,
+	                        value REAL,
+	                        expected REAL,
+	                        tol REAL,
+                                units TEXT,
+                                comment TEXT DEFAULT '',
+                                status TEXT DEFAULT 'n/a',
+                                type TEXT DEFAULT '',
+                                last_update  INTEGER DEFAULT (strftime('%s','now')),
+                              CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));")
+	(sqlite3:execute db "CREATE INDEX IF NOT EXISTS test_data_index ON test_data (test_id);")
+        ;; All triggers created at once in end
+	;;(sqlite3:execute db "CREATE TRIGGER  IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data
+        ;;                     FOR EACH ROW
+        ;;                       BEGIN 
+        ;;                         UPDATE test_data SET last_update=(strftime('%s','now'))
+        ;;                           WHERE id=old.id;
+        ;;                       END;")
+	(sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat (
+                              id           INTEGER PRIMARY KEY,
+                              test_id      INTEGER,
+                              update_time  TIMESTAMP,
+                              cpuload      INTEGER DEFAULT -1,
+                              diskfree     INTEGER DEFAULT -1,
+                              diskusage    INTGER DEFAULT -1,
+                              run_duration INTEGER DEFAULT 0);")
+	(sqlite3:execute db "CREATE TABLE IF NOT EXISTS archives (
+                              id           INTEGER PRIMARY KEY,
+                              test_id      INTEGER,
+                              state        TEXT DEFAULT 'new',
+                              status       TEXT DEFAULT 'n/a',
+                              archive_type TEXT DEFAULT 'bup',
+                              du           INTEGER,
+                              archive_path TEXT);")))
+         ;; (print "creating trigges from init") 
+        (db:create-triggers db)    
+     db)) ;; )
+
+(define (db:create-all-triggers dbstruct)
+(db:with-db
+   dbstruct #f #f
+   (lambda (db)
+(db:create-triggers db))))
+
+(define (db:create-triggers db)
+    (for-each (lambda (key)
+              (sqlite3:execute db (cadr key)))
+          db:trigger-list))
+
+(define (db:drop-all-triggers dbstruct)
+  (db:with-db
+   dbstruct #f #f
+   (lambda (db)
+     (db:drop-triggers db))))
+
+(define (db:is-trigger-dropped db tbl-name)
+  (let* ((trigger-name (if (equal? tbl-name "test_steps")
+			   "update_teststeps_trigger" 
+                           (conc "update_" tbl-name "_trigger")))
+	 (res          #f))
+    (sqlite3:for-each-row
+     (lambda (name)
+       (if (equal? name trigger-name)
+	   (set! res #t)))
+     db 
+     "SELECT name FROM sqlite_master WHERE type = 'trigger' ;" 
+     )))
+
+(define (db:drop-triggers db)
+  (for-each
+   (lambda (key) 
+     (sqlite3:execute db (conc "drop trigger if exists " (car key))))
+   db:trigger-list))
+
+(define  (db:drop-trigger db tbl-name)
+  (let* ((trigger-name (if (equal? tbl-name "test_steps")
+			   "update_teststeps_trigger" 
+                           (conc "update_" tbl-name "_trigger"))))
+    (for-each
+     (lambda (key) 
+       (if (equal? (car key) trigger-name)
+           (sqlite3:execute db (conc "drop trigger if exists " trigger-name))))
+     db:trigger-list)))
+
+(define  (db:create-trigger db tbl-name)
+      (let* ((trigger-name (if (equal? tbl-name "test_steps")
+                              "update_teststeps_trigger" 
+                              (conc "update_" tbl-name "_trigger"))))
+       (for-each (lambda (key) 
+             (if (equal? (car key) trigger-name)
+             (sqlite3:execute db (cadr key))))
+      db:trigger-list))) 
+
+;; Get/open a database
+;;    if run-id => get run specific db
+;;    if #f     => get main db
+;;    if db already open - return inmem
+;;    if db not open, open inmem, rundb and sync then return inmem
+;;    inuse gets set automatically for rundb's
+;;
+(define (db:get-db dbstruct) ;;  run-id)
+  (assert *db-cache-path* "ERROR: Attempt to call db:get-db before /tmp area is set up")
+  (if (stack? (dbr:dbstruct-dbstack dbstruct))
+      (if (stack-empty? (dbr:dbstruct-dbstack dbstruct))
+          (let ((newdb (db:open-megatest-db path: *db-cache-path*))) ;; (common:get-db-tmp-area)))) ;; db:dbfile-path))))
+            ;; (stack-push! (dbr:dbstruct-dbstack dbstruct) newdb)
+            newdb)
+          (stack-pop! (dbr:dbstruct-dbstack dbstruct)))
+      (db:open-db dbstruct)))
+
+;; ;; legacy handling of structure for managing db's. Refactor this into dbr:?
+(define (db:dbdat-get-db dbdat)
+  (if (pair? dbdat)
+      (car dbdat)
+      dbdat))
+
+(define (db:dbdat-get-path dbdat)
+  (if (pair? dbdat)
+      (cdr dbdat)
+      #f))
+
+(define-inline (db:generic-error-printout exn . message)
+  (print-call-chain (current-error-port))
+  (apply debug:print-error 0 *default-log-port* message)
+  (debug:print-error 0 *default-log-port* "   params: " params
+		     ", error: "     ((condition-property-accessor 'exn 'message)   exn)
+		     ", arguments: " ((condition-property-accessor 'exn 'arguments) exn)
+		     ", location: "  ((condition-property-accessor 'exn 'location)  exn)
+		     ))
+
+;; (db:with-db dbstruct run-id sqlite3:exec "select blah fgrom blaz;")
+;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no
+;;
+(define (db:with-db dbstruct run-id r/w proc . params)
+  (let* ((have-struct (dbr:dbstruct? dbstruct))
+         (dbdat     (if have-struct 
+			(db:get-db dbstruct)
+			#f))
+	 (db        (if have-struct
+			(db:dbdat-get-db dbdat)
+			dbstruct))
+	 (fname     (db:dbdat-get-path dbdat))
+	 (use-mutex (> *api-process-request-count* 25))) ;; was 25
+    (if (and use-mutex
+	     (common:low-noise-print 120 "over-50-parallel-api-requests"))
+	(debug:print-info 0 *default-log-port* *api-process-request-count* " parallel api requests being processed in process " (current-process-id) ", throttling access"))
+    (if (common:low-noise-print 600 (conc "parallel-api-requests" *max-api-process-requests*))
+	(debug:print-info 2 *default-log-port* "Parallel api request count: " *api-process-request-count* " max parallel requests: " *max-api-process-requests*))
+    (condition-case
+     (begin
+       (if use-mutex (mutex-lock! *db-with-db-mutex*))
+       (let ((res (apply proc db params)))
+	 (if use-mutex (mutex-unlock! *db-with-db-mutex*))
+	 ;; (if (vector? dbstruct)(db:done-with dbstruct run-id r/w))
+	 (if dbdat (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat))
+	 res))
+     (exn (io-error)
+	  (db:generic-error-printout exn "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again."))
+     (exn (corrupt)
+	  (db:generic-error-printout exn "ERROR: database " fname " is corrupt. Repair it to proceed."))
+     (exn (busy)
+	  (db:generic-error-printout exn "ERROR: database " fname
+				     " is locked. Try copying to another location, remove original and copy back."))
+     (exn (permission)(db:generic-error-printout exn "ERROR: database " fname " has some permissions problem."))
+     (exn ()
+	  (db:generic-error-printout exn "ERROR: Unknown error with database " fname " message: "
+		       ((condition-property-accessor 'exn 'message) exn))))))
+      
+;; This routine creates the db if not already present. It is only called if the db is not already opened
+;;
+(define (db:open-db dbstruct #!key (areapath #f)(do-sync #t)) ;; TODO: actually use areapath
+  (assert *db-cache-path* "ERROR: db:open-db called before /tmp area has been setup")
+  (let ((tmpdb-stack (dbr:dbstruct-dbstack dbstruct))) ;; RA => Returns the first reference in dbstruct
+    (if (stack? tmpdb-stack)
+	(db:get-db tmpdb-stack) ;; get previously opened db (will create new db handle if all in the stack are already used
+        (let* ((max-stale-tmp 10) ;; (configf:lookup-number *configdat* "server" "filling-db-max-stale-seconds" default: 10))
+               (dbpath       *db-cache-path*) ;;; (db:dbfile-path ))      ;; path to tmp db area
+               (dbexists     (common:file-exists? dbpath))
+	       (tmpdbfname   (conc dbpath "/megatest.db"))
+	       (dbfexists    (common:file-exists? tmpdbfname))  ;; (conc dbpath "/megatest.db")))
+               (mtdbexists   (common:file-exists? (conc *toppath* "/megatest.db")))
+							 
+               (mtdbmodtime  (if mtdbexists (common:lazy-sqlite-db-modification-time (conc *toppath* "/megatest.db"))   #f))
+	        		 (tmpdbmodtime (if dbfexists  (common:lazy-sqlite-db-modification-time tmpdbfname) #f)) 
+               (mtdb         (db:open-megatest-db))
+               (mtdbpath     (db:dbdat-get-path mtdb))
+               (tmpdb        (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db))
+               (refndb       (db:open-megatest-db path: dbpath name: "megatest_ref.db"))
+               (write-access (file-write-access? mtdbpath))
+	       ;(mtdbmodtime  (if mtdbexists (common:lazy-sqlite-db-modification-time mtdbpath)   #f)) ; moving this before db:open-megatest-db is called. if wal mode is on -WAL and -shm file get created with causing the  tmpdbmodtime timestamp always greater than mtdbmodtime
+	       ;(tmpdbmodtime (if dbfexists  (common:lazy-sqlite-db-modification-time tmpdbfname) #f)) 
+					;if wal mode is on -WAL and -shm file get created when db:open-megatest-db is called. modtimedelta will always be < 10 so db in tmp not get synced
+          ;(tmpdbmodtime (if dbfexists (db:get-last-update-time (car tmpdb)) #f))    
+          ;(fmt (file-modification-time tmpdbfname))
+	       (modtimedelta (and mtdbmodtime tmpdbmodtime (- mtdbmodtime tmpdbmodtime))))
+
+	  (assert (sqlite3:database? (car mtdb)) "ERROR: in db:open-db and mtdb does not contain database!")
+          (when write-access
+            (sqlite3:execute (car mtdb) "drop trigger if exists update_tests_trigger")
+            (sqlite3:execute (car mtdb) "drop trigger if exists update_runs_trigger"))
+          
+         ;(print "mtdbmodtime " mtdbmodtime " tmpdbmodtime " tmpdbmodtime " mtdbpath " mtdbpath " " (conc *toppath* "/megatest.db"))
+	        ;;(debug:print-info 13 *default-log-port* "db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists" and write-access="write-access)
+          (if (and dbexists (not write-access))
+              (begin
+                (set! *db-write-access* #f)
+                (dbr:dbstruct-read-only-set! dbstruct #t)))
+          (dbr:dbstruct-mtdb-set!   dbstruct mtdb)
+          (dbr:dbstruct-tmpdb-set!  dbstruct tmpdb)
+          (dbr:dbstruct-dbstack-set! dbstruct (make-stack)) ;; BB: why a stack?  Why would the number of db's be indeterminate?  Is this a legacy of 1.db 2.db .. ?
+          (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb) ;; olddb is already a (cons db path)
+          (dbr:dbstruct-refndb-set! dbstruct refndb)
+          (if (and  (or (not dbfexists)
+			(and modtimedelta
+			     (> modtimedelta max-stale-tmp))) ;; if db in tmp is over ten seconds older than the file in MTRA then do a sync back
+		    do-sync)
+	      (begin
+		(debug:print 1 *default-log-port* "filling db " (db:dbdat-get-path tmpdb) " with data \n    from " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta)
+		(db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb refndb tmpdb)
+    ;touch tmp db to avoid wal mode wierdness  
+     (set! (file-modification-time tmpdbfname) (current-seconds))  
+                (debug:print-info 13 *default-log-port* "db:sync-all-tables-list done.")
+                )
+	      (debug:print 4 *default-log-port* " db, " (db:dbdat-get-path tmpdb) " already exists or fresh enough, not propogating data from\n     " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta) )
+	  ;; (db:multi-db-sync dbstruct 'old2new))  ;; migrate data from megatest.db automatically
+          tmpdb))))
+
+;; just tests, test_steps and test_data tables
+(define db:sync-tests-only
+  (list
+   ;; (list "strs"
+   ;;       '("id"             #f)
+   ;;       '("str"            #f))
+   (list "tests" 
+	 '("id"             #f)
+	 '("run_id"         #f)
+	 '("testname"       #f)
+	 '("host"           #f)
+	 '("cpuload"        #f)
+	 '("diskfree"       #f)
+	 '("uname"          #f)
+	 '("rundir"         #f)
+	 '("shortdir"       #f)
+	 '("item_path"      #f)
+	 '("state"          #f)
+	 '("status"         #f)
+	 '("attemptnum"     #f)
+	 '("final_logf"     #f)
+	 '("logdat"         #f)
+	 '("run_duration"   #f)
+	 '("comment"        #f)
+	 '("event_time"     #f)
+	 '("fail_count"     #f)
+	 '("pass_count"     #f)
+	 '("archived"       #f)
+         '("last_update"    #f))
+  (list "test_steps"
+	 '("id"             #f)
+	 '("test_id"        #f)
+	 '("stepname"       #f)
+	 '("state"          #f)
+	 '("status"         #f)
+	 '("event_time"     #f)
+	 '("comment"        #f)
+	 '("logfile"        #f)
+         '("last_update"    #f))
+   (list "test_data"
+	 '("id"             #f)
+	 '("test_id"        #f)
+	 '("category"       #f)
+	 '("variable"       #f)
+	 '("value"          #f)
+	 '("expected"       #f)
+	 '("tol"            #f)
+	 '("units"          #f)
+	 '("comment"        #f)
+	 '("status"         #f)
+	 '("type"           #f)
+         '("last_update"    #f))))
+
+;; needs db to get keys, this is for syncing all tables
+;;
+(define (db:sync-main-list dbstruct)
+  (assert *db-keys* "ERROR: db:sync-main-list called before *db-keys* has been setup")
+  (let ((keys  *db-keys*)) ;; (db:get-keys dbstruct)))
+    (list
+     (list "keys"
+	   '("id"        #f)
+	   '("fieldname" #f)
+	   '("fieldtype" #f))
+     (list "metadat" '("var" #f) '("val" #f))
+     (append (list "runs" 
+		   '("id"  #f))
+	     (map (lambda (k)(list k #f))
+		  (append keys
+			  (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour" "last_update"))))
+     (list "archive_disks"
+           '("id" #f)
+           '("archive_area_name" #f) 
+           '("disk_path" #f)
+           '("last_df" #f)
+           '("last_df_time" #f)
+           '("creation_time" #f)) 
+
+     (list "archive_blocks"
+           '("id" #f)
+           '("archive_disk_id" #f) 
+           '("disk_path" #f)
+           '("last_du" #f)
+           '("last_du_time" #f)
+           '("creation_time" #f)) 
+
+     (list "test_meta"
+	   '("id"             #f)
+	   '("testname"       #f)
+	   '("owner"          #f)
+	   '("description"    #f)
+	   '("reviewed"       #f)
+	   '("iterated"       #f)
+	   '("avg_runtime"    #f)
+	   '("avg_disk"       #f)
+	   '("tags"           #f)
+	   '("jobgroup"       #f)))))
+
+(define (db:sync-all-tables-list dbstruct)
+  (append (db:sync-main-list dbstruct)
+	  db:sync-tests-only))
+
+;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) )
+;; db's are dbdat's
+;;
+;; if last-update specified ("field-name" . time-in-seconds)
+;;    then sync only records where field-name >= time-in-seconds
+;;    IFF field-name exists
+;;
+(define (db:sync-tables tbls last-update fromdb todb . slave-dbs)
+  ;;(handle-exceptions
+  ;;exn
+  ;;(begin
+  ;;  (debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.")
+  ;;  (print-call-chain (current-error-port))
+  ;;  (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+  ;;  (debug:print 5 *default-log-port* "exn=" (condition->list exn))
+  ;;  (debug:print 0 *default-log-port* " status:  " ((condition-property-accessor 'sqlite3 'status) exn))
+  ;;  (debug:print 0 *default-log-port* " src db:  " (db:dbdat-get-path fromdb))
+  ;;  (for-each (lambda (dbdat)
+  ;;		 (let ((dbpath (db:dbdat-get-path dbdat)))
+  ;;		   (debug:print 0 *default-log-port* " dbpath:  " dbpath)
+  ;;		   (if (not (db:repair-db dbdat))
+  ;;		       (begin
+  ;;			 (debug:print-error 0 *default-log-port* "Failed to rebuild " dbpath ", exiting now.")
+  ;;			 (exit)))))
+  ;;	       (cons todb slave-dbs))
+  ;;  
+  ;;  0)
+   ;; this is the work to be done
+   (cond
+    ((not fromdb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with fromdb missing")
+     -1)
+    ((not todb)   (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with todb missing")
+     -2)
+    ((not (sqlite3:database? (db:dbdat-get-db fromdb)))
+     (debug:print-error 0 *default-log-port* "db:sync-tables called with fromdb not a database " fromdb)
+     -3)
+    ((not (sqlite3:database? (db:dbdat-get-db todb)))
+     (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a database " todb)
+     -4)
+
+    ((not (file-write-access? (db:dbdat-get-path todb)))
+     (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a read-only database " todb)
+     -5)
+    ((not (null? (let ((readonly-slave-dbs
+                        (filter
+                         (lambda (dbdat)
+                           (not (file-write-access? (db:dbdat-get-path todb))))
+                         slave-dbs)))
+                   (for-each
+                    (lambda (bad-dbdat)
+                      (debug:print-error
+                       0 *default-log-port* "db:sync-tables called with todb not a read-only database " bad-dbdat))
+                    readonly-slave-dbs)
+                   readonly-slave-dbs))) -6)
+    (else
+     (let ((stmts       (make-hash-table)) ;; table-field => stmt
+	   (all-stmts   '())              ;; ( ( stmt1 value1 ) ( stml2 value2 ))
+	   (numrecs     (make-hash-table))
+	   (start-time  (current-milliseconds))
+	   (tot-count   0))
+       (for-each ;; table
+	(lambda (tabledat)
+	  (let* ((tablename        (car tabledat))
+		 (fields           (cdr tabledat))
+		 (has-last-update  (member "last_update" fields))
+		 (use-last-update  (cond
+				    ((and has-last-update
+					  (member "last_update" fields))
+				     #t) ;; if given a number, just use it for all fields
+				    ((number? last-update) #f) ;; if not matched first entry then ignore last-update for this table
+				    ((and (pair? last-update)
+					  (member (car last-update)    ;; last-update field name
+						  (map car fields)))
+                                        #t)
+				    (last-update
+				     (debug:print 0 *default-log-port* "ERROR: parameter last-update for db:sync-tables must be a pair or a number, received: " last-update);; found in fields
+				     #f)
+				    (else
+				     #f)))
+		 (last-update-value (if use-last-update ;; no need to check for has-last-update - it is already accounted for
+					(if (number? last-update)
+					    last-update
+					    (cdr last-update))
+					#f))
+		 (last-update-field (if use-last-update
+					(if (number? last-update)
+					    "last_update"
+					    (car last-update))
+					#f))
+		 (num-fields (length fields))
+		 (field->num (make-hash-table))
+		 (num->field (apply vector (map car fields))) ;; BBHERE
+		 (full-sel   (conc "SELECT " (string-intersperse (map car fields) ",") 
+				   " FROM " tablename (if use-last-update ;; apply last-update criteria
+							  (conc " WHERE " last-update-field " >= " last-update-value)
+							  "")
+				   ";"))
+		 (full-ins   (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) "
+				   " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );"))
+		 (fromdat    '())
+		 (fromdats   '())
+		 (totrecords 0)
+		 (batch-len  100) ;; (string->number (or (configf:lookup *configdat* "sync" "batchsize") "100")))
+		 (todat      (make-hash-table))
+		 (count      0)
+                 (field-names (map car fields))
+                 (delay-handicap 0) ;; (string->number (or (configf:lookup *configdat* "sync" "delay-handicap") "0")))
+                 )
+
+	    ;; set up the field->num table
+	    (for-each
+	     (lambda (field)
+	       (hash-table-set! field->num field count)
+	       (set! count (+ count 1)))
+	     fields)
+
+	    ;; read the source table
+	    (sqlite3:for-each-row
+	     (lambda (a . b)
+	       (set! fromdat (cons (apply vector a b) fromdat))
+	       (if (> (length fromdat) batch-len)
+		   (begin
+		     (set! fromdats (cons fromdat fromdats))
+		     (set! fromdat  '())
+		     (set! totrecords (+ totrecords 1)))))
+	     (db:dbdat-get-db fromdb)
+	     full-sel)
+	    
+	    ;; tack on remaining records in fromdat
+	    (if (not (null? fromdat))
+		(set! fromdats (cons fromdat fromdats)))
+
+	    (if (common:low-noise-print 120 "sync-records")
+		(debug:print-info 4 *default-log-port* "found " totrecords " records to sync"))
+
+	    ;; read the target table; BBHERE
+	    (sqlite3:for-each-row
+	     (lambda (a . b)
+	       (hash-table-set! todat a (apply vector a b)))
+	     (db:dbdat-get-db todb)
+	     full-sel)
+
+            (when (and delay-handicap (> delay-handicap 0))
+              (debug:print-info 0 *default-log-port* "imposing synthetic sync delay of "delay-handicap" seconds since sync/delay-handicap is configured")
+              (thread-sleep! delay-handicap)
+              (debug:print-info 0 *default-log-port* "synthetic sync delay of "delay-handicap" seconds completed")
+              )
+            
+	    ;; first pass implementation, just insert all changed rows
+	    (for-each 
+	     (lambda (targdb)
+	       (let* ((db                 (db:dbdat-get-db targdb))
+                      (drp-trigger        (if (member "last_update" field-names)
+					      (db:drop-trigger db tablename) 
+					      #f))
+                      (is-trigger-dropped (if (member "last_update" field-names)
+                                              (db:is-trigger-dropped db tablename)
+					      #f)) 
+		      (stmth  (sqlite3:prepare db full-ins)))
+		 ;; (db:delay-if-busy targdb) ;; NO WAITING
+                 (if (member "last_update" field-names)
+                     (debug:print-info 3 *default-log-port* "is-trigger-dropped: " is-trigger-dropped)) 
+		 (for-each
+		  (lambda (fromdat-lst)
+		    (sqlite3:with-transaction
+		     db
+		     (lambda ()
+		       (for-each ;; 
+			(lambda (fromrow)
+			  (let* ((a    (vector-ref fromrow 0))
+				 (curr (hash-table-ref/default todat a #f))
+				 (same #t))
+			    (let loop ((i 0))
+			      (if (or (not curr)
+				      (not (equal? (vector-ref fromrow i)(vector-ref curr i))))
+				  (set! same #f))
+			      (if (and same
+				       (< i (- num-fields 1)))
+				  (loop (+ i 1))))
+			    (if (not same)
+				(begin
+				  (apply sqlite3:execute stmth (vector->list fromrow))
+				  (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0)))))))
+			fromdat-lst))))
+		  fromdats)
+		 (sqlite3:finalize! stmth)
+                 (if (member "last_update" field-names)
+                    (db:create-trigger db tablename))))
+	     (append (list todb) slave-dbs))))
+	tbls)
+       (let* ((runtime      (- (current-milliseconds) start-time))
+	      (should-print (or (debug:debug-mode 12)
+				(common:low-noise-print 120 "db sync" (> runtime 500))))) ;; low and high sync times treated as separate.
+	 (if should-print (debug:print 3 *default-log-port* "INFO: db sync, total run time " runtime " ms"))
+	 (for-each 
+	  (lambda (dat)
+	    (let ((tblname (car dat))
+		  (count   (cdr dat)))
+	      (set! tot-count (+ tot-count count))
+	      (if (> count 0)  ;; concs are there to prevent "Error: (sprintf) illegal format-string character: #\1" which I don't understand.
+		  (if should-print (debug:print 0 *default-log-port* "    "(conc tblname)" "(conc count)))))) ;; ~10a ~5a"
+	  (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b))))))
+       tot-count))))
+
+(define db:trigger-list 
+     (list (list "update_runs_trigger"  "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs
+                             FOR EACH ROW
+                               BEGIN 
+                                 UPDATE runs SET last_update=(strftime('%s','now'))
+                                   WHERE id=old.id;
+                               END;" ) 
+	   (list "update_run_stats_trigger"  "CREATE TRIGGER  IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats
+                             FOR EACH ROW
+                               BEGIN 
+                                 UPDATE run_stats SET last_update=(strftime('%s','now'))
+                                   WHERE id=old.id;
+                               END;" )
+	   (list "update_tests_trigger"  "CREATE TRIGGER  IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests
+                             FOR EACH ROW
+                               BEGIN 
+                                 UPDATE tests SET last_update=(strftime('%s','now'))
+                                   WHERE id=old.id;
+                               END;" )
+	   (list "update_teststeps_trigger"  "CREATE TRIGGER  IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps
+                             FOR EACH ROW
+                               BEGIN 
+                                 UPDATE test_steps SET last_update=(strftime('%s','now'))
+                                   WHERE id=old.id;
+                               END;" )
+	   (list "update_test_data_trigger"  "CREATE TRIGGER  IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data
+                             FOR EACH ROW
+                               BEGIN 
+                                 UPDATE test_data SET last_update=(strftime('%s','now'))
+                                   WHERE id=old.id;
+                               END;" )))
+
+;; return #f to indicate the dbdat should be closed/reopened
+;; else return dbdat
+;;
+(define (db:repair-db dbdat #!key (numtries 1))
+  (let* ((dbpath   (db:dbdat-get-path        dbdat))
+	 (dbdir    (pathname-directory       dbpath))
+	 (fname    (pathname-strip-directory dbpath)))
+    (debug:print-info 0 *default-log-port* "Checking db " dbpath " for errors.")
+    (cond
+     ((not (file-write-access? dbdir))
+      (debug:print 0 *default-log-port* "WARNING: can't write to " dbdir ", can't fix " fname)
+      #f)
+
+     ;; handle special cases, megatest.db and monitor.db
+     ;; 
+     ;;  NOPE: apply this same approach to all db files
+     ;;
+     (else ;; ((equal? fname "megatest.db") ;; this file can be regenerated if needed
+      (handle-exceptions
+       exn
+       (begin
+	 (print "Problems trying to repair the db, exn=" exn)
+	 ;; (db:move-and-recreate-db dbdat)
+	 (if (> numtries 0)
+	     (db:repair-db dbdat numtries: (- numtries 1))
+	     #f)
+	 (debug:print 0 *default-log-port* "FATAL: file " dbpath " was found corrupted, an attempt to fix has been made but you must start over.")
+	 (debug:print 0 *default-log-port*
+		      "   check the following:\n"
+		      "      1. full directories, look in ~/ /tmp and " dbdir "\n"
+		      "      2. write access to " dbdir "\n\n"
+		      "   if the automatic recovery failed you may be able to recover data by doing \"" 
+		      (if (member fname '("megatest.db" "monitor.db"))
+			  "megatest -cleanup-db"
+			  "megatest -import-megatest.db;megatest -cleanup-db")
+		      "\"\n")
+	 (exit) ;; we can not safely continue when a db was corrupted - even if fixed.
+	 )
+       ;; test read/write access to the database
+       (let ((db (sqlite3:open-database dbpath)))
+	 (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
+	 (sqlite3:execute db "PRAGMA synchronous = 0;")
+	 (cond
+	  ((equal? fname "megatest.db")
+	   (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';"))
+	  ((equal? fname "main.db")
+	   (sqlite3:execute db "DELETE FROM runs WHERE state='deleted';"))
+	  ;; this was for the 1.db, 2.db ...
+	  #;((string-match "\\d.db" fname)
+	   (sqlite3:execute db "UPDATE tests SET state='DELETED' WHERE state='DELETED';"))
+	  ((equal? fname "monitor.db")
+	   (sqlite3:execute "DELETE FROM servers WHERE state LIKE 'defunct%';"))
+	  (else
+	   (sqlite3:execute db "vacuum;")))
+	 
+	 (sqlite3:finalize! db)
+	 #t))))))
+    
+
+;;======================================================================
+;; K E E P   F I L E D B   I N   dbstruct
+;;======================================================================
+
+;; (define (db:get-filedb dbstruct run-id)
+;;   (let ((db (vector-ref dbstruct 2)))
+;;     (if db
+;; 	db
+;; 	(let ((fdb (filedb:open-db (conc *toplevel* "/db/files.db"))))
+;; 	  (vector-set! dbstruct 2 fdb)
+;; 	  fdb))))
+;; 
+;; ;; Can also be used to save arbitrary strings
+;; ;;
+;; (define (db:save-path dbstruct path)
+;;   (let ((fdb (db:get-filedb dbstruct)))b
+;;     (filedb:register-path fdb path)))
+;; 
+;; ;; Use to get a path. To get an arbitrary string see next define
+;; ;;
+;; (define (db:get-path dbstruct id)
+;;   (let ((fdb (db:get-filedb dbstruct)))
+;;     (filedb:get-path db id)))
+
+;; NB// #f => return dbdir only
+;;      (was planned to be;  zeroth db with name=main.db)
+;; 
+;; If run-id is #f return to create and retrieve the path where the db will live.
+;;
+(define db:dbfile-path common:get-db-tmp-area)
+
+(define (db:set-sync db)
+  (let ((syncprag (configf:lookup *configdat* "setup" "sychronous")))
+    (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 0) ";")))) 
+
+
+;; db:lock-create-open
+
+
+
+
+(define (db:get-last-update-time db)
+;	(db:with-db
+;   dbstruct #f #f 
+;    (lambda (db)
+			(let ((last-update-time #f))
+      	(sqlite3:for-each-row 
+          (lambda (lup) 
+             (set! last-update-time lup))     
+          db    
+					"select max(lup) from ( select max(last_update) as lup  from tests union select max(last_update) as lup from runs);")
+        last-update-time))
+;))
+
+;; Make the dbstruct, setup up auxillary db's and call for main db at least once
+;;
+;; called in http-transport and replicated in rmt.scm for *local* access. 
+;;
+(define (db:setup do-sync #!key (areapath #f))
+  ;;
+  (cond
+   (*dbstruct-db* *dbstruct-db*);; TODO: when multiple areas are supported, this optimization will be a hazard
+   (else ;;(common:on-homehost?)
+    (debug:print-info 13 *default-log-port* "db:setup entered (first time, not cached.)")
+    (let* ((dbstruct (make-dbr:dbstruct)))
+      (assert *toppath* "ERROR: db:setup called without first calling launch:setup.")
+        ;;(debug:print-info 13 *default-log-port* "in db:setup, *toppath* not set; calling launch:setup")
+        ;; (launch:setup areapath: areapath))
+      (common:get-db-tmp-area)
+      (debug:print-info 13 *default-log-port* "Begin db:open-db")
+      (db:open-db dbstruct areapath: areapath do-sync: do-sync)
+      (debug:print-info 13 *default-log-port* "Done db:open-db")
+      (set! *dbstruct-db* dbstruct)
+      ;;(debug:print-info 13 *default-log-port* "new dbstruct = "(dbr:dbstruct->alist dbstruct))
+      dbstruct))))
+   ;; (else
+   ;;  (debug:print 0 *default-log-port* "ERROR: attempt to open database when not on homehost. Exiting. Homehost: " (common:get-homehost))
+   ;;  (exit 1))))
+
+;; sync run to disk if touched
+;;
+(define (db:sync-touched dbstruct run-id #!key (force-sync #f))
+  (let ((tmpdb   (db:get-db dbstruct))
+	(mtdb    (dbr:dbstruct-mtdb   dbstruct))
+        (refndb  (dbr:dbstruct-refndb dbstruct))
+	(start-t (current-seconds)))
+    (debug:print-info 4 *default-log-port* "Syncing for run-id: " run-id)
+    (mutex-lock! *db-multi-sync-mutex*)
+    (let ((update_info (cons (if force-sync 0 *db-last-sync*) "last_update")))
+      (mutex-unlock! *db-multi-sync-mutex*)
+      (db:sync-tables (db:sync-all-tables-list dbstruct) update_info tmpdb refndb mtdb))
+    (mutex-lock! *db-multi-sync-mutex*)
+    (set! *db-last-sync* start-t)
+    (set! *db-last-access* start-t)
+    (mutex-unlock! *db-multi-sync-mutex*)
+    (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb)))
+
+(define (db:safely-close-sqlite3-db db stmt-cache #!key (try-num 3))
+  (if (<= try-num 0)
+      #f
+      (handle-exceptions
+	  exn
+	(begin
+	  (print "Attempt to safely close sqlite3 db failed. Trying again. exn=" exn)
+	  (thread-sleep! 3)
+	  (sqlite3:interrupt! db)
+	  (db:safely-close-sqlite3-db db stmt-cache try-num: (- try-num 1)))
+	(if (sqlite3:database? db)
+	    (let* ((stmts (and stmt-cache (hash-table-ref/default stmt-cache db #f))))
+	      (if stmts (map sqlite3:finalize! (hash-table-values stmts)))
+	      (sqlite3:finalize! db)
+	      #t)
+	    #f))))
+
+;; close all opened run-id dbs
+(define (db:close-all dbstruct)
+  (if (dbr:dbstruct? dbstruct)
+      (handle-exceptions
+	  exn
+	  (begin
+	    (debug:print 0 *default-log-port* "WARNING: Finalizing failed, "  ((condition-property-accessor 'exn 'message) exn) ", note - exn=" exn)
+	    (print-call-chain *default-log-port*))
+	;; (db:sync-touched dbstruct 0 force-sync: #t) ;; NO. Do not do this here. Instead we rely on a server to be started when there are writes, even if the server itself is not going to be used as a server.
+        (let ((tdbs       (map db:dbdat-get-db 
+			       (stack->list (dbr:dbstruct-dbstack dbstruct))))
+              (mdb        (db:dbdat-get-db (dbr:dbstruct-mtdb   dbstruct)))
+              (rdb        (db:dbdat-get-db (dbr:dbstruct-refndb dbstruct)))
+	      (stmt-cache (dbr:dbstruct-stmt-cache dbstruct)))
+          (map (lambda (db)
+		 (db:safely-close-sqlite3-db db stmt-cache))
+	       tdbs)
+          (db:safely-close-sqlite3-db mdb stmt-cache)     ;; (if (sqlite3:database? mdb) (sqlite3:finalize! mdb))
+          (db:safely-close-sqlite3-db rdb stmt-cache))))) ;; (if (sqlite3:database? rdb) (sqlite3:finalize! rdb))))))
+
+;;   (let ((locdbs (dbr:dbstruct-locdbs dbstruct)))
+;;     (if (hash-table? locdbs)
+;; 	(for-each (lambda (run-id)
+;; 		    (db:close-run-db dbstruct run-id))
+;; 		  (hash-table-keys locdbs)))))
+
+;; (define (db:open-inmem-db)
+;;   (let* ((db      (sqlite3:open-database ":memory:"))
+;; 	 (handler (make-busy-timeout 3600)))
+;;     (sqlite3:set-busy-handler! db handler)
+;;     (db:initialize-run-id-db db)
+;;     (cons db #f)))
+
+;; use bunch of Unix commands to try to break the lock and recreate the db
+;;
+(define (db:move-and-recreate-db dbdat)
+  (let* ((dbpath   (db:dbdat-get-path        dbdat))
+	 (dbdir    (pathname-directory       dbpath))
+	 (fname    (pathname-strip-directory dbpath))
+	 (fnamejnl (conc fname "-journal"))
+	 (tmpname  (conc fname "." (current-process-id)))
+	 (tmpjnl   (conc fnamejnl "." (current-process-id))))
+    (debug:print-error 0 *default-log-port* "" fname " appears corrupted. Making backup \"old/" fname "\"")
+    (system (conc "cd " dbdir ";mkdir -p old;cat " fname " > old/" tmpname))
+    (system (conc "rm -f " dbpath))
+    (if (common:file-exists? fnamejnl)
+	(begin
+	  (debug:print-error 0 *default-log-port* "" fnamejnl " found, moving it to old dir as " tmpjnl)
+	  (system (conc "cd " dbdir ";mkdir -p old;cat " fnamejnl " > old/" tmpjnl))
+	  (system (conc "rm -f " dbdir "/" fnamejnl))))
+    ;; attempt to recreate database
+    (system (conc "cd " dbdir ";sqlite3 old/" tmpname " .dump | sqlite3 " fname))))
+    
+(define (db:patch-schema-rundb frundb)
+  ;;
+  ;; remove this some time after September 2016 (added in version v1.6031
+  ;;
+  (for-each
+   (lambda (table-name)
+     (handle-exceptions
+      exn
+      (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn))
+          (debug:print 0 *default-log-port* "Column last_update already added to " table-name " table")
+          (db:general-sqlite-error-dump exn "alter table " table-name " ..." #f "none"))
+      (sqlite3:execute
+       frundb
+       (conc "ALTER TABLE " table-name " ADD COLUMN last_update INTEGER DEFAULT 0")))
+     (sqlite3:execute
+      frundb
+      (conc "DROP TRIGGER IF EXISTS update_" table-name "_trigger;"))
+     (sqlite3:execute
+      frundb
+      (conc "CREATE TRIGGER IF NOT EXISTS update_" table-name "_trigger AFTER UPDATE ON " table-name "
+                             FOR EACH ROW
+                               BEGIN 
+                                 UPDATE " table-name " SET last_update=(strftime('%s','now'))
+                                   WHERE id=old.id;
+                               END;"))
+     )
+   '("tests" "test_steps" "test_data")))
+
+(define (db:patch-schema-maindb maindb)
+  ;;
+  ;; remove all these some time after september 2016 (added in v1.6031
+  ;;
+  (for-each
+   (lambda (column type default)
+     (handle-exceptions
+	 exn
+	 (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn))
+	     (debug:print 0 *default-log-port* "Column " column " already added to runs table")
+	     (db:general-sqlite-error-dump exn "alter table runs ..." #f "none"))
+       (sqlite3:execute
+	maindb
+	(conc "ALTER TABLE runs ADD COLUMN " column " " type " DEFAULT " default))))
+   (list "last_update" "contour")
+   (list "INTEGER"     "TEXT"   )
+   (list "0"           "''"   ))
+  ;; these schema changes don't need exception handling
+  (sqlite3:execute
+   maindb
+   "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs
+                             FOR EACH ROW
+                               BEGIN 
+                                 UPDATE runs SET last_update=(strftime('%s','now'))
+                                   WHERE id=old.id;
+                               END;")
+  (sqlite3:execute maindb "CREATE TABLE IF NOT EXISTS run_stats (
+                              id     INTEGER PRIMARY KEY,
+                              run_id INTEGER,
+                              state  TEXT,
+                              status TEXT,
+                              count  INTEGER,
+                              last_update INTEGER DEFAULT (strftime('%s','now')))")
+  (sqlite3:execute maindb "CREATE TRIGGER  IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats
+                             FOR EACH ROW
+                               BEGIN 
+                                 UPDATE run_stats SET last_update=(strftime('%s','now'))
+                                   WHERE id=old.id;
+                               END;")
+  (sqlite3:execute maindb "CREATE TABLE IF NOT EXISTS test_rundat (
+                              id           INTEGER PRIMARY KEY,
+                              test_id      INTEGER,
+                              update_time  TIMESTAMP,
+                              cpuload      INTEGER DEFAULT -1,
+                              diskfree     INTEGER DEFAULT -1,
+                              diskusage    INTGER DEFAULT -1,
+                              run_duration INTEGER DEFAULT 0);"))
+
+(define (db:adj-target db)
+  (let ((fields    (configf:get-section *configdat* "fields"))
+	(field-num 0))
+    ;; because we will be refreshing the keys table it is best to clear it here
+    (sqlite3:execute db "DELETE FROM keys;")
+    (for-each
+     (lambda (field)
+       (let ((column (car field))
+	     (spec   (cadr field)))
+	 (handle-exceptions
+	  exn
+	  (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn))
+	      (debug:print 0 *default-log-port* "Target field " column " already exists in the runs table")
+	      (db:general-sqlite-error-dump exn "alter table runs ..." #f "none"))
+	  ;; Add the column if needed
+	  (sqlite3:execute
+	   db
+	   (conc "ALTER TABLE runs ADD COLUMN " column " " spec)))
+	 ;; correct the entry in the keys column
+	 (sqlite3:execute
+	  db
+	  "INSERT INTO keys (id,fieldname,fieldtype) VALUES (?,?,?);"
+	  field-num column spec)
+	 ;; fill in blanks (not allowed as it would be part of the path
+	 (sqlite3:execute
+	  db
+	  (conc "UPDATE runs SET " column "='x' WHERE " column "='';"))
+	 (set! field-num (+ field-num 1))))
+     fields)))
+  
+(define *global-db-store* (make-hash-table))
+
+;; Add db direct
+;;
+(define (db:dispatch-query access-mode rmt-cmd db-cmd . params)
+  (if (eq? access-mode 'cached)
+      (debug:print 2 *default-log-port* "not doing cached calls right now"))
+;;      (apply db:call-with-cached-db db-cmd params)
+      (apply rmt-cmd params))
+;;)
+
+;; return the target db handle so it can be used
+;;
+(define (db:cache-for-read-only source target #!key (use-last-update #f))
+  (assert *toppath* "ERROR: db:cache-for-read-only called without calling launch:setup first.")
+  (if (and (hash-table-ref/default *global-db-store* target #f)
+	   (>= (file-modification-time target)(file-modification-time source)))
+      (hash-table-ref *global-db-store* target)
+      (let* ((toppath   *toppath*) ;; (launch:setup))
+	     (targ-db-last-mod (if (common:file-exists? target)
+				   (file-modification-time target)
+				   0))
+	     (cache-db  (or (hash-table-ref/default *global-db-store* target #f)
+			    (db:open-megatest-db path: target)))
+	     (source-db (db:open-megatest-db path: source))
+	     (curr-time (current-seconds))
+	     (res      '())
+	     (last-update (if use-last-update (cons "last_update" targ-db-last-mod) #f)))
+	(db:sync-tables (db:sync-main-list source-db) last-update source-db cache-db)
+	(db:sync-tables db:sync-tests-only last-update source-db cache-db)
+	(hash-table-set! *global-db-store* target cache-db)
+	cache-db)))
+
+;; ;; call a proc with a cached db
+;; ;;
+;; (define (db:call-with-cached-db proc . params)
+;;   ;; first cache the db in /tmp
+;;   (let* ((cname-part (conc "megatest_cache/" (common:get-testsuite-name)))
+;; 	 (fname      (conc  (common:get-area-path-signature) ".db"))
+;; 	 (cache-dir  (common:get-create-writeable-dir
+;; 		      (list (conc "/tmp/" (current-user-name) "/" cname-part)
+;; 			    (conc "/tmp/" (current-user-name) "-" cname-part)
+;; 			     (conc "/tmp/" (current-user-name) "_" cname-part))))
+;; 	 (megatest-db (conc *toppath* "/megatest.db")))
+;;     ;; (debug:print-info 0 *default-log-port* "Using cache dir " cache-dir)
+;;     (if (not cache-dir)
+;; 	(begin
+;; 	  (debug:print 0 *default-log-port* "ERROR: Failed to find an area to write the cache db")
+;; 	  (exit 1))
+;; 	(let* ((th1      (make-thread
+;; 			  (lambda ()
+;; 			    (if (and (common:file-exists? megatest-db)
+;; 				     (file-write-access? megatest-db))
+;; 				(begin
+;; 				  (db:sync-to-megatest.db dbstruct 'timestamps) ;; internally mutexes on *db-local-sync*
+;; 				  (debug:print-info 2 *default-log-port* "Done syncing to megatest.db"))))
+;; 			  "call-with-cached-db sync-to-megatest.db"))
+;; 	       (cache-db (db:cache-for-read-only
+;; 			  megatest-db
+;; 			  (conc cache-dir "/" fname)
+;; 			  use-last-update: #t)))
+;; 	  (thread-start! th1)
+;; 	  (apply proc cache-db params)
+;; 	  ))))
+
+(define (db:tmp->megatest.db-sync dbstruct last-update)
+  (let* ((mtdb        (dbr:dbstruct-mtdb dbstruct))
+	 (tmpdb       (db:get-db dbstruct))
+	 (refndb      (dbr:dbstruct-refndb dbstruct))
+	 (res         (db:sync-tables (db:sync-all-tables-list dbstruct) last-update tmpdb refndb mtdb)))
+    (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb)
+    res))
+
+;;;; run-ids
+;;    if #f use *db-local-sync* : or 'local-sync-flags
+;;    if #t use timestamps      : or 'timestamps
+;;
+;;  NB// no-sync-db is the db handle, not a flag!
+;;
+(define (db:sync-to-megatest.db dbstruct #!key (no-sync-db #f)) 
+  (let* ((start-time         (current-seconds))
+	 (last-full-update   (if no-sync-db
+				 (db:no-sync-get/default no-sync-db "LAST_FULL_UPDATE" 0)
+				 0))
+	 (full-sync-needed   (> (- start-time last-full-update) 3600)) ;; every hour do a full sync
+	 (last-update        (if full-sync-needed
+				 0
+				 (if no-sync-db
+				     (db:no-sync-get/default no-sync-db "LAST_UPDATE" 0)
+				     0))) ;; (or (db:get-var dbstruct "LAST_UPDATE") 0))
+	 (sync-needed        (> (- start-time last-update) 6))
+	 (res                (if (or sync-needed ;; don't sync if a sync already occurred in the past 6 seconds
+				     full-sync-needed)
+				 (begin
+				   (if no-sync-db
+				       (begin
+					 (if full-sync-needed (db:no-sync-set no-sync-db "LAST_FULL_UPDATE" start-time))
+					 (db:no-sync-set no-sync-db "LAST_UPDATE" start-time)))
+				   (db:tmp->megatest.db-sync dbstruct last-update))
+				 0))
+	 (sync-time           (- (current-seconds) start-time)))
+      (debug:print-info 3 *default-log-port* "Sync of newdb to olddb completed in " sync-time " seconds pid="(current-process-id))
+      (if (common:low-noise-print 30 "sync new to old")
+          (if sync-needed
+              (debug:print-info 0 *default-log-port* "Sync of " res " records from newdb to olddb completed in " sync-time " seconds pid="(current-process-id))
+              (debug:print-info 0 *default-log-port* "No sync needed, last updated " (- start-time last-update) " seconds ago")))
+      res))
+
+;; keeping it around for debugging purposes only
+#;(define (open-run-close-no-exception-handling  proc idb . params)
+  (debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params)
+  (print "I don't work anymore. open-run-close-no-exception-handling needs fixing or removing...")
+  (exit)
+  (if (or *db-write-access*
+	  (not #t)) ;; was: (member proc * db:all-write-procs *)))
+      (let* ((db (cond
+		  ((pair? idb)                 (db:dbdat-get-db idb))
+		  ((sqlite3:database? idb)     idb)
+		  ((not idb)                   (debug:print-error 0 *default-log-port* "cannot open-run-close with #f anymore"))
+		  ((procedure? idb)            (idb))
+		  (else   	               (debug:print-error 0 *default-log-port* "cannot open-run-close with #f anymore"))))
+	     (res #f))
+	(set! res (apply proc db params))
+	(if (not idb)(sqlite3:finalize! dbstruct))
+	(debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling END" )
+	res)
+      #f))
+
+#;(define (open-run-close-exception-handling proc idb . params)
+  (handle-exceptions
+   exn
+   (let ((sleep-time (random 30))
+	 (err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
+     (case err-status
+       ((busy)
+	(thread-sleep! sleep-time))
+       (else
+	(debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable.")
+	(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+	(debug:print 5 *default-log-port* "exn=" (condition->list exn))
+	(debug:print 0 *default-log-port* " status:  " ((condition-property-accessor 'sqlite3 'status) exn))
+	(print-call-chain (current-error-port))
+	(thread-sleep! sleep-time)
+	(debug:print-info 0 *default-log-port* "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up")))
+     (apply open-run-close-exception-handling proc idb params))
+   (apply open-run-close-no-exception-handling proc idb params)))
+
+;; (define open-run-close 
+#;(define open-run-close open-run-close-exception-handling)
+		;;	   open-run-close-no-exception-handling
+;;			   open-run-close-exception-handling)
+;;)
+
+;;======================================================================
+;; A R C H I V E S
+;;======================================================================
+
+;; dneeded is minimum space needed, scan for existing archives that 
+;; are on disks with adequate space and already have this test/itempath
+;; archived
+;;
+(define (db:archive-get-allocations dbstruct testname itempath dneeded)
+  (let* ((dbdat        (db:get-db dbstruct)) ;; archive tables are in main.db
+	 (db           (db:dbdat-get-db dbdat))
+	 (res          '())
+	 (blocks       '())) ;; a block is an archive chunck that can be added too if there is space
+    (sqlite3:for-each-row
+     (lambda (id archive-disk-id disk-path last-du last-du-time)
+       (set! res (cons (vector id archive-disk-id disk-path last-du last-du-time) res)))
+     db
+     "SELECT b.id,b.archive_disk_id,b.disk_path,b.last_du,b.last_du_time FROM archive_blocks AS b
+        INNER JOIN archive_allocations AS a ON a.archive_block_id=b.id
+        WHERE a.testname=? AND a.item_path=?;" 
+     testname itempath)
+    ;; Now res has list of candidate paths, look in archive_disks for candidate with potential free space
+    (if (null? res)
+	'()
+	(sqlite3:for-each-row
+	 (lambda (id archive-area-name disk-path last-df last-df-time)
+	   (set! blocks (cons (vector id archive-area-name disk-path last-df last-df-time) blocks)))
+	 db 
+	 (conc
+	  "SELECT d.id,d.archive_area_name,disk_path,last_df,last_df_time FROM archive_disks AS d
+             INNER JOIN archive_blocks AS b ON d.id=b.archive_disk_id
+             WHERE b.id IN (" (string-intersperse (map conc res) ",") ") AND
+         last_df > ?;")
+	 dneeded))
+    (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)
+    blocks))
+    
+;; returns id of the record, register a disk allocated to archiving and record it's last known
+;; available space
+;;
+(define (db:archive-register-disk dbstruct bdisk-name bdisk-path df)
+  (let* ((dbdat        (db:get-db dbstruct)) ;; archive tables are in main.db
+	 (db           (db:dbdat-get-db dbdat))
+	 (res          #f))
+    (sqlite3:for-each-row
+     (lambda (id)
+       (set! res id))
+     db
+     "SELECT id FROM archive_disks WHERE archive_area_name=? AND disk_path=?;"
+     bdisk-name bdisk-path)
+    (if res ;; record exists, update df and return id
+	(begin
+	  (sqlite3:execute db "UPDATE archive_disks SET last_df=?,last_df_time=(strftime('%s','now'))
+                                  WHERE archive_area_name=? AND disk_path=?;"
+			   df bdisk-name bdisk-path)
+          (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)
+	  res)
+	(begin
+	  (sqlite3:execute
+	   db
+	   "INSERT OR REPLACE INTO archive_disks (archive_area_name,disk_path,last_df)
+                VALUES (?,?,?);"
+	   bdisk-name bdisk-path df)
+          (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)
+	  (db:archive-register-disk dbstruct bdisk-name bdisk-path df)))))
+
+;; record an archive path created on a given archive disk (identified by it's bdisk-id)
+;; if path starts with / then it is full, otherwise it is relative to the archive disk
+;; preference is to store the relative path.
+;;
+(define (db:archive-register-block-name dbstruct bdisk-id archive-path #!key (du #f))
+  (let* ((dbdat        (db:get-db dbstruct)) ;; archive tables are in main.db
+	 (db           (db:dbdat-get-db dbdat))
+	 (res          #f))
+    ;; first look to see if this path is already registered
+    (sqlite3:for-each-row
+     (lambda (id)
+       (set! res id))
+     db
+     "SELECT id FROM archive_blocks WHERE archive_disk_id=? AND disk_path=?;"
+     bdisk-id archive-path)
+    (if res ;; record exists, update du if applicable and return res
+	(if du (sqlite3:execute db "UPDATE archive_blocks SET last_du=?,last_du_time=(strftime('%s','now'))
+                                          WHERE archive_disk_id=? AND disk_path=?;"
+				bdisk-id archive-path du))
+	(begin
+	  (sqlite3:execute db "INSERT OR REPLACE INTO archive_blocks (archive_disk_id,disk_path,last_du)
+                                                        VALUES (?,?,?);"
+			   bdisk-id archive-path (or du 0))
+	  (set! res (db:archive-register-block-name dbstruct bdisk-id archive-path du: du))))
+    (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)
+    res))
+
+
+;; The "archived" field in tests is overloaded; 0 = not archived, > 0 archived in block with given id
+;;
+(define (db:test-set-archive-block-id dbstruct run-id test-id archive-block-id)
+  (db:with-db
+   dbstruct
+   run-id
+   #f
+   (lambda (db)
+     (sqlite3:execute db "UPDATE tests SET archived=? WHERE id=?;"
+		      archive-block-id test-id))))
+ 
+;; Look up the archive block info given a block-id
+;;
+(define (db:test-get-archive-block-info dbstruct archive-block-id)
+  (db:with-db
+   dbstruct
+   #f
+   #f
+   (lambda (db)
+     (let ((res #f))
+       (sqlite3:for-each-row 
+	;;        0         1           2        3          4           5
+	(lambda (id archive-disk-id disk-path last-du last-du-time creation-time)
+	  (set! res (vector id archive-disk-id disk-path last-du last-du-time creation-time)))
+	db
+	"SELECT id,archive_disk_id,disk_path,last_du,last_du_time,creation_time FROM archive_blocks WHERE id=?;"
+	archive-block-id)
+       res))))
+
+;; (define (db:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey)
+;;   (let* ((dbdat        (db:get-db dbstruct #f)) ;; archive tables are in main.db
+;; 	 (db           (db:dbdat-get-db dbdat))
+;; 	 (res          '())
+;; 	 (blocks       '())) ;; a block is an archive chunck that can be added too if there is space
+;;     (sqlite3:for-each-row  #f)
+
+;;======================================================================
+;; L O G G I N G    D B 
+;;======================================================================
+
+#;(define (open-logging-db)
+  (let* ((dbpath    (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname)
+	 (dbexists  (common:file-exists? dbpath))
+	 (db        (sqlite3:open-database dbpath))
+	 (handler   (sqlite3:make-busy-timeout (if (args:get-arg "-override-timeout")
+					   (string->number (args:get-arg "-override-timeout"))
+					   136000)))) ;; 136000)))
+    (sqlite3:set-busy-handler! db handler)
+    (if (not dbexists)
+	(begin
+	  (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log (id INTEGER PRIMARY KEY,event_time TIMESTAMP DEFAULT (strftime('%s','now')),logline TEXT,pwd TEXT,cmdline TEXT,pid INTEGER);")
+	  (db:set-sync db) ;; (sqlite3:execute db (conc "PRAGMA synchronous = 0;"))
+	  ))
+    db))
+
+#;(define (db:log-local-event . loglst)
+  (let ((logline (apply conc loglst)))
+    (db:log-event logline)))
+
+#;(define (db:log-event logline)
+  (let ((db (open-logging-db)))
+    (sqlite3:execute db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);"
+		     logline
+		     (current-directory)
+		     (string-intersperse (argv) " ")
+		     (current-process-id))
+    (sqlite3:finalize! db)
+    logline))
+
+;;======================================================================
+;; D B   U T I L S
+;;======================================================================
+
+;;======================================================================
+;; M A I N T E N A N C E
+;;======================================================================
+
+(define (db:have-incompletes? dbstruct run-id ovr-deadtime)
+  (let* ((incompleted '())
+	 (oldlaunched '())
+	 (toplevels   '())
+	 (deadtime-str (configf:lookup *configdat* "setup" "deadtime"))
+	 (deadtime     (if (and deadtime-str
+				(string->number deadtime-str))
+			   (string->number deadtime-str)
+			   72000))) ;; twenty hours
+    (db:with-db
+     dbstruct #f #f
+     (lambda (db)
+       (if (number? ovr-deadtime)(set! deadtime ovr-deadtime))
+       
+       ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes
+       ;;
+       ;; HOWEVER: this code in run:test seems to work fine
+       ;;              (> (- (current-seconds)(+ (db:test-get-event_time testdat)
+       ;;                     (db:test-get-run_duration testdat)))
+       ;;                    600) 
+       ;; (db:delay-if-busy dbdat)
+       (sqlite3:for-each-row 
+        (lambda (test-id run-dir uname testname item-path)
+          (if (and (equal? uname "n/a")
+                   (equal? item-path "")) ;; this is a toplevel test
+              ;; what to do with toplevel? call rollup?
+              (begin
+                (set! toplevels   (cons (list test-id run-dir uname testname item-path run-id) toplevels))
+                (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id))
+              (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted))))
+        db
+        "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');"
+        run-id deadtime)
+
+       ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config
+       ;;
+       ;; (db:delay-if-busy dbdat)
+       (sqlite3:for-each-row
+        (lambda (test-id run-dir uname testname item-path)
+          (if (and (equal? uname "n/a")
+                   (equal? item-path "")) ;; this is a toplevel test
+              ;; what to do with toplevel? call rollup?
+              (set! toplevels   (cons (list test-id run-dir uname testname item-path run-id) toplevels))
+              (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched))))
+        db
+        "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');"
+        run-id)
+       
+       (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.")
+       (if (and (null? incompleted)
+                (null? oldlaunched)
+                (null? toplevels))
+           #f
+           #t)))))
+
+(define (db:get-status-from-final-status-file run-dir)
+  (let ((infile (conc run-dir "/.final-status")))
+    ;; first verify we are able to write the output file
+    (if (not (file-read-access? infile))
+        (begin 
+	  (debug:print 0 *default-log-port* "ERROR: cannot read " infile)
+          (debug:print 0 *default-log-port* "ERROR: run-dir is " run-dir)
+          #f
+          )
+        (with-input-from-file infile read-lines)
+	)))
+
+;;  select end_time-now from
+;;      (select testname,item_path,event_time+run_duration as
+;;                          end_time,strftime('%s','now') as now from tests where state in
+;;      ('RUNNING','REMOTEHOSTSTART','LAUNCHED'));
+
+;; BUG: Probably broken - does not explicitly use run-id in the query
+;;
+(define (db:top-test-set-per-pf-counts dbstruct run-id test-name)
+  (db:general-call dbstruct 'top-test-set-per-pf-counts (list test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name)))
+
+;; Clean out old junk and vacuum the database
+;;
+;; Ultimately do something like this:
+;;
+;; 1. Look at test records either deleted or part of deleted run:
+;;    a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown'
+;;    b. If test dir gone, delete the test record
+;; 2. Look at run records
+;;    a. If have tests that are not deleted, set state='unknown'
+;;    b. ....
+;;
+(define (db:clean-up dbdat)
+  ;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db")
+  (let* ((keep-record-age ( - (current-seconds) (common:hms-string->seconds (or (configf:lookup *configdat* "setup" "delete-record-age") "30d"))))
+	 (db         (db:dbdat-get-db dbdat))
+	 (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);"))
+	(statements
+	 (map (lambda (stmt)
+		(sqlite3:prepare db stmt))
+	      (list
+	       ;; delete all tests that belong to runs that are 'deleted'
+	       (conc "DELETE FROM tests WHERE run_id in (SELECT id FROM runs WHERE state='deleted') and last_update < " keep-record-age ";")
+	       ;; delete all tests that are 'DELETED'
+	       (conc "DELETE FROM tests WHERE state='DELETED' and last_update < " keep-record-age " ;")
+	       ;; delete all tests that have no run
+	       (conc "DELETE FROM tests WHERE run_id NOT IN (SELECT DISTINCT id FROM runs) and last_update < " keep-record-age "; ")
+	       ;; delete all runs that are state='deleted'
+	       (conc "DELETE FROM runs WHERE state='deleted' and last_update < " keep-record-age ";")
+	       ;; delete empty runs
+	       (conc "DELETE FROM runs WHERE id NOT IN (SELECT DISTINCT r.id FROM runs AS r INNER JOIN tests AS t ON t.run_id=r.id) and last_update < " keep-record-age ";")
+	       ;; remove orphaned test_rundat entries
+	       (conc "DELETE FROM test_rundat where test_id NOT IN (SELECT id FROM tests);")
+	       ;; remove orphaned test_steps entries
+	       (conc "DELETE FROM test_steps WHERE test_id NOT IN (SELECT id FROM tests);")
+               ;; remove orphaned test_dat entries
+	       (conc "DELETE FROM test_data WHERE test_id NOT IN (SELECT id FROM tests);")
+
+	       ))))
+    ;; (db:delay-if-busy dbdat)
+    ;(debug:print-info 0 *default-log-port*  statements) 
+    (sqlite3:with-transaction 
+     db
+     (lambda ()
+       (sqlite3:for-each-row (lambda (tot)
+			       (debug:print-info 0 *default-log-port* "Records count before clean: " tot))
+			     count-stmt)
+       (map sqlite3:execute statements)
+       (sqlite3:for-each-row (lambda (tot)
+			       (debug:print-info 0 *default-log-port* "Records count after  clean: " tot))
+			     count-stmt)))
+    (map sqlite3:finalize! statements)
+    (sqlite3:finalize! count-stmt)
+    ;; (db:find-and-mark-incomplete db)
+    ;; (db:delay-if-busy dbdat)
+    (sqlite3:execute db "VACUUM;")))
+
+;; Clean out old junk and vacuum the database
+;;
+;; Ultimately do something like this:
+;;
+;; 1. Look at test records either deleted or part of deleted run:
+;;    a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown'
+;;    b. If test dir gone, delete the test record
+;; 2. Look at run records
+;;    a. If have tests that are not deleted, set state='unknown'
+;;    b. ....
+;;
+(define (db:clean-up-rundb dbdat)
+  ;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db")
+  (let* ((db         (db:dbdat-get-db dbdat))
+	 (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests);"))
+	(statements
+	 (map (lambda (stmt)
+		(sqlite3:prepare db stmt))
+	      (list
+	       ;; delete all tests that belong to runs that are 'deleted'
+	       ;; (conc "DELETE FROM tests WHERE run_id NOT IN (" (string-intersperse (map conc valid-runs) ",") ");")
+	       ;; delete all tests that are 'DELETED'
+	       "DELETE FROM tests WHERE state='DELETED';"
+	       ))))
+    ;; (db:delay-if-busy dbdat)
+    (sqlite3:with-transaction 
+     db
+     (lambda ()
+       (sqlite3:for-each-row (lambda (tot)
+			       (debug:print-info 0 *default-log-port* "Records count before clean: " tot))
+			     count-stmt)
+       (map sqlite3:execute statements)
+       (sqlite3:for-each-row (lambda (tot)
+			       (debug:print-info 0 *default-log-port* "Records count after  clean: " tot))
+			     count-stmt)))
+    (map sqlite3:finalize! statements)
+    (sqlite3:finalize! count-stmt)
+    ;; (db:find-and-mark-incomplete db)
+    ;; (db:delay-if-busy dbdat)
+    (sqlite3:execute db "VACUUM;")))
+
+;; Clean out old junk and vacuum the database
+;;
+;; Ultimately do something like this:
+;;
+;; 1. Look at test records either deleted or part of deleted run:
+;;    a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown'
+;;    b. If test dir gone, delete the test record
+;; 2. Look at run records
+;;    a. If have tests that are not deleted, set state='unknown'
+;;    b. ....
+;;
+(define (db:clean-up-maindb dbdat)
+  ;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db")
+  (let* ((db         (db:dbdat-get-db dbdat))
+	 (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM runs);"))
+	 (statements
+	  (map (lambda (stmt)
+		 (sqlite3:prepare db stmt))
+	       (list
+		;; delete all tests that belong to runs that are 'deleted'
+		;; (conc "DELETE FROM tests WHERE run_id NOT IN (" (string-intersperse (map conc valid-runs) ",") ");")
+		;; delete all tests that are 'DELETED'
+		"DELETE FROM runs WHERE state='deleted';"
+		)))
+	 (dead-runs '()))
+    (sqlite3:for-each-row
+     (lambda (run-id)
+       (set! dead-runs (cons run-id dead-runs)))
+       db
+       "SELECT id FROM runs WHERE state='deleted';")
+    ;; (db:delay-if-busy dbdat)
+    (sqlite3:with-transaction 
+     db
+     (lambda ()
+       (sqlite3:for-each-row (lambda (tot)
+			       (debug:print-info 0 *default-log-port* "Records count before clean: " tot))
+			     count-stmt)
+       (map sqlite3:execute statements)
+       (sqlite3:for-each-row (lambda (tot)
+			       (debug:print-info 0 *default-log-port* "Records count after  clean: " tot))
+			     count-stmt)))
+    (map sqlite3:finalize! statements)
+    (sqlite3:finalize! count-stmt)
+    ;; (db:find-and-mark-incomplete db)
+    ;; (db:delay-if-busy dbdat)
+    (sqlite3:execute db "VACUUM;")
+    dead-runs))
+
+;;======================================================================
+;; M E T A   G E T   A N D   S E T   V A R S
+;;======================================================================
+
+;; returns number if string->number is successful, string otherwise
+;; also updates *global-delta*
+;;
+(define (db:get-var dbstruct var)
+  (let* ((res      #f))
+    (db:with-db
+     dbstruct #f #f
+     (lambda (db)
+       (sqlite3:for-each-row
+        (lambda (val)
+          (set! res val))
+        db
+        "SELECT val FROM metadat WHERE var=?;" var)
+       ;; convert to number if can
+       (if (string? res)
+           (let ((valnum (string->number res)))
+             (if valnum (set! res valnum))))
+       res))))
+
+(define (db:inc-var dbstruct var)
+  (db:with-db dbstruct #f #t 
+	      (lambda (db)
+		(sqlite3:execute db "UPDATE metadat SET val=val+1 WHERE var=?;" var))))
+
+(define (db:dec-var dbstruct var)
+  (db:with-db dbstruct #f #t 
+	      (lambda (db)
+		(sqlite3:execute db "UPDATE metadat SET val=val-1 WHERE var=?;" var))))
+
+;; This was part of db:get-var. It was used to estimate the load on
+;; the database files.
+;;
+;; scale by 10, average with current value.
+;;     (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms)
+;; 						 (if throttle throttle 0.01)))
+;; 			    2))
+;;     (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit
+;; 	(begin
+;; 	  (debug:print-info 4 *default-log-port* "launch throttle factor=" *global-delta*)
+;; 	  (set! *last-global-delta-printed* *global-delta*)))
+
+(define (db:set-var dbstruct var val)
+  (db:with-db dbstruct #f #t 
+	      (lambda (db)
+		(sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val))))
+
+(define (db:add-var dbstruct var val)
+  (db:with-db dbstruct #f #t 
+	      (lambda (db)
+		(sqlite3:execute db "UPDATE metadat SET val=val+? WHERE var=?;" val var))))
+
+(define (db:del-var dbstruct var)
+  (db:with-db dbstruct #f #t 
+	      (lambda (db)
+		(sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var))))
+
+;;======================================================================
+;; no-sync.db - small bits of data to be shared between servers
+;;======================================================================
+
+(define (db:open-no-sync-db)
+  (let* ((dbpath (db:dbfile-path))
+	 (dbname (conc dbpath "/no-sync.db"))
+	 (db-exists (common:file-exists? dbname))
+	 (db     (sqlite3:open-database dbname)))
+    (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
+    (if (not db-exists)
+	(begin
+	  (sqlite3:execute db "PRAGMA synchronous = 0;")
+	  (sqlite3:execute db "CREATE TABLE IF NOT EXISTS no_sync_metadat (var TEXT,val TEXT, CONSTRAINT no_sync_metadat_constraint UNIQUE (var));")
+	  (sqlite3:execute db "PRAGMA journal_mode=WAL;")))
+    db))
+
+;; if we are not a server create a db handle. this is not finalized
+;; so watch for problems. I'm still not clear if it is needed to manually
+;; finalize sqlite3 dbs with the sqlite3 egg.
+;;
+(define (db:no-sync-db db-in)
+  (mutex-lock! *db-access-mutex*)
+  (let ((res (if db-in
+                 db-in
+                 (let ((db (db:open-no-sync-db)))
+                   (set! *no-sync-db* db)
+                   db))))
+    (mutex-unlock! *db-access-mutex*)
+    res))
+
+(define (db:no-sync-set db var val)
+  (sqlite3:execute (db:no-sync-db db) "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES (?,?);" var val))
+
+(define (db:no-sync-del! db var)
+  (sqlite3:execute (db:no-sync-db db) "DELETE FROM no_sync_metadat WHERE var=?;" var))
+
+(define (db:no-sync-get/default db var default)
+  (let ((res default))
+    (sqlite3:for-each-row
+     (lambda (val)
+       (set! res val))
+     (db:no-sync-db db)
+     "SELECT val FROM no_sync_metadat WHERE var=?;"
+     var)
+    (if res
+        (let ((newres (if (string? res)
+			  (string->number res)
+			  #f)))
+          (if newres
+              newres
+              res))
+        res)))
+
+(define (db:no-sync-close-db db stmt-cache)
+  (db:safely-close-sqlite3-db db stmt-cache))
+
+;; transaction protected lock aquisition
+;; either:
+;;    fails    returns  (#f . lock-creation-time)
+;;    succeeds (returns (#t . lock-creation-time)
+;; use (db:no-sync-del! db keyname) to release the lock
+;;
+(define (db:no-sync-get-lock db-in keyname)
+  (let ((db (db:no-sync-db db-in)))
+    (sqlite3:with-transaction
+     db
+     (lambda ()
+       (handle-exceptions
+	   exn
+	   (let ((lock-time (current-seconds)))
+	     (debug:print-info 2 *default-log-port* "db:no-sync-get-lock keyname=" keyname ", lock-time=" lock-time ", exn=" exn)
+	     (sqlite3:execute db "INSERT INTO no_sync_metadat (var,val) VALUES(?,?);" keyname lock-time)
+	     `(#t . ,lock-time))
+	 `(#f . ,(sqlite3:first-result db "SELECT val FROM no_sync_metadat WHERE var=?;" keyname)))))))
+
+;; use a global for some primitive caching, it is just silly to
+;; re-read the db over and over again for the keys since they never
+;; change
+
+;; why get the keys from the db? why not get from the *configdat*
+;; using keys:config-get-fields?
+
+(define (db:get-keys dbstruct)
+  (if *db-keys* *db-keys* 
+      (let ((res '()))
+	(db:with-db dbstruct #f #f
+		    (lambda (db)
+		      (sqlite3:for-each-row 
+		       (lambda (key)
+			 (set! res (cons key res)))
+		       db
+		       "SELECT fieldname FROM keys ORDER BY id DESC;")))
+	(set! *db-keys* res)
+	res)))
+
+;; extract index number given a header/data structure
+(define (db:get-index-by-header header field)
+  (list-index (lambda (x)(equal? x field)) header))
+
+;; look up values in a header/data structure
+(define (db:get-value-by-header row header field)
+  (if (or (null? header) (not row))
+      #f
+      (let loop ((hed (car header))
+                 (tal (cdr header))
+                 (n   0))
+        (if (equal? hed field)
+            (handle-exceptions
+             exn
+             (begin
+               (debug:print 0 *default-log-port* "WARNING: attempt to read non-existant field, row="
+			    row " header=" header " field=" field ", exn=" exn)
+               #f)
+             (vector-ref row n))
+	    (if (null? tal) #f (loop (car tal)(cdr tal)(+ n 1)))))))
+
+;; Accessors for the header/data structure
+;; get rows and header from 
+(define (db:get-header vec)(vector-ref vec 0))
+(define (db:get-rows   vec)(vector-ref vec 1))
+
+;;======================================================================
+;;  R U N S
+;;======================================================================
+
+
+
+
+
+(define (db:get-run-times dbstruct run-patt target-patt)
+(let ((res `())
+           (qry 	(conc "select runname, (max(end_time)-min(event_time))/60 as runtime, target from (select runname, run_id,tests.event_time,tests.event_time+run_duration AS end_time, " (string-join (db:get-keys dbstruct) " || '/' || ") " as target from tests inner join runs on tests.run_id = runs.id where runs.runname like ? and target like ?) group by run_id ;")))
+;(print qry)
+(db:with-db 
+   dbstruct
+   #f ;; this is for the main runs db
+   #f ;; does not modify db
+   (lambda (db)
+            (sqlite3:for-each-row
+	(lambda (runname runtime target )
+	  (set! res (cons (vector runname runtime target) res)))
+	db
+        qry 
+	run-patt target-patt)
+       
+       res))))
+
+
+
+(define (db:get-run-name-from-id dbstruct run-id)
+  (db:with-db 
+   dbstruct
+   #f ;; this is for the main runs db
+   #f ;; does not modify db
+   (lambda (db)
+     (let ((res #f))
+       (sqlite3:for-each-row
+	(lambda (runname)
+	  (set! res runname))
+	db
+	"SELECT runname FROM runs WHERE id=?;"
+	run-id)
+       res))))
+
+(define (db:get-run-key-val dbstruct run-id key)
+  (db:with-db
+   dbstruct
+   #f
+   #f
+   (lambda (db)
+     (let ((res #f))
+       (sqlite3:for-each-row
+	(lambda (val)
+	  (set! res val))
+	db
+	(conc "SELECT " key " FROM runs WHERE id=?;")
+	run-id)
+       res))))
+
+;; keys list to key1,key2,key3 ...
+(define (runs:get-std-run-fields keys remfields)
+  (let* ((header    (append keys remfields))
+	 (keystr    (conc (keys->keystr keys) ","
+			  (string-intersperse remfields ","))))
+    (list keystr header)))
+
+
+;; register a test run with the db, this accesses the main.db and does NOT
+;; use server api
+;;
+(define (db:register-run dbstruct keyvals runname state status user contour-in)
+  (let* ((keys      (map car keyvals))
+	 (keystr    (keys->keystr keys))
+	 (contour   (or contour-in ""))  ;; empty string to force no hierarcy and be backwards compatible.
+	 (comma     (if (> (length keys) 0) "," ""))
+	 (andstr    (if (> (length keys) 0) " AND " ""))
+	 (valslots  (keys->valslots keys)) ;; ?,?,? ...
+	 (allvals   (append (list runname state status user contour) (map cadr keyvals)))
+	 (qryvals   (append (list runname) (map cadr keyvals)))
+	 (key=?str  (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND ")))
+    (debug:print 3 *default-log-port* "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str)
+    (debug:print 2 *default-log-port* "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run")
+    (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and"
+	(db:with-db
+	 dbstruct #f #f
+	 (lambda (db)
+	   (let ((res #f))
+	     (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time,contour" comma keystr ") VALUES (?,?,?,?,strftime('%s','now'),?" comma valslots ");")
+		    allvals)
+	     (apply sqlite3:for-each-row 
+		    (lambda (id)
+		      (set! res id))
+		    db
+		    (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");")))
+		      qry)
+		    qryvals)
+	     (sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res)
+	     res))) 
+	(begin
+	  (debug:print-error 0 *default-log-port* "Called without all necessary keys")
+	  #f))))
+
+;; replace header and keystr with a call to runs:get-std-run-fields
+;;
+;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
+;; runpatts: patt1,patt2 ...
+;;
+(define (db:get-runs dbstruct runpatt count offset keypatts)
+  (let* ((res       '())
+	 (keys       (db:get-keys dbstruct))
+	 (runpattstr (db:patt->like "runname" runpatt))
+	 (remfields  (list "id" "runname" "state" "status" "owner" "event_time"))
+	 (header     (append keys remfields))
+	 (keystr     (conc (keys->keystr keys) ","
+			   (string-intersperse remfields ",")))
+	 (qrystr     (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? "
+			   ;; Generate: " AND x LIKE 'keypatt' ..."
+			   (if (null? keypatts) ""
+			       (conc " AND "
+				     (string-join 
+				      (map (lambda (keypatt)
+					     (let ((key  (car keypatt))
+						   (patt (cadr keypatt)))
+					       (db:patt->like key patt)))
+					   keypatts)
+				      " AND ")))
+			   " AND state != 'deleted' ORDER BY event_time DESC "
+			   (if (number? count)
+			       (conc " LIMIT " count)
+			       "")
+			   (if (number? offset)
+			       (conc " OFFSET " offset)
+			       ""))))
+    (debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count)
+    (db:with-db dbstruct #f #f
+		(lambda (db)		
+		  (sqlite3:for-each-row
+		   (lambda (a . x)
+		     (set! res (cons (apply vector a x) res)))
+		   db
+		   qrystr
+		   )))
+    (debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count)
+    (vector header res)))
+
+
+(define-record simple-run target id runname state status owner event_time)
+(define-record-printer (simple-run x out)
+  (fprintf out "#,(simple-run ~S ~S ~S ~S)"
+	   (simple-run-target x) (simple-run-id x) (simple-run-runname x) (time->string (seconds->local-time (simple-run-event_time x) ))))
+
+;; simple get-runs
+;;
+(define (db:simple-get-runs dbstruct runpatt count offset target last-update)
+    (let* ((res       '())
+	   (keys       (db:get-keys dbstruct))
+	   (runpattstr (db:patt->like "runname" runpatt))
+	   (remfields  (list "id" "runname" "state" "status" "owner" "event_time"))
+	   (targstr    (string-intersperse keys "||'/'||"))
+	   (keystr     (conc targstr " AS target,"
+			     (string-intersperse remfields ",")))
+	   (qrystr     (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? "
+			     ;; Generate: " AND x LIKE 'keypatt' ..."
+			     " AND target LIKE '" target "'"
+			     " AND state != 'deleted' "
+			     (if (number? last-update)
+				 (conc " AND last_update >= " last-update)
+				 "")
+			     " ORDER BY event_time DESC "
+			     (if (number? count)
+				 (conc " LIMIT " count)
+				 "")
+			     (if (number? offset)
+				 (conc " OFFSET " offset)
+				 "")))
+	   )
+    (debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " target: " target " offset: " offset " limit: " count)
+    (db:with-db dbstruct #f #f
+		(lambda (db)		
+		  (sqlite3:for-each-row
+		   (lambda (target id runname state status owner event_time)
+		     (set! res (cons (make-simple-run target id runname state status owner event_time) res)))
+		   db
+		   qrystr
+		   )))
+    (debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " target: " target " offset: " offset " limit: " count)
+    res))
+
+;; TODO: Switch this to use max(update_time) from each run db? Then if using a server there is no disk traffic (using inmem db)
+;;
+(define (db:get-changed-run-ids since-time)
+  (let* ((dbdir      (db:dbfile-path)) ;; (configf:lookup *configdat* "setup" "dbdir"))
+	 (alldbs     (glob (conc dbdir "/[0-9]*.db")))
+	 (changed    (filter (lambda (dbfile)
+			       (> (file-modification-time dbfile) since-time))
+			     alldbs)))
+    (delete-duplicates
+     (map (lambda (dbfile)
+	    (let* ((res (string-match ".*\\/(\\d)*\\.db" dbfile)))
+	      (if res
+		  (string->number (cadr res))
+		  (begin
+		    (debug:print 2 *default-log-port* "WARNING: Failed to process " dbfile " for run-id")
+		    0))))
+	  changed))))
+
+;; Get all targets from the db
+;;
+(define (db:get-targets dbstruct)
+  (let* ((res       '())
+	 (keys       (db:get-keys dbstruct))
+	 (header     keys) ;; (map key:get-fieldname keys))
+	 (keystr     (keys->keystr keys))
+	 (qrystr     (conc "SELECT " keystr " FROM runs WHERE state != 'deleted';"))
+	 (seen       (make-hash-table)))
+    (db:with-db
+     dbstruct
+     #f
+     #f
+     (lambda (db)
+       (sqlite3:for-each-row
+	(lambda (a . x)
+	  (let ((targ (cons a x)))
+	    (if (not (hash-table-ref/default seen targ #f))
+		(begin
+		  (hash-table-set! seen targ #t)
+		  (set! res (cons (apply vector targ) res))))))
+	db
+	qrystr)
+       (debug:print-info 11 *default-log-port* "db:get-targets END qrystr: " qrystr )
+       (vector header res)))))
+
+;; just get count of runs
+(define (db:get-num-runs dbstruct runpatt)
+  (db:with-db
+   dbstruct
+   #f
+   #f
+   (lambda (db)
+     (let ((numruns 0))
+       (debug:print-info 11 *default-log-port* "db:get-num-runs START " runpatt)
+       (sqlite3:for-each-row 
+	(lambda (count)
+	  (set! numruns count))
+	db
+	"SELECT COUNT(id) FROM runs WHERE runname LIKE ? AND state != 'deleted';" runpatt)
+       (debug:print-info 11 *default-log-port* "db:get-num-runs END " runpatt)
+       numruns))))
+
+;; just get count of runs
+(define (db:get-runs-cnt-by-patt dbstruct runpatt targetpatt keys)
+  (db:with-db
+   dbstruct
+   #f
+   #f
+   (lambda (db)
+     (let ((numruns 0)
+           (qry-str #f)
+           (key-patt "")
+	     	   (keyvals  (if targetpatt (keys:target->keyval keys targetpatt) '())))
+     
+    (for-each (lambda (keyval)
+		(let* ((key    (car keyval))
+		       (patt   (cadr keyval))
+		       (fulkey (conc ":" key))
+		       (wildtype (if (substring-index "%" patt) "like" "glob")))
+         
+		  (if patt
+		      (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'"))
+		      (begin
+			(debug:print-error 0 *default-log-port* "searching for runs with no pattern set for " fulkey)
+			(exit 6)))))
+	      keyvals)
+    ;(print  runpatt " -- " key-patt)
+    (set! qry-str (conc "SELECT COUNT(id) FROM runs WHERE state != 'deleted' AND runname  like '" runpatt "'" key-patt))
+    ;(print qry-str )
+       
+       (sqlite3:for-each-row 
+					 (lambda (count)
+	  			    (set! numruns count))
+				db
+				qry-str)
+       (debug:print-info 11 *default-log-port* "db:get-num-runs END " runpatt)
+       numruns))))
+
+
+;; (sqlite3#fold-row proc3670 init3671 db-or-stmt3672 . params3673)>
+;; 
+(define (db:get-raw-run-stats dbstruct run-id)
+  (db:with-db
+   dbstruct
+   run-id
+   #f
+   (lambda (db)
+     (sqlite3:fold-row
+	(lambda (res state status count)
+	  (cons (list state status count) res))
+	'()
+	db
+	"SELECT state,status,count(id) AS count FROM tests WHERE run_id=? AND NOT(uname='n/a' AND item_path='') GROUP BY state,status;"
+	run-id))))
+
+;; Update run_stats for given run_id
+;; input data is a list (state status count)
+;;
+(define (db:update-run-stats dbstruct run-id stats)
+  ;; (mutex-lock! *db-transaction-mutex*)
+  (db:with-db
+   dbstruct
+   #f
+   #f
+
+   (lambda (db)
+     ;; remove previous data
+     
+     (let* ((stmt1 (sqlite3:prepare db "DELETE FROM run_stats WHERE run_id=? AND state=? AND status=?;"))
+	    (stmt2 (sqlite3:prepare db "INSERT INTO run_stats (run_id,state,status,count) VALUES (?,?,?,?);"))
+	    (res
+	     (sqlite3:with-transaction
+	      db
+	      (lambda ()
+		(for-each
+		 (lambda (dat)
+		   (sqlite3:execute stmt1 run-id (car dat)(cadr dat))
+		   (apply sqlite3:execute stmt2 run-id dat))
+		 stats)))))
+       (sqlite3:finalize! stmt1)
+       (sqlite3:finalize! stmt2)
+       ;; (mutex-unlock! *db-transaction-mutex*)
+       res))))
+
+(define (db:get-main-run-stats dbstruct run-id)
+  (db:with-db
+   dbstruct
+   #f ;; this data comes from main
+   #f
+   (lambda (db)
+     (sqlite3:fold-row
+	(lambda (res state status count)
+	  (cons (list state status count) res))
+	'()
+	db
+	"SELECT state,status,count FROM run_stats WHERE run_id=? AND run_id IN (SELECT id FROM runs WHERE state NOT IN ('DELETED','deleted'));"
+	run-id))))
+
+(define (db:print-current-query-stats)
+  ;; generate stats from *db-api-call-time*
+  (let ((ordered-keys (sort (hash-table-keys *db-api-call-time*)
+			    (lambda (a b)
+			      (let ((sum-a (common:sum (hash-table-ref *db-api-call-time* a)))
+				    (sum-b (common:sum (hash-table-ref *db-api-call-time* b))))
+				(> sum-a sum-b)))))
+	(total        0))
+    (for-each
+     (lambda (cmd-key)
+       (let* ((dat  (hash-table-ref *db-api-call-time* cmd-key))
+	      (num  (length dat))
+	      (avg  (if (> num 0)
+			(/ (common:sum dat)(length dat)))))
+	 (set! total (+ total num))
+	 (debug:print-info 0 *default-log-port* cmd-key "\tavg: " avg " max: " (common:max dat) " min: " (common:min-max < dat) " num: " (length dat))))
+     ordered-keys)
+    (debug:print-info 0 *default-log-port* "TOTAL: " total " api calls since start.")))
+
+(define (db:get-all-run-ids dbstruct)
+  (db:with-db
+   dbstruct
+   #f
+   #f
+   (lambda (db)
+     (let ((run-ids '()))
+       (sqlite3:for-each-row
+	(lambda (run-id)
+	  (set! run-ids (cons run-id run-ids)))
+	db
+	"SELECT id FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;")
+    (reverse run-ids)))))
+
+;; get some basic run stats
+;;
+;; data structure:
+;;
+;; ( (runname (( state  count ) ... ))
+;;   (   ...
+;;
+(define (db:get-run-stats dbstruct)
+  (let* ((totals       (make-hash-table))
+	 (curr         (make-hash-table))
+	 (res          '())
+	 (runs-info    '()))
+    ;; First get all the runname/run-ids
+    (db:with-db
+     dbstruct #f #f
+     (lambda (db)
+       (sqlite3:for-each-row
+	(lambda (run-id runname)
+	  (set! runs-info (cons (list run-id runname) runs-info)))
+	db
+	"SELECT id,runname FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;"))) ;; If you change this to the more logical ASC please adjust calls to db:get-run-stats
+    ;; for each run get stats data
+    (for-each
+     (lambda (run-info)
+       ;; get the net state/status counts for this run
+       (let* ((run-id   (car  run-info))
+	      (run-name (cadr run-info)))
+	 (db:with-db
+	  dbstruct
+	  run-id
+	  #f
+	  (lambda (db)
+	    (sqlite3:for-each-row
+	     (lambda (state status count)
+	       (let ((netstate (if (equal? state "COMPLETED") status state)))
+		 (if (string? netstate)
+		     (begin
+		       (hash-table-set! totals netstate (+ (hash-table-ref/default totals netstate 0) count))
+		       (hash-table-set! curr   netstate (+ (hash-table-ref/default curr   netstate 0) count))))))
+	     db
+	     "SELECT state,status,count(id) FROM tests AS t WHERE run_id=? GROUP BY state,status ORDER BY state,status DESC;"
+             run-id)
+	    ;; add the per run counts to res
+	    (for-each (lambda (state)
+			(set! res (cons (list run-name state (hash-table-ref curr state)) res)))
+		      (sort (hash-table-keys curr) string>=))
+	    (set! curr (make-hash-table))))))
+     runs-info)
+    (for-each (lambda (state)
+		(set! res (cons (list "Totals" state (hash-table-ref totals state)) res)))
+	      (sort (hash-table-keys totals) string>=))
+    res))
+
+;; db:get-runs-by-patt
+;; get runs by list of criteria
+;; register a test run with the db
+;;
+;; Use: (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
+;;  to extract info from the structure returned
+;;
+(define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit fields last-update  sort-order ) ;; test-name)
+  (let* ((tmp      (runs:get-std-run-fields keys (or fields '("id" "runname" "state" "status" "owner" "event_time"))))
+	 (keystr   (car tmp))
+	 (header   (cadr tmp))
+	 (key-patt "")
+	 (runwildtype (if (substring-index "%" runnamepatt) "like" "glob"))
+	 (qry-str  #f)
+	 (keyvals  (if targpatt (keys:target->keyval keys targpatt) '())))
+    (for-each (lambda (keyval)
+		(let* ((key    (car keyval))
+		       (patt   (cadr keyval))
+		       (fulkey (conc ":" key))
+		       (wildtype (if (substring-index "%" patt) "like" "glob")))
+		  (if patt
+		      (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'"))
+		      (begin
+			(debug:print-error 0 *default-log-port* "searching for runs with no pattern set for " fulkey)
+			(exit 6)))))
+	      keyvals)
+    (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt 
+			(if last-update
+			       (conc " AND last_update >= " last-update " ")
+			       " ")
+			" ORDER BY event_time " sort-order " " 
+			(if limit  (conc " LIMIT " limit)   "")
+			(if offset (conc " OFFSET " offset) "")
+			";"))
+    (debug:print-info 4 *default-log-port* "runs:get-runs-by-patt qry=" qry-str " " runnamepatt)
+    ;(print "runs:get-runs-by-patt qry=" qry-str " " runnamepatt)
+
+    (vector header 
+            (reverse
+             (db:with-db dbstruct #f #f ;; reads db, does not write to it.
+                         (lambda (db)
+                           (sqlite3:fold-row
+                            (lambda (res . r)
+                              (cons (list->vector r) res))
+                            '()
+                            db
+                            qry-str
+                            runnamepatt)))))))
+
+;; use (get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
+;; NOTE: Does NOT return a list of rows (or one row) for the first slot of the vector
+;;       this is inconsistent with get-runs but it makes some sense.
+;;
+(define (db:get-run-info dbstruct run-id)
+  ;;(if (hash-table-ref/default *run-info-cache* run-id #f)
+  ;;    (hash-table-ref *run-info-cache* run-id)
+  (let* ((res       (vector #f #f #f #f))
+	 (keys      (db:get-keys dbstruct))
+	 (remfields (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour" "last_update")) ;;  "area_id"))
+	 (header    (append keys remfields))
+	 (keystr    (conc (keys->keystr keys) ","
+			  (string-intersperse remfields ","))))
+    (debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)
+    
+    (db:with-db
+     dbstruct #f #f
+     (lambda (db)
+       (sqlite3:for-each-row
+	(lambda (a . x)
+	  (set! res (apply vector a x)))
+	db 
+	(conc "SELECT " keystr " FROM runs WHERE id=?;")
+	run-id)))
+    (debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)
+    (let ((finalres (vector header res)))
+      ;; (hash-table-set! *run-info-cache* run-id finalres)
+      finalres)))
+
+(define (db:set-comment-for-run dbstruct run-id comment)
+  (db:with-db
+   dbstruct #f #f
+   (lambda (db)
+     (sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment ;; (sdb:qry 'getid comment)
+		      run-id))))
+
+;; does not (obviously!) removed dependent data. But why not!!?
+(define (db:delete-run dbstruct run-id)
+  (db:with-db
+   dbstruct #f #f
+   (lambda (db)
+     (sqlite3:with-transaction
+      db
+      (lambda ()
+        (sqlite3:execute db "DELETE FROM test_steps WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);" run-id)
+        (sqlite3:execute db "DELETE FROM test_data WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);"  run-id)
+        (sqlite3:execute db "UPDATE tests SET state='DELETED',comment='' WHERE run_id=?;" run-id)
+        ;; (db:delay-if-busy dbdat)
+        (sqlite3:execute db "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id))))))
+
+(define (db:update-run-event_time dbstruct run-id)
+  (db:with-db
+   dbstruct #f #t
+   (lambda (db)
+     (sqlite3:execute db "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id))))
+
+(define (db:lock/unlock-run dbstruct run-id lock unlock user)
+  (db:with-db
+   dbstruct #f #t
+   (lambda (db)
+     (let ((newlockval (if lock "locked"
+			   (if unlock
+			       "unlocked"
+			       "locked")))) ;; semi-failsafe
+       (sqlite3:execute db "UPDATE runs SET state=? WHERE id=?;" newlockval run-id)
+       (sqlite3:execute db "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);"
+			user (conc newlockval " " run-id))
+       (debug:print-info 1 *default-log-port* "" newlockval " run number " run-id)))))
+
+(define (db:set-run-status dbstruct run-id status msg)
+  (db:with-db
+   dbstruct #f #f
+   (lambda (db)
+       (if msg
+         (sqlite3:execute db "UPDATE runs SET status=?,comment=? WHERE id=?;" status msg run-id)
+         (sqlite3:execute db "UPDATE runs SET status=? WHERE id=?;" status run-id)))))
+
+(define (db:set-run-state-status dbstruct run-id state status )
+  (db:with-db
+   dbstruct #f #f
+   (lambda (db)
+          (sqlite3:execute db "UPDATE runs SET status=?,state=? WHERE id=?;" status state run-id))))
+
+
+
+(define (db:get-run-status dbstruct run-id)
+  (let ((res "n/a"))
+    (db:with-db
+     dbstruct #f #f
+     (lambda (db)
+       (sqlite3:for-each-row 
+	(lambda (status)
+	  (set! res status))
+	db
+	"SELECT status FROM runs WHERE id=?;" 
+	run-id)
+       res))))
+
+(define (db:get-run-state dbstruct run-id)
+  (let ((res "n/a"))
+    (db:with-db
+     dbstruct #f #f
+     (lambda (db)
+       (sqlite3:for-each-row 
+	(lambda (status)
+	  (set! res status))
+	db
+	"SELECT state FROM runs WHERE id=?;" 
+	run-id)
+       res))))
+
+
+;;======================================================================
+;; K E Y S
+;;======================================================================
+
+;; get key val pairs for a given run-id
+;; ( (FIELDNAME1 keyval1) (FIELDNAME2 keyval2) ... )
+(define (db:get-key-val-pairs dbstruct run-id)
+  (let* ((keys (db:get-keys dbstruct))
+	 (res  '()))
+    (db:with-db
+     dbstruct #f #f
+     (lambda (db)
+       (for-each 
+	(lambda (key)
+	  (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
+	    (sqlite3:for-each-row 
+	     (lambda (key-val)
+	       (set! res (cons (list key (if (string? key-val) key-val "")) res))) ;; replace non-string bad values with empty string to prevent crashes. This scenario can happen when Megatest is killed on updating the db
+	     db qry run-id)))
+	keys)))
+       (reverse res)))
+
+;; get key vals for a given run-id
+(define (db:get-key-vals dbstruct run-id)
+  (let* ((keys (db:get-keys dbstruct))
+	 (res  '()))
+    (db:with-db
+     dbstruct #f #f
+     (lambda (db)
+       (for-each 
+	(lambda (key)
+	  (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
+	    ;; (db:delay-if-busy dbdat)
+	    (sqlite3:for-each-row 
+	     (lambda (key-val)
+	       (set! res (cons (if (string? key-val) key-val "") res))) ;; check that the key-val is a string for cases where a crash injected bad data in the megatest.db
+	     db qry run-id)))
+	keys)))
+    (let ((final-res (reverse res)))
+      (hash-table-set! *keyvals* run-id final-res)
+      final-res)))
+
+;; The target is keyval1/keyval2..., cached in *target* as it is used often
+(define (db:get-target dbstruct run-id)
+  (let* ((keyvals (db:get-key-vals dbstruct run-id))
+	 (thekey  (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/")))
+    thekey))
+
+;; Get run-ids for runs with same target but different runnames and NOT run-id
+;;
+(define (db:get-prev-run-ids dbstruct run-id)
+  (let* ((keyvals (db:get-key-val-pairs dbstruct run-id))
+	 (kvalues (map cadr keyvals))
+	 (keys    (db:get-keys dbstruct))
+	 (qrystr  (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")))
+    (let ((prev-run-ids '()))
+      (if (null? keyvals)
+          '()
+          (begin
+            (db:with-db dbstruct #f #f ;; #f means work with the zeroth db - i.e. the runs db
+                        (lambda (db)
+                          (apply sqlite3:for-each-row
+                                 (lambda (id)
+                                   (set! prev-run-ids (cons id prev-run-ids)))
+                                 db
+                                 (conc "SELECT id FROM runs WHERE " qrystr " AND state != 'deleted' AND id != ?;")
+                                 (append kvalues (list run-id)))))
+            prev-run-ids)))))
+
+;;======================================================================
+;;  T E S T S
+;;======================================================================
+
+;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN
+;; i.e. these lists define what to NOT show.
+;; states and statuses are required to be lists, empty is ok
+;; not-in #t = above behaviour, #f = must match
+;; mode:
+;;  'dashboard - use state = 'COMPLETED' AND status in ( statuses ) OR state in ( states )
+;;
+(define (db:get-tests-for-run dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode)
+  (let* ((qryvalstr       (case qryvals
+			    ((shortlist) "id,run_id,testname,item_path,state,status")
+			    ((#f)        db:test-record-qry-selector) ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")
+			    (else        qryvals)))
+	 (res            '())
+	 ;; if states or statuses are null then assume match all when not-in is false
+	 (states-qry      (if (null? states) 
+			      #f
+			      (conc " state "  
+				    (if (eq? mode 'dashboard)
+					" IN ('"
+					(if not-in
+					    " NOT IN ('"
+					    " IN ('")) 
+				    (string-intersperse states   "','")
+				    "')")))
+	 (statuses-qry    (if (null? statuses)
+			      #f
+			      (conc " status "
+				    (if (eq? mode 'dashboard)
+					" IN ('"
+					(if not-in 
+					    " NOT IN ('"
+					    " IN ('") )
+				    (string-intersperse statuses "','")
+				    "')")))
+	 (interim-qry       (conc " AND " (if not-in "NOT " "") "( state='COMPLETED' " (if statuses-qry (conc " AND " statuses-qry " ) ") " ) ")
+				  (if states-qry
+				      (conc (if not-in " AND " " OR ") states-qry ) ;; " ) ")
+				      "")))
+	 (states-statuses-qry 
+	  (cond 
+	   ((and states-qry statuses-qry)
+	    (case mode
+	      ((dashboard) 
+	       (if not-in
+		   (conc " AND (state='COMPLETED' AND status NOT IN ('" (string-intersperse statuses "','") "')) "
+			 " OR (state != 'COMPLETED' AND state NOT IN ('" (string-intersperse states "','") "')) ")
+		   (conc " AND (state='COMPLETED' AND status IN ('" (string-intersperse statuses "','") "')) "
+			 " OR (state NOT IN ('COMPLETED','DELETED') AND state IN ('" (string-intersperse states "','") "')) ")))
+	      (else       (conc " AND ( " states-qry " AND " statuses-qry " ) "))))
+	   (states-qry  
+	    (case mode
+	      ((dashboard) (conc " AND " (if not-in "NOT " "") " state IN ('" (string-intersperse states    "','") "') ")) ;; interim-qry)
+	      (else        (conc " AND " states-qry))))
+	   (statuses-qry 
+	    (case mode
+	      ((dashboard) (conc " AND " (if not-in "NOT " "") " status IN ('" (string-intersperse statuses "','") "') ")) ;; interim-qry)
+	      (else        (conc " AND " statuses-qry))))
+	   (else "")))
+	 (tests-match-qry (tests:match->sqlqry testpatt))
+	 (qry             (conc "SELECT " qryvalstr
+				(if run-id
+				    " FROM tests WHERE run_id=? "
+				    " FROM tests WHERE ? > 0 ") ;; should work?
+				(if last-update " " " AND state != 'DELETED' ") ;; if using last-update we want deleted tests?
+				states-statuses-qry
+				(if tests-match-qry (conc " AND (" tests-match-qry ") ") "")
+				(if last-update (conc " AND last_update >= " last-update " ") "")
+				(case sort-by
+				  ((rundir)      " ORDER BY length(rundir) ")
+				  ((testname)    (conc " ORDER BY testname " (if sort-order (conc sort-order ",") "") " item_path "))
+				  ((statestatus) (conc " ORDER BY state " (if  sort-order (conc sort-order ",") "") " status "))
+				  ((event_time)  " ORDER BY event_time ")
+				  (else          (if (string? sort-by)
+						     (conc " ORDER BY " sort-by " ")
+						     " ")))
+				(if sort-order sort-order " ")
+				(if limit  (conc " LIMIT " limit)   " ")
+				(if offset (conc " OFFSET " offset) " ")
+				";"
+				)))
+    (debug:print-info 8 *default-log-port* "db:get-tests-for-run run-id=" run-id ", qry=" qry)
+    (let* ((res (db:with-db dbstruct run-id #f
+			    (lambda (db)
+			      ;; (let* ((stmth (db:get-cache-stmth dbstruct db qry))) ;; due to use of last-update we can't efficiently cache this query
+				(reverse
+				 (sqlite3:fold-row
+				  (lambda (res . row)
+				    ;; id run-id testname state status event-time host cpuload
+				    ;;     diskfree uname rundir item-path run-duration final-logf comment)
+				    (cons (list->vector row) res))
+				  '()
+				  db qry ;; stmth
+				  (or run-id 1) ;; 1 > 0 , for the case where we are seeking tests matching criteral for all runs
+				  ))))))
+      (case qryvals
+	((shortlist)(map db:test-short-record->norm res))
+	((#f)       res)
+	(else       res)))))
+
+(define (db:test-short-record->norm inrec)
+  ;;  "id,run_id,testname,item_path,state,status"
+  ;;  "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
+  (vector (vector-ref inrec 0) ;; id
+	  (vector-ref inrec 1) ;; run_id
+	  (vector-ref inrec 2) ;; testname
+	  (vector-ref inrec 4) ;; state
+	  (vector-ref inrec 5) ;; status
+	  -1 "" -1 -1 "" "-" 
+	  (vector-ref inrec 3) ;; item-path
+	  -1 "-" "-"))
+
+;;
+;; 1. cache tests-match-qry
+;; 2. compile qry and store in hash
+;; 3. convert for-each-row to fold
+;;
+;; THERE IS A BUG IN THIS ONE, MAYBE THE HOH STUFF AIN'T WORKING?
+;;
+#;(define (db:get-tests-for-run-state-status dbstruct run-id testpatt #!optional (last-update 0))
+  (db:with-db
+   dbstruct run-id #f
+   (lambda (db)
+`     (let* ((res            '())
+	     (stmt-cache      (dbr:dbstruct-stmt-cache dbstruct))
+	     (stmth           (let* ((sh (db:hoh-get stmt-cache db testpatt)))
+				(or sh
+				    (let* ((tests-match-qry (tests:match->sqlqry testpatt))
+					   (qry             (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? " 
+								  " AND last_update > ? "
+								  (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")))
+					   (newsh           (sqlite3:prepare db qry)))
+				      (debug:print-info 8 *default-log-port* "db:get-tests-for-run qry=" qry)
+				      (db:hoh-set! stmt-cache db testpatt newsh)
+				      newsh)))))
+       (reverse
+	(sqlite3:fold-row
+	 (lambda (res id testname item-path state status)
+	   ;;  id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
+	   (cons (vector id run-id testname state status -1         ""     -1      -1       ""    "-"  item-path -1           "-"         "-") res))
+	 '()
+	 stmth
+	 run-id
+	 (or last-update 0)))))))
+
+(define (db:get-tests-for-run-state-status dbstruct run-id testpatt #!optional (last-update 0))
+  (let* ((res            '())
+	 (tests-match-qry (tests:match->sqlqry testpatt))
+	 (qry             (conc "SELECT id,testname,item_path,state,status,event_time,run_duration FROM tests WHERE run_id=? " 
+				" AND last_update > ? "
+				(if tests-match-qry (conc " AND (" tests-match-qry ") ") "")
+				)))
+    (debug:print-info 8 *default-log-port* "db:get-tests-for-run qry=" qry)
+    (db:with-db dbstruct run-id #f
+		(lambda (db)
+		  (sqlite3:fold-row
+		   (lambda (res id testname item-path state status event-time run-duration)
+		     ;;            id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
+		     (cons (vector id run-id testname state status event-time  ""     -1      -1       ""    "-"  item-path run-duration  "-"         "-") res))
+		   '()
+		   db 
+		   qry
+		   run-id
+		   (or last-update 0))))))
+
+(define (db:get-testinfo-state-status dbstruct run-id test-id)
+  (let ((res            #f))
+    (db:with-db dbstruct run-id #f
+		(lambda (db)
+		  (sqlite3:for-each-row
+		   (lambda (run-id testname item-path state status)
+		     ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
+		     (set! res (vector test-id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-")))
+		   db 
+		   "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=?;" 
+		   test-id)))
+    res))
+
+;; get a useful subset of the tests data (used in dashboard
+;; use db:mintest-get-{id ,run_id,testname ...}
+;;
+(define (db:get-tests-for-run-mindata dbstruct run-id testpatt states statuses not-in)
+  (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f "id,run_id,testname,state,status,event_time,item_path" 0 #f))
+
+;; do not use.
+;;
+(define (db:get-tests-for-runs dbstruct run-ids testpatt states statuses #!key (not-in #f)(qryvals #f))
+  ;; (db:delay-if-busy)
+  (let ((res '()))
+    (for-each 
+     (lambda (run-id)
+       (set! res (append 
+		  res 
+		  (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f qryvals #f 'normal))))
+     (if run-ids
+	 run-ids
+	 (db:get-all-run-ids dbstruct)))
+    res))
+
+;; Convert calling routines to get list of run-ids and loop, do not use the get-tests-for-runs
+;;
+
+(define (db:delete-test-records dbstruct run-id test-id)
+  (db:general-call dbstruct 'delete-test-step-records (list test-id))
+  (db:general-call dbstruct 'delete-test-data-records (list test-id))
+  (db:with-db
+   dbstruct #f #f
+   (lambda (db)
+     (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id))))
+
+;; 
+(define (db:delete-old-deleted-test-records dbstruct)
+  (let ((targtime (- (current-seconds)
+		     (or (configf:lookup-number *configdat* "setup" "keep-deleted-records")
+			 (* 30 24 60 60))))) ;; one month in the past
+    (db:with-db
+     dbstruct
+     0
+     #t
+     (lambda (db)
+       (sqlite3:with-transaction
+	db
+	(lambda ()
+	  (sqlite3:execute db "DELETE FROM test_steps WHERE test_id IN (SELECT id FROM tests WHERE state='DELETED' AND event_time<?);" targtime)
+	  (sqlite3:execute db "DELETE FROM test_data WHERE test_id IN (SELECT id FROM tests WHERE state='DELETED' AND event_time<?);" targtime)
+	  (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED' AND event_time<?;" targtime)))))))
+
+;; NEW BEHAVIOR: Count tests running in all runs!
+;;
+(define (db:get-count-tests-running dbstruct run-id) ;; fastmode)
+  (let* ((qry ;; (if fastmode
+		;;   "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND NOT (uname = 'n/a' AND item_path = '') LIMIT 1;"
+		  "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND NOT (uname = 'n/a' AND item_path = '');")) ;; )
+  (db:with-db
+   dbstruct
+   run-id
+   #f
+   (lambda (db)
+     (let* ((stmth (db:get-cache-stmth dbstruct  db qry)))
+       (sqlite3:first-result stmth))))))
+
+;; NEW BEHAVIOR: Count tests running in only one run!
+;;
+(define (db:get-count-tests-actually-running dbstruct run-id)
+  (db:with-db
+   dbstruct
+   run-id
+   #f
+   (lambda (db)
+     (sqlite3:first-result
+      db
+      ;; WARNING BUG EDIT ME - merged from v1.55 - not sure what is right here ...
+      ;; "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id NOT IN (SELECT id FROM runs WHERE state='deleted') AND NOT (uname = 'n/a' AND item_path = '');")
+      "SELECT count(id) FROM tests WHERE state in ('RUNNING','REMOTEHOSTSTART','LAUNCHED') AND run_id=?;" 
+      run-id)))) ;; NOT IN (SELECT id FROM runs WHERE state='deleted');")
+
+;; NEW BEHAVIOR: Look only at single run with run-id
+;; 
+;; (define (db:get-running-stats dbstruct run-id)
+(define (db:get-count-tests-running-for-run-id dbstruct run-id) ;; fastmode)
+  (let* ((qry ;; (if fastmode
+		 ;;  "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=? LIMIT 1;"
+		  "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=?;")) ;; )
+    (db:with-db
+     dbstruct
+     run-id
+     #f
+     (lambda (db)
+       (let* ((stmth (db:get-cache-stmth dbstruct db qry)))
+	 (sqlite3:first-result stmth run-id))))))
+
+;; For a given testname how many items are running? Used to determine
+;; probability for regenerating html
+;;
+(define (db:get-count-tests-running-for-testname dbstruct run-id testname)
+  (db:with-db
+   dbstruct
+   run-id
+   #f
+   (lambda (db)
+     (let* ((stmt "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=? AND NOT (uname = 'n/a' AND item_path = '') AND testname=?;")
+	    (stmth (db:get-cache-stmth dbstruct db stmt)))
+       (sqlite3:first-result
+	stmth run-id testname)))))
+
+(define (db:get-not-completed-cnt dbstruct run-id)
+(db:with-db
+   dbstruct
+   run-id
+   #f
+   (lambda (db)
+      ;(print "SELECT count(id) FROM tests WHERE state not in ('COMPLETED', 'DELETED') AND run_id=" run-id)  
+     (sqlite3:first-result
+      db
+      "SELECT count(id) FROM tests WHERE state not in ('COMPLETED', 'DELETED') AND run_id=?;" run-id))))
+
+(define (db:get-count-tests-running-in-jobgroup dbstruct run-id jobgroup)
+  (if (not jobgroup)
+      0 ;; 
+      (let ((testnames '()))
+	;; get the testnames
+	(db:with-db
+	 dbstruct #f #f
+	 (lambda (db)
+	   (sqlite3:for-each-row
+	    (lambda (testname)
+	      (set! testnames (cons testname testnames)))
+	    db
+	    "SELECT testname FROM test_meta WHERE jobgroup=?"
+	    jobgroup)))
+	;; get the jobcount NB// EXTEND THIS TO OPPERATE OVER ALL RUNS?
+	(if (not (null? testnames))
+	    (db:with-db
+	     dbstruct
+	     run-id
+	     #f
+	     (lambda (db)
+	       (sqlite3:first-result
+		db
+		(conc "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND testname in ('"
+		      (string-intersperse testnames "','")
+		      "') AND NOT (uname = 'n/a' AND item_path='');")) ;; should this include the (uname = 'n/a' ...) ???
+	       ))
+	    0))))
+
+;; tags: '("tag%" "tag2" "%ag6")
+;;
+
+;; done with run when:
+;;   0 tests in LAUNCHED, NOT_STARTED, REMOTEHOSTSTART, RUNNING
+(define (db:estimated-tests-remaining dbstruct run-id)
+  (db:with-db
+   dbstruct
+   run-id
+   #f
+   (lambda (db)
+     (sqlite3:first-result
+      db
+      "SELECT count(id) FROM tests WHERE state in ('LAUNCHED','NOT_STARTED','REMOTEHOSTSTART','RUNNING','KILLREQ') AND run_id=?;")
+     run-id)))
+
+;; map run-id, testname item-path to test-id
+(define (db:get-test-id dbstruct run-id testname item-path)
+  (db:with-db
+   dbstruct
+   run-id
+   #f
+   (lambda (db)
+     (db:first-result-default
+      db
+      "SELECT id FROM tests WHERE testname=? AND item_path=? AND run_id=?;"
+      #f ;; the default
+      testname item-path run-id))))
+
+;; overload the unused attemptnum field for the process id of the runscript or 
+;; ezsteps step script in progress
+;;
+(define (db:test-set-top-process-pid dbstruct run-id test-id pid)
+  (db:with-db
+   dbstruct
+   run-id
+   #f
+   (lambda (db)
+     (sqlite3:execute db "UPDATE tests SET attemptnum=? WHERE id=?;"
+		      pid test-id))))
+
+(define (db:test-get-top-process-pid dbstruct run-id test-id)
+  (db:with-db
+   dbstruct
+   run-id
+   #f
+   (lambda (db)
+     (db:first-result-default
+      db
+      "SELECT attemptnum FROM tests WHERE id=?;"
+      #f
+      test-id))))
+
+(define db:test-record-fields '("id"           "run_id"        "testname"  "state"      "status"      "event_time"
+				"host"         "cpuload"       "diskfree"  "uname"      "rundir"      "item_path"
+                                "run_duration" "final_logf"    "comment"   "shortdir"   "attemptnum"  "archived" "last_update"))
+
+;; fields *must* be a non-empty list
+;;
+(define (db:field->number fieldname fields)
+  (if (null? fields)
+      #f
+      (let loop ((hed  (car fields))
+		 (tal  (cdr fields))
+		 (indx 0))
+	(if (equal? fieldname hed)
+	    indx
+	    (if (null? tal)
+		#f
+		(loop (car tal)(cdr tal)(+ indx 1)))))))
+
+(define db:test-record-qry-selector (string-intersperse db:test-record-fields ","))
+
+(define (db:update-tesdata-on-repilcate-db dbstruct old-lt new-lt)
+  (db:with-db
+   dbstruct   #f   #f
+   (lambda (db)
+     (sqlite3:execute db "UPDATE tests SET rundir= replace(rundir,?,?), shortdir=replace(shortdir,?,?);"
+		      old-lt new-lt  old-lt new-lt))))
+
+;; NOTE: Use db:test-get* to access records
+;; NOTE: This needs rundir decoding? Decide, decode here or where used? For the moment decode where used.
+(define (db:get-all-tests-info-by-run-id dbstruct run-id)
+  (let* ((res '()))
+    (db:with-db
+     dbstruct #f #f
+     (lambda (db)
+       (sqlite3:for-each-row
+	(lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived)
+	  ;;                 0    1       2      3      4        5       6      7        8     9     10      11          12          13       14     15        16
+	  (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived)
+			  res)))
+	db
+	(conc "SELECT " db:test-record-qry-selector " FROM tests WHERE state != 'DELETED' AND run_id=?;")
+	run-id)))
+    res))
+
+(define (db:replace-test-records dbstruct run-id testrecs)
+  (db:with-db dbstruct run-id #t 
+	      (lambda (db)
+		(let* ((qmarks (string-intersperse (make-list (length db:test-record-fields) "?") ","))
+		       (qrystr (conc "INSERT OR REPLACE INTO tests (" db:test-record-qry-selector ") VALUES (" qmarks ") WHERE run_id=?;"))
+		       (qry    (sqlite3:prepare db qrystr)))
+		  (debug:print 0 *default-log-port* "INFO: migrating test records for run with id " run-id)
+		  (sqlite3:with-transaction
+		   db
+		   (lambda ()
+		     (for-each 
+		      (lambda (rec)
+			;; (debug:print 0 *default-log-port* "INFO: Inserting values: " (string-intersperse (map conc (vector->list rec)) ",") "\n")
+			(apply sqlite3:execute qry (append (vector->list rec)(list run-id))))
+		      testrecs)))
+		  (sqlite3:finalize! qry)))))
+
+;; map a test-id into the proper range
+;;
+(define (db:adj-test-id mtdb min-test-id test-id)
+  (if (>= test-id min-test-id)
+      test-id
+      (let loop ((new-id min-test-id))
+	(let ((test-id-found #f))
+	  (sqlite3:for-each-row 
+	   (lambda (id)
+	     (set! test-id-found id))
+	   (db:dbdat-get-db mtdb)
+	   "SELECT id FROM tests WHERE id=?;"
+	   new-id)
+	  ;; if test-id-found then need to try again
+	  (if test-id-found
+	      (loop (+ new-id 1))
+	      (begin
+		(debug:print-info 0 *default-log-port* "New test id " new-id " selected for test with id " test-id)
+		(sqlite3:execute mtdb "UPDATE tests SET id=? WHERE id=?;" new-id test-id)))))))
+
+;; move test ids into the 30k * run_id range
+;;
+(define (db:prep-megatest.db-adj-test-ids mtdb run-id testrecs)
+  (debug:print-info 0 *default-log-port* "Adjusting test ids in megatest.db for run " run-id)
+  (let ((min-test-id (* run-id 30000)))
+    (for-each 
+     (lambda (testrec)
+       (let* ((test-id (vector-ref testrec (db:field->number "id" db:test-record-fields))))
+	 (db:adj-test-id (db:dbdat-get-db mtdb) min-test-id test-id)))
+     testrecs)))
+	
+;; 1. move test ids into the 30k * run_id range
+;; 2. move step ids into the 30k * run_id range
+;;
+(define (db:prep-megatest.db-for-migration mtdb)
+  (let* ((run-ids (db:get-all-run-ids mtdb)))
+    (for-each 
+     (lambda (run-id)
+       (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id)))
+	 (db:prep-megatest.db-adj-test-ids (db:dbdat-get-db mtdb) run-id testrecs)))
+     run-ids)))
+
+;; Get test data using test_id, run-id is not used
+;; 
+(define (db:get-test-info-by-id dbstruct run-id test-id)
+  (db:with-db
+   dbstruct
+   #f ;; run-id
+   #f
+   (lambda (db)
+     (let ((res #f))
+       (sqlite3:for-each-row ;; attemptnum added to hold pid of top process (not Megatest) controlling a test
+	(lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived last-update)
+	  ;;                0    1       2      3      4        5       6      7        8     9     10      11          12          13           14         15          16
+	  (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived last-update)))
+	db
+	(conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=?;")
+	test-id)
+       res))))
+
+;; Use db:test-get* to access
+;; Get test data using test_ids. NB// Only works within a single run!!
+;;
+(define (db:get-test-info-by-ids dbstruct run-id test-ids)
+  (db:with-db
+   dbstruct
+   run-id
+   #f
+   (lambda (db)
+     (let ((res '()))
+       (sqlite3:for-each-row
+	(lambda (a . b)
+	  ;;                 0    1       2      3      4        5       6      7        8     9     10      11          12          13       14
+	  (set! res (cons (apply vector a b) res)))
+	db
+	(conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id in ("
+	      (string-intersperse (map conc test-ids) ",") ");"))
+       res))))
+
+(define (db:get-test-info dbstruct run-id test-name item-path)
+  (db:with-db
+   dbstruct
+   run-id
+   #f
+   (lambda (db)
+     (let ((res #f))
+       (sqlite3:for-each-row
+	(lambda (a . b)
+	  (set! res (apply vector a b)))
+	db
+	(conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=? AND run_id=?;")
+	test-name item-path run-id)
+       res))))
+
+(define (db:test-get-rundir-from-test-id dbstruct run-id test-id)
+  (db:with-db
+   dbstruct
+   run-id
+   #f
+   (lambda (db)
+     (db:first-result-default
+      db
+      "SELECT rundir FROM tests WHERE id=?;"
+      #f ;; default result
+      test-id))))
+
+(define (db:get-test-times dbstruct run-name target)
+  (let ((res `())
+        (qry 	(conc "select testname, item_path, run_duration, "
+		      (string-join (db:get-keys dbstruct) " || '/' || ")
+		      " as target from tests inner join runs on tests.run_id = runs.id where runs.runname = ? and target = ?  ;")))
+    (db:with-db 
+     dbstruct
+     #f ;; this is for the main runs db
+     #f ;; does not modify db
+     (lambda (db)
+       (sqlite3:for-each-row
+	(lambda (test-name item-path test-time target )
+	  (set! res (cons (vector test-name item-path test-time) res)))
+	db
+	qry 
+	run-name target)
+       res))))
+
+;;======================================================================
+;; S T E P S
+;;======================================================================
+
+(define (db:teststep-set-status! dbstruct run-id test-id teststep-name state-in status-in comment logfile)
+  (db:with-db
+   dbstruct
+   run-id
+   #t
+   (lambda (db)
+     (sqlite3:execute 
+      db
+      "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);"
+      test-id teststep-name state-in status-in (current-seconds)
+      (if comment comment "")
+      (if logfile logfile "")))))
+
+
+
+(define (db:delete-steps-for-test! dbstruct run-id test-id)
+  ;; TODO: figure out why status is the key field rather than state (note:  CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state) )
+  (db:with-db
+   dbstruct
+   run-id
+   #t
+   (lambda (db)
+     (sqlite3:execute 
+      db
+      "UPDATE test_steps set status='DELETED' where test_id=?" ;;  and run_id=? !! - run_id not in table (bummer) TODO: get run_id into schema for test_steps
+      test-id))))
+
+
+;; db-get-test-steps-for-run
+(define (db:get-steps-for-test dbstruct run-id test-id)
+  (db:with-db
+   dbstruct
+   run-id
+   #f
+   (lambda (db)
+     (let* ((res '()))
+       (sqlite3:for-each-row 
+	(lambda (id test-id stepname state status event-time logfile comment)
+	  (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment) res)))
+	db
+	"SELECT id,test_id,stepname,state,status,event_time,logfile,comment FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
+	test-id)
+       (reverse res)))))
+
+ (define (db:get-steps-info-by-id dbstruct  test-step-id)
+   (db:with-db
+    dbstruct
+    #f 
+    #f
+    (lambda (db)
+      (let* ((res (vector #f #f #f #f #f #f #f #f #f)))
+        (sqlite3:for-each-row 
+       (lambda (id test-id stepname state status event-time logfile comment last-update)
+         (set! res (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment last-update)))
+       db
+       "SELECT id,test_id,stepname,state,status,event_time,logfile,comment,last_update FROM test_steps WHERE id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
+       test-step-id)
+        res))))
+
+(define (db:get-steps-data dbstruct run-id test-id)
+  (db:with-db
+   dbstruct
+   run-id
+   #f
+   (lambda (db)
+     (let ((res '()))
+       (sqlite3:for-each-row 
+	(lambda (id test-id stepname state status event-time logfile)
+	  (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res)))
+	db
+	"SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
+	test-id)
+       (reverse res)))))
+
+;;======================================================================
+;; T E S T  D A T A 
+;;======================================================================
+
+(define (db:get-data-info-by-id dbstruct  test-data-id)
+  (let* ((stmt        "SELECT id,test_id, category, variable, value, expected, tol, units, comment, status, type, last_update FROM test_data WHERE id=? ORDER BY id ASC;")) ;; event_time DESC,id ASC;
+    (db:with-db
+     dbstruct
+     #f 
+     #f
+     (lambda (db)
+       (let* ((stmth (db:get-cache-stmth dbstruct db stmt))
+	      (res   (sqlite3:fold-row
+		      (lambda (res id test-id  category variable value expected tol units comment status type last-update)
+			(vector id test-id  category variable value expected tol units comment status type last-update))
+		      (vector #f #f #f #f #f #f #f #f #f #f #f #f)
+		      stmth
+		      test-data-id)))
+        res)))))
+
+;; WARNING: Do NOT call this for the parent test on an iterated test
+;; Roll up test_data pass/fail results
+;; look at the test_data status field, 
+;;    if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS.
+;;    if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored
+(define (db:test-data-rollup dbstruct run-id test-id status)
+  (let* ((fail-count 0)
+	 (pass-count 0))
+    (db:with-db
+     dbstruct #f #f
+     (lambda (db)
+       (sqlite3:for-each-row
+	(lambda (fcount pcount)
+	  (set! fail-count fcount)
+	  (set! pass-count pcount))
+	db 
+	"SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count,
+             (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'pass') AS pass_count;"
+	test-id test-id)
+       ;; Now rollup the counts to the central megatest.db
+       (db:general-call dbstruct 'pass-fail-counts (list pass-count fail-count test-id))
+       ;; if the test is not FAIL then set status based on the fail and pass counts.
+       (db:general-call dbstruct 'test_data-pf-rollup (list test-id test-id test-id test-id))))))
+
+;; each section is a rule except "final" which is the final result
+;;
+;; [rule-5]
+;; operator in
+;; section LogFileBody
+;; desc Output voltage
+;; status OK
+;; expected 1.9
+;; measured 1.8
+;; type +/-
+;; tolerance 0.1
+;; pass 1
+;; fail 0
+;; 
+;; [final]
+;; exit-code 6
+;; exit-status SKIP
+;; message If flagged we are asking for this to exit with code 6
+;;
+;; recorded in steps table:
+;;   category: stepname
+;;   variable: rule-N
+;;   value:    measured
+;;   expected: expected
+;;   tol:      tolerance
+;;   units:    -
+;;   comment:  desc or message
+;;   status:   status
+;;   type:     type
+;; 
+(define (db:logpro-dat->csv dat stepname)
+  (let ((res '()))
+    (for-each
+     (lambda (entry-name)
+       (if (equal? entry-name "final")
+	   (set! res (append 
+		      res
+		      (list
+		       (list stepname
+			     entry-name
+			     (configf:lookup dat entry-name "exit-code")    ;; 0 ;; Value
+			     0                                              ;; 1 ;; Expected
+			     0                                              ;; 2 ;; Tolerance
+			     "n/a"					    ;; 3 ;; Units
+			     (configf:lookup dat entry-name "message")      ;; 4 ;; Comment
+			     (configf:lookup dat entry-name "exit-status")  ;; 5 ;; Status
+			     "logpro"                                       ;; 6 ;; Type
+			     ))))
+	   (let* ((value     (or (configf:lookup dat entry-name "measured")  "n/a"))
+		  (expected  (or (configf:lookup dat entry-name "expected")  0.0))
+		  (tolerance (or (configf:lookup dat entry-name "tolerance") 0.0))
+		  (comment   (or (configf:lookup dat entry-name "comment")
+				 (configf:lookup dat entry-name "desc")      "n/a"))
+		  (status    (or (configf:lookup dat entry-name "status")    "n/a"))
+		  (type      (or (configf:lookup dat entry-name "expected")  "n/a")))
+	     (set! res (append
+			res  
+			(list (list stepname
+				    entry-name 
+				    value        ;; 0
+				    expected     ;; 1
+				    tolerance    ;; 2
+				    "n/a"        ;; 3 Units
+				    comment      ;; 4
+				    status       ;; 5
+				    type         ;; 6
+				    )))))))
+     (hash-table-keys dat))
+    res))
+
+;; $MT_MEGATEST -load-test-data << EOF
+;; foo,bar,   1.2,  1.9, >
+;; foo,rab, 1.0e9, 10e9, 1e9
+;; foo,bla,   1.2,  1.9, <
+;; foo,bal,   1.2,  1.2, <   ,     ,Check for overload
+;; foo,alb,   1.2,  1.2, <=  , Amps,This is the high power circuit test
+;; foo,abl,   1.2,  1.3, 0.1
+;; foo,bra,   1.2, pass, silly stuff
+;; faz,bar,    10,  8mA,     ,     ,"this is a comment"
+;; EOF
+
+(define (tdb:get-prev-tol-for-test tdb test-id category variable)
+  ;; Finish me?
+  (values #f #f #f))
+
+(define (db:csv->test-data dbstruct run-id test-id csvdata)
+  (debug:print 4 *default-log-port* "test-id " test-id ", csvdata: " csvdata)
+  (db:with-db
+   dbstruct #f #f
+   (lambda (db)
+     (let* ((csvlist (csv->list (make-csv-reader
+				 (open-input-string csvdata)
+				 '((strip-leading-whitespace? #t)
+				   (strip-trailing-whitespace? #t)))))) ;; (csv->list csvdata)))
+       (for-each
+	(lambda (csvrow)
+	  (let* ((padded-row  (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9))
+		 (category    (list-ref padded-row 0))
+		 (variable    (list-ref padded-row 1))
+		 (value       (any->number-if-possible (list-ref padded-row 2)))
+		 (expected    (any->number-if-possible (list-ref padded-row 3)))
+		 (tol         (any->number-if-possible (list-ref padded-row 4))) ;; >, <, >=, <=, or a number
+		 (units       (list-ref padded-row 5))
+		 (comment     (list-ref padded-row 6))
+		 (status      (let ((s (list-ref padded-row 7)))
+				(if (and (string? s)(or (string-match (regexp "^\\s*$") s)
+							(string-match (regexp "^n/a$") s)))
+				    #f
+				    s))) ;; if specified on the input then use, else calculate
+		 (type        (list-ref padded-row 8)))
+	    ;; look up expected,tol,units from previous best fit test if they are all either #f or ''
+	    (debug:print 4 *default-log-port* "BEFORE: category: " category " variable: " variable " value: " value 
+			 ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment " type: " type)
+	    
+	    (if (and (or (not expected)(equal? expected ""))
+		     (or (not tol)     (equal? expected ""))
+		     (or (not units)   (equal? expected "")))
+		(let-values (((new-expected new-tol new-units)(tdb:get-prev-tol-for-test #f test-id category variable)))
+		  (set! expected new-expected)
+		  (set! tol      new-tol)
+		  (set! units    new-units)))
+	    
+	    (debug:print 4 *default-log-port* "AFTER:  category: " category " variable: " variable " value: " value 
+			 ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment)
+	    ;; calculate status if NOT specified
+	    (if (and (not status)(number? expected)(number? value)) ;; need expected and value to be numbers
+		(if (number? tol) ;; if tol is a number then we do the standard comparison
+		    (let* ((max-val (+ expected tol))
+			   (min-val (- expected tol))
+			   (result  (and (>=  value min-val)(<= value max-val))))
+		      (debug:print 4 *default-log-port* "max-val: " max-val " min-val: " min-val " result: " result)
+		      (set! status (if result "pass" "fail")))
+		    (set! status ;; NB// need to assess each one (i.e. not return operator since need to act if not valid op.
+		      (case (string->symbol tol) ;; tol should be >, <, >=, <=
+			((>)  (if (>  value expected) "pass" "fail"))
+			((<)  (if (<  value expected) "pass" "fail"))
+			((>=) (if (>= value expected) "pass" "fail"))
+			((<=) (if (<= value expected) "pass" "fail"))
+			(else (conc "ERROR: bad tol comparator " tol))))))
+	    (debug:print 4 *default-log-port* "AFTER2: category: " category " variable: " variable " value: " value 
+			 ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment)
+	    ;; (db:delay-if-busy dbdat)
+	    (sqlite3:execute db "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);"
+			     test-id category variable value expected tol units (if comment comment "") status type)))
+	csvlist)))))
+
+;; This routine moved from tdb.scm, tdb:read-test-data
+;;
+(define (db:read-test-data dbstruct run-id test-id categorypatt)
+  (let* ((res '()))
+    (db:with-db
+     dbstruct #f #f
+     (lambda (db)
+       (sqlite3:for-each-row 
+	(lambda (id test_id category variable value expected tol units comment status type)
+	  (set! res (cons (vector id test_id category variable value expected tol units comment status type) res)))
+	db
+	"SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt)
+       (reverse res)))))
+
+;; This routine moved from tdb.scm, :read-test-data
+;;
+(define (db:read-test-data-varpatt dbstruct run-id test-id categorypatt varpatt)
+  (let* ((res '()))
+    (db:with-db
+     dbstruct #f #f
+     (lambda (db)
+       (sqlite3:for-each-row 
+	(lambda (id test_id category variable value expected tol units comment status type)
+	  (set! res (cons (vector id test_id category variable value expected tol units comment status type) res)))
+	db
+	"SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? AND variable LIKE ? ORDER BY category,variable;" test-id categorypatt varpatt)
+       (reverse res)))))
+
+
+;;======================================================================
+;; Misc. test related queries
+;;======================================================================
+
+(define (db:get-run-ids-matching-target dbstruct keynames target res runname testpatt statepatt statuspatt)
+  (db:with-db
+   dbstruct #f #f
+   (lambda (db)
+     (let* ((row-ids '())
+	    (keystr (string-intersperse 
+		     (map (lambda (key val)
+			    (conc key " like '" val "'"))
+			  keynames 
+			  (string-split target "/"))
+		     " AND "))
+	    ;; (testqry (tests:match->sqlqry testpatt))
+	    (runsqry (sqlite3:prepare db (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';"))))
+       ;; (debug:print 8 *default-log-port* "db:test-get-paths-matching-keynames-target-new\n  runsqry=" runsqry "\n  tstsqry=" testqry)
+       (sqlite3:for-each-row
+	(lambda (rid)
+	  (set! row-ids (cons rid row-ids)))
+	runsqry)
+       (sqlite3:finalize! runsqry)
+       row-ids))))
+
+;; finds latest matching all patts for given run-id
+;;
+(define (db:test-get-paths-matching-keynames-target-new dbstruct run-id keynames target res testpatt statepatt statuspatt runname)
+  (let* ((testqry (tests:match->sqlqry testpatt))
+	 (tstsqry (conc "SELECT rundir FROM tests WHERE run_id=? AND " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;")))
+    (db:with-db
+     dbstruct
+     run-id
+     #f
+     (lambda (db)
+       (sqlite3:for-each-row 
+	(lambda (p)
+	  (set! res (cons p res)))
+	db
+	tstsqry
+	run-id)
+       res))))
+
+(define (db:test-toplevel-num-items dbstruct run-id testname)
+  (db:with-db
+   dbstruct
+   run-id
+   #f
+   (lambda (db)
+     (let ((res 0))
+       (sqlite3:for-each-row
+	(lambda (num-items)
+	  (set! res num-items))
+	db
+	"SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND state NOT IN ('DELETED');"
+	run-id
+	testname)
+       res))))
+
+;;======================================================================
+;; QUEUE UP META, TEST STATUS AND STEPS REMOTE ACCESS
+;;======================================================================
+
+;; NOTE: Can remove the regex and base64 encoding for zmq
+(define (db:obj->string obj #!key (transport 'http))
+  (case transport
+    ;; ((fs) obj)
+    ((http fs)
+     (string-substitute
+      (regexp "=") "_"
+      (base64:base64-encode 
+       (z3:encode-buffer
+	(with-output-to-string
+	  (lambda ()(serialize obj))))) ;; BB: serialize - this is what causes problems between different builds of megatest communicating.  serialize is sensitive to binary image of mtest.
+      #t))
+    ((zmq nmsg)(with-output-to-string (lambda ()(serialize obj))))
+    (else obj))) ;; rpc
+
+(define (db:string->obj msg #!key (transport 'http))
+  (case transport
+    ;; ((fs) msg)
+    ((http fs)
+     (if (string? msg)
+	 (with-input-from-string 
+	     (z3:decode-buffer
+	      (base64:base64-decode
+	       (string-substitute 
+		(regexp "_") "=" msg #t)))
+	   (lambda ()(deserialize)))
+	 (begin
+	   (debug:print-error 0 *default-log-port* "reception failed. Received \"" msg "\" but cannot translate it.")
+           (print-call-chain (current-error-port))
+	   msg))) ;; crude reply for when things go awry
+    ((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize))))
+    (else msg))) ;; rpc
+
+(define (db:roll-up-rules state-status-counts state status)
+  (if (null? state-status-counts) ;; don't get it, why would this happen?
+      '(#f #f)
+      (let* ((running             (length (filter (lambda (x)
+						    (member (dbr:counts-state x) *common:running-states*))
+						  state-status-counts)))
+	     (bad-not-started      (length (filter (lambda (x)
+						     (and (equal? (dbr:counts-state x) "NOT_STARTED") 
+							  (not (member (dbr:counts-status x)  *common:not-started-ok-statuses*))))
+						   state-status-counts)))
+	     (all-curr-states      (common:special-sort  ;; worst -> best (sort of)
+				    (delete-duplicates
+				     (if (and state (not (member state *common:dont-roll-up-states*)))
+					 (cons state (map dbr:counts-state state-status-counts))
+					 (map dbr:counts-state state-status-counts)))
+				    *common:std-states* >))
+	     (all-curr-statuses    (common:special-sort  ;; worst -> best
+				    (delete-duplicates
+				     (if (and state status (not (member state *common:dont-roll-up-states*)))
+					 (cons status (map dbr:counts-status state-status-counts))
+					 (map dbr:counts-status state-status-counts)))
+				    *common:std-statuses* >))
+	     (non-completes        (filter (lambda (x)
+					     (not (member x (cons "COMPLETED" *common:dont-roll-up-states*))))
+					   all-curr-states))
+	     (preq-fails        (filter (lambda (x)
+					  (equal? x "PREQ_FAIL"))
+					all-curr-statuses))
+	     (num-non-completes (length non-completes))
+	     (newstate          (cond
+				 ((> running 0)             "RUNNING")            ;; anything running, call the situation running
+				 ((> (length preq-fails) 0) "NOT_STARTED")
+				 ((> bad-not-started 0)     "COMPLETED")          ;; we have an ugly situation, it is completed in the sense we cannot do more.
+				 ((> num-non-completes 0)   (car non-completes))  ;;  (remove (lambda (x)(equal? "COMPLETED" x)) all-curr-states))) ;; only rollup DELETED if all DELETED
+				 (else                      (car all-curr-states))))
+	     (newstatus         (cond
+				 ((> (length preq-fails) 0)  "PREQ_FAIL")
+				 ((or (> bad-not-started 0)
+				      (and (equal? newstate "NOT_STARTED")
+					   (> num-non-completes 0)))
+				  "STARTED")
+				 (else (car all-curr-statuses)))))
+	(debug:print-info 2 *default-log-port*
+			  "\n--> probe db:set-state-status-and-roll-up-items: "
+			  "\n--> state-status-counts: "(map dbr:counts->alist state-status-counts)
+			  "\n--> running:             "running
+			  "\n--> bad-not-started:     "bad-not-started
+			  "\n--> non-non-completes:   "num-non-completes
+			  "\n--> non-completes:       "non-completes
+			  "\n--> all-curr-states:     "all-curr-states
+			  "\n--> all-curr-statuses:   "all-curr-statuses
+			  "\n--> newstate             "newstate
+			  "\n--> newstatus            "newstatus
+			  "\n\n")
+	;; NB// Pass the db so it is part of the transaction
+	(list newstate newstatus))))
+
+(define (db:set-state-status-and-roll-up-run dbstruct run-id curr-state curr-status)
+    (mutex-lock! *db-transaction-mutex*)
+    (db:with-db
+     dbstruct #f #f
+     (lambda (db)
+       (let ((tr-res
+              (sqlite3:with-transaction
+               db
+               (lambda ()
+		 (let* ((state-status-counts  (db:get-all-state-status-counts-for-run dbstruct run-id))
+			(state-statuses       (db:roll-up-rules state-status-counts #f #f ))
+			(newstate             (car state-statuses))
+			(newstatus            (cadr state-statuses))) 
+		   (if (and newstate newstatus
+			    (or (not (eq? newstate curr-state)) (not (eq?  newstatus curr-status))))
+		       (db:set-run-state-status dbstruct run-id newstate newstatus )))))))
+         (mutex-unlock! *db-transaction-mutex*)
+         tr-res))))
+
+
+(define (db:get-all-state-status-counts-for-run dbstruct run-id)
+ (let* ((test-count-recs (db:with-db
+			  dbstruct #f #f
+			  (lambda (db)
+			    (sqlite3:map-row
+			     (lambda (state status count)
+			       (make-dbr:counts state: state status: status count: count))
+			     db
+			     "SELECT state,status,count(id) FROM tests WHERE run_id=?  GROUP BY state,status;"
+			     run-id )))))
+   test-count-recs))
+
+
+;; BBnote: db:get-all-state-status-counts-for-test returns dbr:counts object aggregating state and status of items of a given test, *not including rollup state/status*
+;;
+;; NOTE: This is called within a transaction
+;;
+(define (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path item-state-in item-status-in)
+  (let* ((test-info   (db:get-test-info dbstruct run-id test-name item-path))
+         (item-state  (or item-state-in (db:test-get-state test-info))) 
+         (item-status (or item-status-in (db:test-get-status test-info)))
+         (other-items-count-recs (db:with-db
+                                  dbstruct #f #f
+                                  (lambda (db)
+                                    (sqlite3:map-row
+                                     (lambda (state status count)
+                                       (make-dbr:counts state: state status: status count: count))
+                                     db
+                                     ;; ignore current item because we have changed its value in the current transation so this select will see the old value.
+                                     "SELECT state,status,count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND item_path !=? GROUP BY state,status;"
+                                     run-id test-name item-path))))
+
+         ;; add current item to tally outside of sql query
+         (match-countrec-lambda (lambda (countrec) 
+                                  (and (equal? (dbr:counts-state  countrec) item-state)
+                                       (equal? (dbr:counts-status countrec) item-status))))
+
+         (already-have-count-rec-list
+          (filter match-countrec-lambda other-items-count-recs)) ;; will have either 0 or 1 count recs depending if another item shares this item's state/status
+         
+         (updated-count-rec    (if (null? already-have-count-rec-list)
+                                   (make-dbr:counts state: item-state status: item-status count: 1)
+                                   (let* ((our-count-rec (car already-have-count-rec-list))
+                                          (new-count (add1 (dbr:counts-count our-count-rec))))
+                                     (make-dbr:counts state: item-state status: item-status count: new-count))))
+
+         (nonmatch-countrec-lambda (lambda (countrec) (not (match-countrec-lambda countrec))))
+         
+         (unrelated-rec-list   
+          (filter nonmatch-countrec-lambda other-items-count-recs)))
+    
+    (cons updated-count-rec unrelated-rec-list)))
+
+;; (define (db:get-all-item-states db run-id test-name)
+;;   (sqlite3:map-row 
+;;    (lambda (a) a)
+;;    db
+;;    "SELECT DISTINCT state FROM tests WHERE item_path != '' AND state != 'DELETED' AND run_id=? AND testname=?"
+;;    run-id test-name))
+;; 
+;; (define (db:get-all-item-statuses db run-id test-name)
+;;   (sqlite3:map-row 
+;;    (lambda (a) a)
+;;    db
+;;    "SELECT DISTINCT status FROM tests WHERE item_path != '' AND state != 'DELETED' AND state='COMPLETED' AND run_id=? AND testname=?"
+;;    run-id test-name))
+
+(define (db:test-get-logfile-info dbstruct run-id test-name)
+  (db:with-db
+   dbstruct
+   run-id
+   #f
+   (lambda (db)
+     (let ((res #f))
+       (sqlite3:for-each-row 
+	(lambda (path final_logf)
+	  ;; (let ((path       (sdb:qry 'getstr path-id))
+	  ;;       (final_logf (sdb:qry 'getstr final_logf-id)))
+	  (set! logf final_logf)
+	  (set! res (list path final_logf))
+	  (if (directory? path)
+	      (debug:print 2 *default-log-port* "Found path: " path)
+	      (debug:print 2 *default-log-port* "No such path: " path))) ;; )
+	db
+	"SELECT rundir,final_logf FROM tests WHERE testname=? AND item_path='' AND run_id=?;"
+	test-name run-id)
+       res))))
+
+;;======================================================================
+;; A G R E G A T E D   T R A N S A C T I O N   D B   W R I T E S 
+;;======================================================================
+
+(define db:queries 
+  (list '(update-run-duration     "UPDATE tests SET run_duration=? WHERE id=?;")
+
+	;; TESTS
+	'(register-test          "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');")
+	;; Test state and status
+	'(set-test-state         "UPDATE tests SET state=?   WHERE id=?;")
+	'(set-test-status        "UPDATE tests SET state=?   WHERE id=?;")
+	'(state-status           "UPDATE tests SET state=?,status=? WHERE id=?;") ;; D/ONE
+	'(state-status-msg       "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;") ;; DONE
+	;; Test comment
+	'(set-test-comment       "UPDATE tests SET comment=? WHERE id=?;")
+	'(set-test-start-time    "UPDATE tests SET event_time=strftime('%s','now') WHERE id=?;") ;; DONE
+	'(pass-fail-counts       "UPDATE tests SET pass_count=?,fail_count=? WHERE id=?;")
+	;; test_data-pf-rollup is used to set a tests PASS/FAIL based on the pass/fail info from the steps
+	'(test_data-pf-rollup    "UPDATE tests
+                                    SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 
+                                      THEN 'FAIL'
+                                    WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND 
+                                      (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL')
+                                    THEN 'PASS'
+                                    ELSE status
+                                    END WHERE id=?;") ;; DONE
+	'(test-set-log            "UPDATE tests SET final_logf=? WHERE id=?;")      ;; DONE
+	;; '(test-set-rundir-by-test-id "UPDATE tests SET rundir=? WHERE id=?")        ;; DONE
+	;; '(test-set-rundir         "UPDATE tests SET rundir=? AND testname=? AND item_path=?;") ;; DONE
+	'(test-set-rundir-shortdir "UPDATE tests SET rundir=?,shortdir=? WHERE testname=? AND item_path=? AND run_id=?;")    ;; BROKEN!!! NEEDS run-id
+	'(delete-tests-in-state   ;; "DELETE FROM tests WHERE state=?;")                  ;; DONE
+	  "UPDATE tests SET state='DELETED' WHERE state=?")
+	'(tests:test-set-toplog   "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';")
+	'(update-cpuload-diskfree "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;") ;; DONE
+	'(update-uname-host       "UPDATE tests SET uname=?,host=? WHERE id=?;")       ;; DONE
+        '(update-test-rundat      "INSERT INTO test_rundat (test_id,update_time,cpuload,diskfree,diskusage,run_duration) VALUES (?,?,?,?,?,?);")
+	'(update-test-state       "UPDATE tests SET state=? WHERE state=? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")
+	'(update-test-status      "UPDATE tests SET status=? WHERE status like ? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")
+	;; stuff for set-state-status-and-roll-up-items
+	'(update-pass-fail-counts "UPDATE tests 
+             SET fail_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('FAIL','CHECK','INCOMPLETE','ABORT')),
+                 pass_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED'))
+             WHERE testname=? AND item_path='' AND run_id=?;") ;; DONE  ;; BROKEN!!! NEEDS run-id
+	'(top-test-set-running  "UPDATE tests SET state='RUNNING' WHERE testname=? AND item_path='' AND run_id=?;") ;; DONE   ;; BROKEN!!! NEEDS run-id
+
+	;; NOT USED
+	;;
+	;; Might be the following top-test-set-per-pf-counts query could be better based off of something like this:
+	;;
+	;; select state,status,count(state) from tests where run_id=59 AND testname='runfirst' group by state,status;
+	;;
+	'(top-test-set-per-pf-counts "UPDATE tests
+                       SET state=CASE 
+                                   WHEN (SELECT count(id) FROM tests 
+                                                WHERE testname=?
+                                                     AND item_path != '' 
+                                                     AND status NOT IN ('n/a')
+                                                     AND state in ('NOT_STARTED')) > 0 THEN 'UNKNOWN'
+                                   WHEN (SELECT count(id) FROM tests 
+                                                WHERE testname=?
+                                                     AND item_path != '' 
+                                                     AND (status NOT IN ('TEN_STRIKES','BLOCKED') OR status IN ('INCOMPLETE'))
+                                                     AND state in ('RUNNING','NOT_STARTED','LAUNCHED','REMOTEHOSTSTART')) > 0 THEN 'RUNNING'
+                                   WHEN (SELECT count(id) FROM tests 
+                                                WHERE testname=?
+                                                     AND item_path != '' 
+                                                     AND state NOT IN ('COMPLETED','DELETED')) = 0 THEN 'COMPLETED'
+                                   WHEN (SELECT count(id) FROM tests 
+                                                WHERE testname=?
+                                                     AND item_path != '' 
+                                                     AND state = 'NOT_STARTED') > 0 THEN 'NOT_STARTED'
+                                   ELSE 'UNKNOWN' END,
+                            status=CASE 
+                                  WHEN fail_count > 0 THEN 'FAIL' 
+                                  WHEN (SELECT count(id) FROM tests
+                                         WHERE testname=?
+                                              AND item_path != ''
+                                              AND state IN ('BLOCKED','INCOMPLETE')) > 0 THEN 'FAIL'
+                                  WHEN (SELECT count(id) FROM tests
+                                         WHERE testname=?
+                                              AND item_path != ''
+                                              AND state NOT IN ('DELETED')
+                                              AND status IN ('INCOMPLETE','ABORT')) > 0 THEN 'ABORT'
+                                  WHEN (SELECT count(id) FROM tests
+                                         WHERE testname=?
+                                              AND item_path != ''
+                                              AND state NOT IN ('DELETED')
+                                              AND status = 'AUTO') > 0 THEN 'AUTO'
+                                  WHEN (SELECT count(id) FROM tests
+                                         WHERE testname=?
+                                              AND item_path != ''
+                                              AND state NOT IN ('DELETED')
+                                              AND status IN ('STUCK/INCOMPLETE', 'INCOMPLETE')) > 0 THEN 'INCOMPLETE'
+                                  WHEN (SELECT count(id) FROM tests
+                                         WHERE testname=?
+                                              AND item_path != ''
+                                              AND state IN ('COMPLETED','STUCK/INCOMPLETE','INCOMPLETE')
+                                              AND status = 'FAIL') > 0 THEN 'FAIL'
+                                  WHEN (SELECT count(id) FROM tests
+                                         WHERE testname=?
+                                              AND item_path != ''
+                                              AND state NOT IN ('DELETED')
+                                              AND status = 'CHECK') > 0 THEN 'CHECK'
+                                  WHEN (SELECT count(id) FROM tests
+                                         WHERE testname=?
+                                              AND item_path != ''
+                                              AND state NOT IN ('DELETED')
+                                              AND status = 'SKIP') > 0 THEN 'SKIP'
+                                  WHEN (SELECT count(id) FROM tests
+                                         WHERE testname=?
+                                              AND item_path != ''
+                                              AND state NOT IN ('DELETED')
+                                              AND status = 'WARN') > 0 THEN 'WARN'
+                                  WHEN (SELECT count(id) FROM tests
+                                         WHERE testname=?
+                                              AND item_path != ''
+                                              AND state NOT IN ('DELETED')
+                                              AND status = 'WAIVED') > 0 THEN 'WAIVED'
+                                  WHEN (SELECT count(id) FROM tests
+                                         WHERE testname=? 
+                                              AND item_path != ''
+                                              AND state NOT IN ('DELETED')
+                                              AND status NOT IN ('PASS','FAIL','WARN','WAIVED')) > 0 THEN 'ABORT'
+                                  WHEN (SELECT count(id) FROM tests
+                                         WHERE testname=?
+                                              AND item_path != ''
+                                              AND state='NOT_STARTED') > 0 THEN 'n/a'
+                                  WHEN (SELECT count(id) FROM tests
+                                         WHERE testname=?
+                                              AND item_path != ''
+                                              AND state = 'COMPLETED'
+                                              AND status = 'PASS') > 0 THEN 'PASS'
+                                  WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' 
+                                  ELSE 'UNKNOWN' END
+                       WHERE testname=? AND item_path='';") ;; DONE  ;; BROKEN!!! NEEDS run-id
+
+	;; STEPS
+	'(delete-test-step-records "UPDATE test_steps SET status='DELETED' WHERE test_id=?;")
+	'(delete-test-data-records "UPDATE test_data  SET status='DELETED' WHERE test_id=?;") ;; using status since no state field
+	))
+
+(define (db:lookup-query qry-name)
+  (let ((q (alist-ref qry-name db:queries)))
+    (if q (car q) #f)))
+
+;; do not run these as part of the transaction
+(define db:special-queries   '(rollup-tests-pass-fail
+			       ;; db:set-state-status-and-roll-up-items  ;; WHY NOT!?
+			       login
+			       immediate
+			       flush
+			       sync
+			       set-verbosity
+			       killserver
+			       ))
+
+(define (db:login dbstruct calling-path calling-version client-signature)
+   (cond 
+   ((not (equal? calling-path *toppath*))
+    (list #f "Login failed due to mismatch paths: " calling-path ", " *toppath*))
+   ;; ((not (equal? *run-id* run-id))
+   ;;  (list #f "Login failed due to mismatch run-id: " run-id ", " *run-id*))
+   ((not (equal? megatest-version calling-version))
+    (list #t (conc "Login warning due to mismatch megatest version: " calling-version ", " megatest-version)))
+   
+    (else
+    (hash-table-set! *logged-in-clients* client-signature (current-seconds))
+    '(#t "successful login"))))
+
+(define (db:general-call dbstruct stmtname params)
+  (let ((query (let ((q (alist-ref (if (string? stmtname)
+				       (string->symbol stmtname)
+				       stmtname)
+				   db:queries)))
+ 		 (if q (car q) #f))))
+    (db:with-db
+     dbstruct #f #f
+     (lambda (db)
+       (apply sqlite3:execute db query params)
+       #t))))
+
+;; get a summary of state and status counts to calculate a rollup
+;;
+(define (db:get-state-status-summary dbstruct run-id testname)
+  (let ((res   '()))
+    (db:with-db
+     dbstruct #f #f
+     (lambda (db)
+       (sqlite3:for-each-row
+	(lambda (state status count)
+	  (set! res (cons (vector state status count) res)))
+	db
+	"SELECT state,status,count(state) FROM tests WHERE run_id=? AND testname=? AND item_path='' GROUP BY state,status;"
+	run-id testname)
+       res))))
+
+(define (db:get-latest-host-load dbstruct raw-hostname)
+  (let* ((hostname (string-substitute "\\..*$" "" raw-hostname))
+         (res  (cons -1 0)))
+    (db:with-db
+     dbstruct #f #f
+     (lambda (db)
+       (sqlite3:for-each-row
+        (lambda (cpuload update-time)  (set! res (cons cpuload update-time)))
+        db
+        "SELECT tr.cpuload, tr.update_time FROM test_rundat tr, tests t WHERE t.host=? AND tr.cpuload != -1  AND tr.test_id=t.id ORDER BY tr.update_time DESC LIMIT 1;"
+        hostname))) res ))
+
+(define (db:set-top-level-from-items dbstruct run-id testname)
+  (let* ((summ  (db:get-state-status-summary dbstruct run-id testname))
+	 (find  (lambda (state status)
+		  (if (null? summ) 
+		      #f
+		      (let loop ((hed (car summ))
+				 (tal (cdr summ)))
+			(if (and (string-match state  (vector-ref hed 0))
+				 (string-match status (vector-ref hed 1)))
+			    hed
+			    (if (null? tal)
+				#f
+				(loop (car tal)(cdr tal)))))))))
+
+
+      ;;;     E D I T M E ! !
+
+
+    (cond
+     ((> (find "COMPLETED" ".*") 0) #f))))
+		   
+    
+
+;; get the previous records for when these tests were run where all keys match but runname
+;; NB// Merge this with test:get-previous-test-run-records? This one looks for all matching tests
+;; can use wildcards. Also can likely be factored in with get test paths?
+;;
+;; Run this remotely!!
+;;
+(define (db:get-matching-previous-test-run-records dbstruct run-id test-name item-path)
+  (let* ((keys    (db:get-keys dbstruct))
+	 (selstr  (string-intersperse keys ","))
+	 (qrystr  (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND "))
+	 (keyvals #f)
+	 (tests-hash (make-hash-table)))
+    ;; first look up the key values from the run selected by run-id
+    (db:with-db
+     dbstruct #f #f
+     (lambda (db)
+       (sqlite3:for-each-row 
+	(lambda (a . b)
+	  (set! keyvals (cons a b)))
+	db
+	(conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id)))
+    (if (not keyvals)
+	'()
+	(let ((prev-run-ids '()))
+	  (db:with-db
+	   dbstruct #f #f
+	   (lambda (db)
+	     (apply sqlite3:for-each-row
+		    (lambda (id)
+		      (set! prev-run-ids (cons id prev-run-ids)))
+		    db
+		    (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id)))))
+	  ;; collect all matching tests for the runs then
+	  ;; extract the most recent test and return that.
+	  (debug:print 4 *default-log-port* "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals 
+		       ", previous run ids found: " prev-run-ids)
+	  (if (null? prev-run-ids) '()  ;; no previous runs? return null
+	      (let loop ((hed (car prev-run-ids))
+			 (tal (cdr prev-run-ids)))
+		(let ((results (db:get-tests-for-run dbstruct hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f #f 'normal)))
+		  (debug:print 4 *default-log-port* "Got tests for run-id " run-id ", test-name " test-name 
+			       ", item-path " item-path " results: " (intersperse results "\n"))
+		  ;; Keep only the youngest of any test/item combination
+		  (for-each 
+		   (lambda (testdat)
+		     (let* ((full-testname (conc (db:test-get-testname testdat) "/" (db:test-get-item-path testdat)))
+			    (stored-test   (hash-table-ref/default tests-hash full-testname #f)))
+		       (if (or (not stored-test)
+			       (and stored-test
+				    (> (db:test-get-event_time testdat)(db:test-get-event_time stored-test))))
+			   ;; this test is younger, store it in the hash
+			   (hash-table-set! tests-hash full-testname testdat))))
+		   results)
+		  (if (null? tal)
+		      (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests
+		      (loop (car tal)(cdr tal))))))))))
+
+;; Function recursively checks if <db>.journal exists; if yes means db busy; call itself after delayed interval
+;; return the sqlite3 db handle if possible
+;; 
+#;(define (db:delay-if-busy dbdat #!key (count 6))
+  (if (not (configf:lookup *configdat* "server" "delay-on-busy")) 
+      (and dbdat (db:dbdat-get-db dbdat))
+      (if dbdat
+	  (let* ((dbpath (db:dbdat-get-path dbdat))
+		 (db     (db:dbdat-get-db   dbdat)) ;; we'll return this so (db:delay--if-busy can be called inline
+		 (dbfj   (conc dbpath "-journal")))
+	    (if (handle-exceptions
+		 exn
+		 (begin
+		   (debug:print-info 0 *default-log-port* "WARNING: failed to test for existance of " dbfj ", exn=" exn)
+		   (thread-sleep! 1)
+		   (db:delay-if-busy count (- count 1))) 
+		 (common:file-exists? dbfj))
+		(case count
+		  ((6)
+		   (thread-sleep! 0.2)
+		   (db:delay-if-busy count: 5))
+		  ((5)
+		   (thread-sleep! 0.4)
+		   (db:delay-if-busy count: 4))
+		  ((4)
+		   (thread-sleep! 0.8)
+		   (db:delay-if-busy count: 3))
+		  ((3)
+		   (thread-sleep! 1.6)
+		   (db:delay-if-busy count: 2))
+		  ((2)
+		   (thread-sleep! 3.2)
+		   (db:delay-if-busy count: 1))
+		  ((1)
+		   (thread-sleep! 6.4)
+		   (db:delay-if-busy count: 0))
+		  (else
+		   (debug:print-info 0 *default-log-port* "delaying db access due to high database load.")
+		   (thread-sleep! 12.8))))
+	    db) 
+	  "bogus result from db:delay-if-busy")))
+
+(define (db:test-get-records-for-index-file dbstruct run-id test-name)
+  (let ((res '()))
+    (db:with-db
+     dbstruct
+     run-id
+     #f
+     (lambda (db)
+       (sqlite3:for-each-row 
+	(lambda (id itempath state status run_duration logf comment)
+	  (set! res (cons (vector id itempath state status run_duration logf comment) res)))
+	db
+	"SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE testname=? AND item_path != '' AND run_id=?;" ;; BUG! WHY NO run_id?
+	test-name
+	run-id)
+       res))))
+
+;;======================================================================
+;; Tests meta data
+;;======================================================================
+
+;; returns a hash table of tags to tests
+;;
+(define (db:get-tests-tags dbstruct)
+  (db:with-db
+   dbstruct #f #f
+   (lambda (db)
+     (let* ((res     (make-hash-table)))
+       (sqlite3:for-each-row
+	(lambda (testname tags-in)
+	  (let ((tags (string-split tags-in ",")))
+	    (for-each
+	     (lambda (tag)
+	       (hash-table-set! res tag
+				(delete-duplicates
+				 (cons testname (hash-table-ref/default res tag '())))))
+	     tags)))
+	db
+	"SELECT testname,tags FROM test_meta")
+       (hash-table->alist res)))))
+
+;; read the record given a testname
+(define (db:testmeta-get-record dbstruct testname)
+  (let ((res   #f))
+    (db:with-db
+     dbstruct
+     #f
+     #f
+     (lambda (db)
+       (sqlite3:for-each-row
+	(lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup)
+	  (set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup)))
+	db
+	"SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE testname=?;"
+	testname)
+       res))))
+
+;; create a new record for a given testname
+(define (db:testmeta-add-record dbstruct testname)
+  (db:with-db dbstruct #f #f 
+	      (lambda (db)
+		(sqlite3:execute 
+		 db
+		 "INSERT OR IGNORE INTO test_meta (testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags) VALUES (?,'','','','','','','','');" testname))))
+
+;; update one of the testmeta fields
+(define (db:testmeta-update-field dbstruct testname field value)
+  (db:with-db dbstruct #f #f 
+	      (lambda (db)
+		(sqlite3:execute 
+		 db
+		 (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname))))
+
+(define (db:testmeta-get-all dbstruct)
+  (db:with-db dbstruct #f #f 
+	      (lambda (db)
+		(let ((res '()))
+		  (sqlite3:for-each-row
+		   (lambda (a . b)
+		     (set! res (cons (apply vector a b) res)))
+		   db
+		   "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta;")
+		  res))))
+
+;;======================================================================
+;; M I S C   M A N A G E M E N T   I T E M S 
+;;======================================================================
+
+
+;; the new prereqs calculation, looks also at itempath if specified
+;; all prereqs must be met
+;;    if prereq test with itempath='' is COMPLETED and PASS, WARN, CHECK, or WAIVED then prereq is met
+;;    if prereq test with itempath=ref-item-path and COMPLETED with PASS, WARN, CHECK, or WAIVED then prereq is met
+;;
+;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK, SKIP or WAIVED)
+;;       mode 'toplevel means that tests must be COMPLETED only
+;;       mode 'itemmatch or 'itemwait means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]]
+;;       mode 'exclusive means this test/item cannot run if the same test/item is LAUNCHED,REMOTEHOSTSTART or RUNNING
+;;
+;; IDEA for consideration:
+;;    1. collect all tests "upstream"
+;;    2. any NOT completed and good? if yes => return those as prereqs not met, if no => return null list
 ;; 
-;; (define (set-functions dbgp dbgpinfo)
-;;   (set! debug:print dbgp)
-;;   (set! debug:print-info dbgpinfo))
+;; (define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path mode)
+(define (db:get-prereqs-not-met dbstruct run-id waitons ref-test-name ref-item-path mode itemmaps) ;; #!key (mode '(normal))(itemmap #f))
+  ;; BBnote - rollup of an itemized test's overall state/status done in db:set-state-status-and-roll-up-items
+  (append
+   (if (member 'exclusive mode)
+       (let ((running-tests (db:get-tests-for-run dbstruct
+						  #f  ;; run-id of #f means for all runs. 
+						  (if (string=? ref-item-path "")   ;; testpatt
+						      ref-test-name
+						      (conc ref-test-name "/" ref-item-path))
+						  '("LAUNCHED" "REMOTEHOSTSTART" "RUNNING") ;; states
+						  '()          ;; statuses
+						  #f           ;; offset
+						  #f           ;; limit
+						  #f           ;; not-in
+						  #f           ;; sort by
+						  #f           ;; sort order
+						  'shortlist   ;; query type
+						  0            ;; last update, beginning of time ....
+						  #f           ;; mode
+						  )))
+	;;(map (lambda (testdat)
+	;;	(if (equal? (db:test-get-item-path testdat) "")
+	;;	    (db:test-get-testname testdat)
+	;;	    (conc (db:test-get-testname testdat)
+	;;		  "/"
+	;;		  (db:test-get-item-path testdat))))
+	 running-tests) ;; calling functions want the entire data
+       '())
+
+   ;; collection of: for each waiton -
+   ;;   if this ref-test-name is an item in an itemized test and mode is itemwait/itemmatch:
+   ;;     if waiton is not itemized - if waiton is not both completed and in ok status, add as unmet prerequisite
+   ;;     if waiton is itemized:
+   ;;           and waiton's items are not expanded, add as unmet prerequisite
+   ;;           else if matching waiton item is not both completed and in an ok status, add as unmet prerequisite
+   ;;   else
+   ;;    if waiton toplevel is not in both completed and ok status, add as unmet prerequisite
+
+   (if (or (not waitons)
+	   (null? waitons))
+       '()
+       (let* ((ref-test-itemized-mode (not (null? (lset-intersection eq? mode '(itemmatch itemwait))))) ;; how is this different from using member?
+              (ref-test-toplevel-mode (not (null? (lset-intersection eq? mode '(toplevel)))))
+              (ref-test-is-toplevel   (equal? ref-item-path ""))
+              (ref-test-is-item       (not ref-test-is-toplevel))
+              (unmet-pre-reqs '())
+	      (result         '())
+              (unmet-prereq-items '())
+              )
+	 (for-each  ; waitons
+	  (lambda (waitontest-name)
+	    ;; by getting the tests with matching name we are looking only at the matching test 
+	    ;; and related sub items
+	    ;; next should be using mt:get-tests-for-run?
+
+            (let (;(waiton-is-itemized ...)
+                  ;(waiton-items-are-expanded ...)
+                  (waiton-tests             (db:get-tests-for-run-state-status dbstruct run-id waitontest-name))
+		  (ever-seen         #f)
+		  (parent-waiton-met #f)
+		  (item-waiton-met   #f)
+
+                  )
+	      (for-each ; test expanded from waiton
+	       (lambda (waiton-test) 
+		 (let* ((waiton-state             (db:test-get-state waiton-test))
+			(waiton-status            (db:test-get-status waiton-test))
+			(waiton-item-path         (db:test-get-item-path waiton-test)) ;; BB- this is the upstream itempath
+			(waiton-test-name         (db:test-get-testname waiton-test))
+                        (waiton-is-toplevel       (equal? waiton-item-path ""))
+                        (waiton-is-item           (not waiton-is-toplevel))
+			(waiton-is-completed      (member waiton-state  *common:ended-states*))
+			(waiton-is-running        (member waiton-state  *common:running-states*))
+			(waiton-is-killed         (member waiton-state  *common:badly-ended-states*))
+			(waiton-is-ok             (member waiton-status *common:well-ended-states*)) 
+			;;                                              testname-b    path-a    path-b
+			(same-itempath            (db:compare-itempaths ref-test-name waiton-item-path ref-item-path itemmaps)) ;; (equal? ref-item-path waiton-item-path)))
+			(real-ref-test-name       (car (string-split ref-test-name "/"))) ;; I THINK ref-test-name SHOULD NEVER HAVE THE ITEM_PATH!
+			(test-and-ref-are-same    (equal? real-ref-test-name waiton-test-name)))
+		   (debug:print 4 *default-log-port* "waiton-test-name " waiton-test-name " ref-test-name: " ref-test-name " test-and-ref-are-same: " test-and-ref-are-same)
+		   (set! ever-seen #t)
+                   ;;(BB> "***consider waiton "waiton-test"/"waiton-item-path"***")
+                   (cond
+                    ;; case 0 - toplevel of an itemized test, at least one item in prereq has completed
+                    ((and waiton-is-item ref-test-is-toplevel ref-test-itemized-mode waiton-is-completed)
+                     (set! parent-waiton-met #t))
+
+                    ;; case 1, non-item (parent test) is 
+		    ((and waiton-is-toplevel ;; this is the parent test of the waiton being examined
+			  waiton-is-completed
+                          ;;(BB> "cond1")
+			  (or waiton-is-ok ref-test-toplevel-mode)) ;;  itemmatch itemwait))))))
+		     (set! parent-waiton-met #t))
+		    ;; Special case for toplevel and KILLED
+		    ((and waiton-is-toplevel ;; this is the parent test
+			  waiton-is-killed
+			  (member 'toplevel mode))
+                     ;;(BB> "cond2")
+		     (set! parent-waiton-met #t))
+		    ;; For itemwait mode IFF the previous matching item is good the set parent-waiton-met
+                    ((and ref-test-itemized-mode ref-test-is-item same-itempath)
+                     ;;(BB> "cond3")
+		     (if (and waiton-is-completed (or waiton-is-ok ref-test-toplevel-mode)) 
+                         (set! item-waiton-met #t)
+                         (set! unmet-prereq-items (cons waiton-test unmet-prereq-items)))
+                     (if (and waiton-is-toplevel ;; if upstream rollup test is completed, parent-waiton-met is set
+			      (or waiton-is-completed waiton-is-running))
+			 (set! parent-waiton-met #t)))
+		    ;; normal checking of parent items, any parent or parent item not ok blocks running
+		    ((and waiton-is-completed
+			  (or waiton-is-ok 
+			      (member 'toplevel mode))              ;; toplevel does not block on FAIL
+			  (and waiton-is-ok (member 'itemmatch mode) ;; itemmatch blocks on not ok ;; TODO: THIS IS PROBABLY A BUG.  ITEMMATCH AND ITEMWAIT ARE SYNONYMS!! WHAT HAPPENED OT ITEMWAIT???
+                               ))
+                     ;;(BB> "cond4")
+		     (set! item-waiton-met #t))
+                    ((and waiton-is-completed waiton-is-ok same-itempath)
+                     ;;(BB> "cond5")
+                     (set! item-waiton-met #t))
+		    ((and waiton-is-completed waiton-is-ok test-and-ref-are-same) ;; probably from [waitons] table
+		     (set! item-waiton-met #t))
+                    (else
+                     #t
+                     ;;(BB> "condelse")
+                     ))))
+               waiton-tests)
+	      ;; both requirements, parent and item-waiton must be met to NOT add item to
+	      ;; prereq's not met list
+               ;; (BB>
+               ;;  "\n* waiton-tests           "waiton-tests
+               ;;  "\n* parent-waiton-met      "parent-waiton-met
+               ;;  "\n* item-waiton-met        "item-waiton-met
+               ;;  "\n* ever-seen              "ever-seen
+               ;;  "\n* ref-test-itemized-mode "ref-test-itemized-mode
+               ;;  "\n* unmet-prereq-items     "unmet-prereq-items
+               ;;  "\n* result (pre)           "result
+               ;;  "\n* ever-seen              "ever-seen
+               ;;  "\n")
+
+              (cond
+               ((and ref-test-itemized-mode ref-test-is-item (not (null? unmet-prereq-items)))
+                (set! result (append unmet-prereq-items result)))
+               ((not (or parent-waiton-met item-waiton-met))
+                (set! result (append (if (null? waiton-tests) (list waitontest-name) waiton-tests) result))) ;; appends the string if the full record is not available
+	      ;; if the test is not found then clearly the waiton is not met...
+	      ;; (if (not ever-seen)(set! result (cons waitontest-name result)))))
+               ((not ever-seen)
+                (set! result (append (if (null? waiton-tests)(list waitontest-name) waiton-tests) result))))))
+	  waitons)
+	 (delete-duplicates result)))))
+
+;;======================================================================
+;; To sync individual run
+;;======================================================================
+(define (db:get-run-record-ids dbstruct target run keynames test-patt)
+(let ((backcons (lambda (lst item)(cons item lst))))
+    (db:with-db
+     dbstruct #f #f 
+     (lambda (db)
+        (let* ((keystr (string-intersperse 
+		     (map (lambda (key val)
+			    (conc key " like '" val "'"))
+			  keynames 
+			  (string-split target "/"))
+		     " AND "))
+         (run-qry (conc "SELECT id FROM runs  WHERE " keystr  " and runname='" run"'"))
+         (test-qry (conc "SELECT id FROM tests WHERE run_id in (" run-qry ") and testname like '" test-patt "'")))
+         (print run-qry)
+         (print test-qry) 
+	 `((runs       . ,(sqlite3:fold-row backcons '() db run-qry))
+	   (tests      . ,(sqlite3:fold-row backcons '() db test-qry))
+	   (test_steps . ,(sqlite3:fold-row backcons '() db (conc "SELECT id FROM test_steps WHERE test_id in (" test-qry ")")))
+	   (test_data  . ,(sqlite3:fold-row backcons '() db (conc "SELECT id FROM test_data  WHERE test_id in (" test-qry ")" )))
+	   ))))))
+
+;;======================================================================
+;; Just for sync, procedures to make sync easy
+;;======================================================================
+
+;; get an alist of record ids changed since time since-time
+;;   '((runs . (1 2 3 ...))(steps . (5 6 7 ...) ...))
+;;
+(define (db:get-changed-record-ids dbstruct since-time)
+  ;; no transaction, allow the db to be accessed between the big queries
+  (let ((backcons (lambda (lst item)(cons item lst))))
+    (db:with-db
+     dbstruct #f #f 
+     (lambda (db)
+       `((runs       . ,(sqlite3:fold-row backcons '() db "SELECT id FROM runs  WHERE last_update>=?" since-time))
+	 (tests      . ,(sqlite3:fold-row backcons '() db "SELECT id FROM tests WHERE last_update>=?" since-time))
+	 (test_steps . ,(sqlite3:fold-row backcons '() db "SELECT id FROM test_steps WHERE last_update>=?" since-time))
+	 (test_data  . ,(sqlite3:fold-row backcons '() db "SELECT id FROM test_data  WHERE last_update>=?" since-time))
+	 ;; (test_meta  . ,(fold-row backcons '() db "SELECT id FROM test_meta  WHERE last_update>?" since-time))
+	 (run_stats  . ,(sqlite3:fold-row backcons '() db "SELECT id FROM run_stats  WHERE last_update>=?" since-time))
+	 )))))
+
+;;======================================================================
+;; Extract ods file from the db
+;;======================================================================
+
+;; NOT REWRITTEN YET!!!!!
+
+;; runspatt is a comma delimited list of run patterns
+;; keypatt-alist must contain *all* keys with an associated pattern: '( ("KEY1" "%") .. )
+(define (db:extract-ods-file dbstruct outputfile keypatt-alist runspatt pathmod)
+  (let* ((keysstr  (string-intersperse (map car keypatt-alist) ","))
+	 (keyqry   (string-intersperse (map (lambda (p)(conc (car p) " LIKE ? ")) keypatt-alist) " AND "))
+	 (numkeys  (length keypatt-alist))
+	 (test-ids '())
+	 (dbdat    (db:get-db dbstruct))
+	 (db       (db:dbdat-get-db dbdat))
+	 (windows  (and pathmod (substring-index "\\" pathmod)))
+	 (tempdir  (conc "/tmp/" (current-user-name) "/" runspatt "_" (random 10000) "_" (current-process-id)))
+	 (runsheader (append (list "Run Id" "Runname") ; 0 1
+			     (map car keypatt-alist)   ; + N = length keypatt-alist
+			     (list "Testname"          ; 2
+				   "Item Path"         ; 3 
+				   "Description"       ; 4 
+				   "State"             ; 5 
+				   "Status"            ; 6  
+				   "Final Log"         ; 7 
+				   "Run Duration"      ; 8 
+				   "When Run"          ; 9 
+				   "Tags"              ; 10
+				   "Run Owner"         ; 11
+				   "Comment"           ; 12
+				   "Author"            ; 13
+				   "Test Owner"        ; 14
+				   "Reviewed"          ; 15
+				   "Diskfree"          ; 16
+				   "Uname"             ; 17
+				   "Rundir"            ; 18
+				   "Host"              ; 19
+				   "Cpu Load"          ; 20
+				   )))
+	 (results (list runsheader))			 
+	 (testdata-header (list "Run Id" "Testname" "Item Path" "Category" "Variable" "Value" "Expected" "Tol" "Units" "Status" "Comment"))
+	 (mainqry (conc "SELECT
+              t.testname,r.id,runname," keysstr ",t.testname,
+              t.item_path,tm.description,t.state,t.status,
+              final_logf,run_duration, 
+              strftime('%m/%d/%Y %H:%M:%S',datetime(t.event_time,'unixepoch'),'localtime'),
+              tm.tags,r.owner,t.comment,
+              author,
+              tm.owner,reviewed,
+              diskfree,uname,rundir,
+              host,cpuload
+            FROM tests AS t JOIN runs AS r ON t.run_id=r.id JOIN test_meta AS tm ON tm.testname=t.testname
+            WHERE runname LIKE ? AND " keyqry ";")))
+    (debug:print 2 *default-log-port* "Using " tempdir " for constructing the ods file. keyqry: " keyqry " keystr: " keysstr " with keys: " (map cadr keypatt-alist)
+		 "\n      mainqry: " mainqry)
+    ;; "Expected Value"
+    ;; "Value Found"
+    ;; "Tolerance"
+    (apply sqlite3:for-each-row
+	   (lambda (test-id . b)
+	     (set! test-ids (cons test-id test-ids))   ;; test-id is now testname
+	     (set! results (append results ;; note, drop the test-id
+				   (list
+				    (if pathmod
+					(let* ((vb        (apply vector b))
+					       (keyvals   (let loop ((i    0)
+								     (res '()))
+							    (if (>= i numkeys)
+								res
+								(loop (+ i 1)
+								      (append res (list (vector-ref vb (+ i 2))))))))
+					       (runname   (vector-ref vb 1))
+					       (testname  (vector-ref vb (+  2 numkeys)))
+					       (item-path (vector-ref vb (+  3 numkeys)))
+					       (final-log (vector-ref vb (+  7 numkeys)))
+					       (run-dir   (vector-ref vb (+ 18 numkeys)))
+					       (log-fpath (conc run-dir "/"  final-log))) ;; (string-intersperse keyvals "/") "/" testname "/" item-path "/"
+					  (debug:print 4 *default-log-port* "log: " log-fpath " exists: " (common:file-exists? log-fpath))
+					  (vector-set! vb (+ 7 numkeys) (if (common:file-exists? log-fpath)
+									    (let ((newpath (conc pathmod "/"
+												 (string-intersperse keyvals "/")
+												 "/" runname "/" testname "/"
+												 (if (string=? item-path "") "" (conc "/" item-path))
+												 final-log)))
+									      ;; for now throw away newpath and use the log-fpath conc'd with pathmod
+									      (set! newpath (conc pathmod log-fpath))
+									      (if windows (string-translate newpath "/" "\\") newpath))
+									    (if (debug:debug-mode 1)
+										(conc final-log " not-found")
+										"")))
+					  (vector->list vb))
+					b)))))
+	   db
+	   mainqry
+	   runspatt (map cadr keypatt-alist))
+    (debug:print 2 *default-log-port* "Found " (length test-ids) " records")
+    (set! results (list (cons "Runs" results)))
+    ;; now, for each test, collect the test_data info and add a new sheet
+    (for-each
+     (lambda (test-id)
+       (let ((test-data (list testdata-header))
+	     (curr-test-name #f))
+	 (sqlite3:for-each-row
+	  (lambda (run-id testname item-path category variable value expected tol units status comment)
+	    (set! curr-test-name testname)
+	    (set! test-data (append test-data (list (list run-id testname item-path category variable value expected tol units status comment)))))
+	  db 
+	  ;; "SELECT run_id,testname,item_path,category,variable,td.value AS value,expected,tol,units,td.status AS status,td.comment AS comment FROM test_data AS td INNER JOIN tests ON tests.id=td.test_id WHERE test_id=?;"
+	  "SELECT run_id,testname,item_path,category,variable,td.value AS value,td.expected,td.tol,td.units,td.status AS status,td.comment AS comment FROM test_data AS td INNER JOIN tests ON tests.id=td.test_id WHERE testname=?;"
+	  test-id)
+	 (if curr-test-name
+	     (set! results (append results (list (cons curr-test-name test-data)))))
+	 ))
+     (sort (delete-duplicates test-ids) string<=))
+    (system (conc "mkdir -p " tempdir))
+    ;; (pp results)
+    (ods:list->ods 
+     tempdir
+     (if (string-match (regexp "^[/~]+.*") outputfile) ;; full path?
+	 outputfile
+	 (begin
+	   (debug:print 0 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory")
+	   (conc (current-directory) "/" outputfile)))
+     results)
+    ;; brutal clean up
+    (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)
+    (system "rm -rf tempdir")))
+
+;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%")
+
+;;======================================================================
+;; mt routines that fit moved here
+;;======================================================================
+
+;;======================================================================
+;;  T R I G G E R S
+;;======================================================================
+
+(define (mt:run-trigger cmd test-id test-rundir trigger logname test-name item-path event-time actual-state actual-status)
+  ;; Putting the commandline into ( )'s means no control over the shell. 
+  ;; stdout and stderr will be caught in the NBFAKE or mt_launch.log files
+  ;; or equivalent. No need to do this. Just run it?
+  (let* ((fullcmd (conc "nbfake "
+			cmd           " "
+			test-id       " "
+			test-rundir   " "
+			trigger       " "
+			test-name     " "
+			item-path     " " ;; has / prepended to deal with toplevel tests
+			actual-state  " "
+			actual-status " "
+			event-time
+			))
+	 (prev-nbfake-log (get-environment-variable "NBFAKE_LOG")))
+    (setenv "NBFAKE_LOG" (conc (cond
+				((and (directory-exists? test-rundir)
+				      (file-write-access? test-rundir))
+				 test-rundir)
+				((and (directory-exists? *toppath*)
+				      (file-write-access? *toppath*))
+				 *toppath*)
+				(else (conc "/tmp/" (current-user-name))))
+			       "/" logname))
+    (debug:print-info 0 *default-log-port* "TRIGGERED on " trigger ", running command " fullcmd " output at " (get-environment-variable "NBFAKE_LOG"))
+    ;; (call-with-environment-variables
+    ;;  `(("NBFAKE_LOG" . ,(conc test-rundir "/" logname)))
+    ;;  (lambda ()
+    (process-run fullcmd)
+    (if prev-nbfake-log
+	(setenv "NBFAKE_LOG" prev-nbfake-log)
+	(unsetenv "NBFAKE_LOG"))
+    )) ;; ))
+
+;; is dbdir writeable and or is dbdir/dbname writeable
+;;
+(define (db:writeable dbdir dbname)
+  (let* ((dbfile (conc dbdir "/" dbname)))
+    (if (file-exists? dbfile)
+	(file-write-access? dbfile)
+	(file-write-access? *toppath*))))
+
+;;======================================================================the end
 
 )

Index: dcommon.scm
==================================================================
--- dcommon.scm
+++ dcommon.scm
@@ -27,10 +27,26 @@
 
 (declare (unit dcommon))
 
 (declare (uses gutils))
 (declare (uses db))
+
+(declare (uses commonmod))
+(import commonmod)
+
+(declare (uses dbmod))
+(import dbmod)
+
+(declare (uses configfmod))
+(import configfmod)
+
+(declare (uses dcommonmod))
+(import dcommonmod)
+
+(declare (uses servermod))
+(import servermod)
+
 ;; (declare (uses synchash))
 
 (include "megatest-version.scm")
 (include "common_records.scm")
 (include "db_records.scm")

ADDED   dcommonmod.scm
Index: dcommonmod.scm
==================================================================
--- /dev/null
+++ dcommonmod.scm
@@ -0,0 +1,450 @@
+;;======================================================================
+;; Copyright 2017, Matthew Welland.
+;; 
+;; This file is part of Megatest.
+;; 
+;;     Megatest is free software: you can redistribute it and/or modify
+;;     it under the terms of the GNU General Public License as published by
+;;     the Free Software Foundation, either version 3 of the License, or
+;;     (at your option) any later version.
+;; 
+;;     Megatest is distributed in the hope that it will be useful,
+;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;     GNU General Public License for more details.
+;; 
+;;     You should have received a copy of the GNU General Public License
+;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
+
+;;======================================================================
+
+(declare (unit dcommonmod))
+(declare (uses commonmod))
+(declare (uses configfmod))
+
+(module dcommonmod
+	*
+	
+(import scheme chicken data-structures extras ports)
+(use
+ (prefix iup iup:)
+ canvas-draw
+ (prefix sqlite3 sqlite3:)
+ posix
+ typed-records
+ srfi-18
+ srfi-69
+ matchable
+ sparse-vectors
+ srfi-1
+ regex
+ srfi-13
+ )
+(import canvas-draw-iup)
+
+(import commonmod)
+(import configfmod)
+
+(include "common_records.scm")
+
+;;======================================================================
+;; T R E E   S T U F F 
+;;======================================================================
+
+;; path is a list of nodes, each the child of the previous
+;; this routine returns the id so another node can be added
+;; either as a leaf or as a branch
+;;
+;; BUG: This needs a stop sensor for when a branch is exhausted
+;;
+(define (tree:find-node obj path)
+  ;; start at the base of the tree
+  (if (null? path)
+      #f ;; or 0 ????
+      (let loop ((hed      (car path))
+		 (tal      (cdr path))
+		 (depth    0)
+		 (nodenum  0))
+	;; nodes in iup tree are 100% sequential so iterate over nodenum
+	(if (iup:attribute obj (conc "DEPTH" nodenum)) ;; end when no more nodes
+	    (let ((node-depth (string->number (iup:attribute obj (conc "DEPTH" nodenum))))
+		  (node-title (iup:attribute obj (conc "TITLE" nodenum))))
+	      (if (and (equal? depth node-depth)
+		       (equal? hed   node-title)) ;; yep, this is the one!
+		  (if (null? tal) ;; end of the line
+		      nodenum
+		      (loop (car tal)(cdr tal)(+ depth 1)(+ 1 nodenum)))
+		  ;; this is the case where we found part of the hierarchy but not 
+		  ;; all of it, i.e. the node-depth went from deep to less deep
+		  (if (> depth node-depth) ;; (+ 1 node-depth))
+		      #f
+		      (loop hed tal depth (+ nodenum 1)))))
+	    #f))))
+
+;; top is the top node name zeroeth node VALUE=0
+(define (tree:add-node obj top nodelst #!key (userdata #f))
+  (let ((curr-top (iup:attribute obj "TITLE0")))
+    (if (or (not (string? curr-top))
+	    (string-null? curr-top)
+	    (string-match "^\\s*$" curr-top))
+          (iup:attribute-set! obj "ADDBRANCH0" top))
+
+
+    
+    (cond
+     ((not (equal? top (iup:attribute obj "TITLE0")))
+      (print "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0")))
+     ((null? nodelst))
+     (else
+      (let loop ((hed      (car nodelst))
+		 (tal      (cdr nodelst))
+		 (depth    1)
+		 (pathl    (list top)))
+	;; Because the tree dialog changes node numbers when
+	;; nodes are added or removed we must look up nodes
+	;; each and every time. 0 is the top node so default
+	;; to that.
+	(let* ((newpath    (append pathl (list hed)))
+	       (parentnode (tree:find-node obj pathl))
+	       (nodenum    (tree:find-node obj newpath)))
+	  ;; Add the branch under lastnode if not found
+	  (if (not nodenum)
+	      (begin
+		(iup:attribute-set! obj (conc "ADDBRANCH" parentnode) hed)
+		;; ERROR? ADDING DATA TO PARENT, DONT WE WANT IT ON CREATED NODE?
+		(if userdata
+		    (iup:attribute-set! obj (conc "USERDATA"   parentnode) userdata))
+		(if (null? tal)
+		    #t
+		    ;; reset to top
+		    (loop (car nodelst)(cdr nodelst) 1 (list top)))) 
+	      (if (null? tal) ;; if null here then this path has already been added
+		  #t
+		  (loop (car tal)(cdr tal)(+ depth 1) newpath)))))))))
+
+(define (tree:node->path obj nodenum)
+  (let loop ((currnode 0)
+	     (path     '()))
+    (let* ((node-depth (string->number (iup:attribute obj (conc "DEPTH" currnode))))
+	   (node-title (iup:attribute obj (conc "TITLE" currnode)))
+	   (trimpath   (if (and (not (null? path))
+				(> (length path) node-depth))
+			   (take path node-depth)
+			   path))
+	   (newpath    (append trimpath (list node-title))))
+      (if (>= currnode nodenum)
+	  newpath
+	  (loop (+ currnode 1)
+		newpath)))))
+
+(define (tree:delete-node obj top node-path) ;; node-path is a list of strings
+  (let ((id  (tree:find-node obj (cons top node-path))))
+    (print "Found node to remove " id " for path " top " " node-path)
+    (iup:attribute-set! obj (conc "DELNODE" id) "SELECTED")))
+	
+#|
+
+  (let* ((tb      (iup:treebox
+                   #:value 0
+                   #:name "Runs"
+                   #:expand "YES"
+                   #:addexpanded "NO"
+                   #:selection-cb
+                   (lambda (obj id state)
+                     ;; (print "obj: " obj ", id: " id ", state: " state)
+                     (let* ((run-path (tree:node->path obj id))
+                            (run-id   (tree-path->run-id (cdr run-path))))
+                       (if run-id
+                           (begin
+                             (dboard:data-curr-run-id-set! data run-id)
+                             (dashboard:update-run-summary-tab)))
+                       ;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
+                       ))))
+|#
+
+(define (tree-path->run-id tabdat path)
+  (if (not (null? path))
+      (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) path #f)
+      #f))
+
+(define (new-tree-path->run-id rdat path)
+  (if (not (null? path))
+      (hash-table-ref/default(dboard:rdat-targ-runid rdat) path #f)
+       ;; 
+      #f))
+
+
+;;======================================================================
+;; COMMONDAT
+;;======================================================================
+
+;; for the new runs view lets build up a few new record types and then consolidate later
+;;
+;; this is a two level deep pipeline for the incoming data:
+;;   sql query data ==> filters ==> data for display
+;;
+(defstruct dboard:rdat
+  ;; view related items
+  (runnum    0) ;; which column we are processing, index into runsbynum, we sweep across all these runs then start over
+  (leftcol   0) ;; number of the leftmost visible column
+  (toprow    0) ;; topmost visible row
+  (numcols  24) ;; number of columns visible
+  (numrows  20) ;; number of rows visible
+  
+  ;; efactored  <=== merge detritus
+  (runs       (make-sparse-vector #f))  ;; id => runrec
+  (run-tests  (make-sparse-vector '())) ;; id => list of tests
+  (runsbynum  (make-vector 100 #f))     ;; vector num => runrec
+  (rownames   (make-hash-table))        ;; testname => rownum
+  (targ-runid (make-hash-table))        ;; area/target/runname => run-id  ;; not sure this will be needed
+  (tests      (make-hash-table))        ;; test[/itempath] => list of test rec
+
+  ;; run sql filters 
+  (targ-sql-filt        "%")
+  (runname-sql-filt     "%")
+  (run-state-sql-filt   "%")
+  (run-status-sql-filt  "%")
+
+  ;; test sql filter
+  (testname-sql-filt    "%")
+  (itempath-sql-filt    "%")
+  (test-state-sql-filt  "%")
+  (test-status-sql-filt "%")
+
+  ;; other sql related fields
+  (last-updates (make-sparse-vector 0))  ;; run-id -> timestamp of the last update from sql db, set to zero on any field changes
+
+  ;; filtered data
+  (cols  (make-sparse-vector))   ;; columnnum => run-id
+  (tests (make-hash-table))      ;; test[/itempath] => (vector columnnum => test rec)
+
+  ;; various
+  (prev-run-ids  '())            ;; push previously looked at runs on this
+  (view-changed #f)
+
+  ;; widgets
+  (runs-tree #f)                 ;;
+  (runs-mtx  #f)                 ;; runs displayed here
+  (items-mtx #f)                 ;; items displayed here
+  ;; info widgets here
+  )
+
+(define (dboard:rdat-push-run-id rdat run-id)
+  (dboard:rdat-prev-run-ids-set! rdat (cons run-id (dboard:rdat-prev-run-ids rdat))))
+
+(defstruct dboard:runrec
+  id
+  target  ;; a/b/c...
+  tdef    ;; for future use
+  )
+     
+(defstruct dboard:testrec
+  id
+  runid
+  testname  ;; test[/itempath]
+  state
+  status
+  start-time
+  duration
+  )
+
+
+(define (dboard:rundat-make-init #!key (run #f)(key-vals #f)(tests #f));; -100 is before time began
+  (make-dboard:rundat 
+   run: run
+   tests: (or tests (make-hash-table))
+   key-vals: key-vals 
+   )) 
+
+(defstruct dboard:testdat
+  id       ;; testid
+  state    ;; test state
+  status   ;; test status
+  )
+
+
+
+
+
+;; data common to all tabs goes here
+;;
+(defstruct dboard:commondat
+  ((curr-tab-num 0) : number)
+  please-update  
+  tabdats
+  update-mutex
+  updaters 
+  updating
+  uidat ;; needs to move to tabdat at some time
+  hide-not-hide-tabs
+  )
+
+(define (dboard:commondat-make)
+  (make-dboard:commondat
+   curr-tab-num:         0
+   tabdats:              (make-hash-table)
+   please-update:        #t
+   update-mutex:         (make-mutex)
+   updaters:             (make-hash-table)
+   updating:             #f
+   hide-not-hide-tabs:   #f
+   ))
+
+;;======================================================================
+;; TABDAT
+;;======================================================================
+
+;; data for each specific tab goes here
+;;
+(defstruct dboard:tabdat 
+  ;; runs
+  ((allruns         '())                 : list)        ;; list of dboard:rundat records
+  ((allruns-by-id    (make-hash-table))  : hash-table)  ;; hash of run-id -> dboard:rundat records
+  ((done-runs       '())                 : list)        ;; list of runs already drawn
+  ((not-done-runs   '())                 : list)        ;; list of runs not yet drawn
+  (header            #f)                                ;; header for decoding the run records
+  (keys              #f)                                ;; keys for this run (i.e. target components)
+  ((numruns          8)                  : number) 
+  ((tot-runs          0)                 : number)
+  ((last-data-update  0)                 : number)      ;; last time the data in allruns was updated
+  ((last-runs-update  0)                 : number)      ;; last time we pulled the runs info to update the tree
+  (runs-mutex         (make-mutex))                     ;; use to prevent parallel access to draw objects
+  ((run-update-times  (make-hash-table)) : hash-table)  ;; update times indexed by run-id
+  ((last-test-dat      (make-hash-table)) : hash-table)  ;; cache last tests dat by run-id
+  ((run-db-paths      (make-hash-table)) : hash-table)  ;; cache the paths to the run db files
+
+  ;; Runs view
+  ((buttondat         (make-hash-table)) : hash-table)  ;;     
+  ((item-test-names  '())                : list)        ;; list of itemized tests
+  ((run-keys          (make-hash-table)) : hash-table)
+  (runs-matrix        #f)                               ;; used in newdashboard
+  ((start-run-offset   0)                : number)      ;; left-right slider value
+  ((start-test-offset  0)                : number)      ;; up-down slider value
+  ((runs-btn-height     "x16") : string) ;; (or (configf:lookup *configdat* "dashboard" "btn-height") "x16")) : string)  ;; was 12
+  ((runs-btn-fontsz     "10")  : string) ;; (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10")) : string)   ;; was 8
+  ((runs-cell-width     "50")  : string) ;; (or (configf:lookup *configdat* "dashboard" "cell-width") "50")) : string)   ;; was 50
+  ((all-test-names     '())              : list)
+  
+  ;; Canvas and drawing data
+  (cnv                #f)
+  (cnv-obj            #f)
+  (drawing            #f)
+  ((run-start-row     0)                 : number)
+  ((max-row           0)                 : number)
+  ((running-layout    #f)                : boolean)
+  (originx            #f)
+  (originy            #f)
+  ((layout-update-ok  #t)                : boolean)
+  ((compact-layout    #t)                : boolean)
+
+  ;; Run times layout
+  ;; (graph-button-box #f) ;; RA => Think it is not referenced anywhere
+  (graph-matrix     #f)
+  ((graph-matrix-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru graph name info
+  ((graph-cell-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru matrix cell info
+  ((graph-matrix-row 1) : number)
+  ((graph-matrix-col 1) : number)
+
+  ;; Controls used to launch runs etc.
+  ((command          "")                 : string)      ;; for run control this is the command being built up
+  (command-tb        #f)	                        ;; widget for the type of command; run, remove-runs etc.
+  (test-patterns-textbox #f)                            ;; text box widget for editing a list of test patterns
+  (key-listboxes     #f)			         
+  (key-lbs           #f)			         
+  run-name                                              ;; from run name setting widget
+  states                                                ;; states for -state s1,s2 ...
+  statuses                                              ;; statuses for -status s1,s2 ...
+						         
+  ;; Selector variables				         
+  curr-run-id                                           ;; current row to display in Run summary view
+  prev-run-id                                           ;; previous runid selected before current runid was selected (used in xor-two-runs runs summary mode
+  curr-test-ids                                         ;; used only in dcommon:run-update which is used in newdashboard
+  ((filters-changed  #t)                  : boolean)    ;; to indicate that the user changed filters for this tab
+  ((last-filter-str  "")                  : string)      ;; conc the target runname and testpatt for a signature of changed filters
+  ((hide-empty-runs  #f)                  : boolean)     
+  ((hide-not-hide    #t)                  : boolean)     ;; toggle for hide/not hide empty runs
+  (hide-not-hide-button #f)
+  ((searchpatts        (make-hash-table)) : hash-table)  ;;
+  ((state-ignore-hash  (make-hash-table)) : hash-table)  ;; hash of  STATE => #t/#f for display control
+  ((status-ignore-hash (make-hash-table)) : hash-table)  ;; hash of STATUS => #t/#f
+  (target              #f)
+  (test-patts          #f)
+
+  ;; db info to file the .db files for the area
+  (access-mode         #f)
+  (dbdir               #f)
+  (dbfpath             #f)
+  (dbkeys              #f)
+  ((last-db-update     (make-hash-table)) : hash-table) ;; last db file timestamp
+  (monitor-db-path     #f)                              ;; where to find monitor.db
+  ro                                                    ;; is the database read-only?
+
+  ;; tests data
+  ((num-tests          10)               : number)      ;; total number of tests to show (used in the old runs display)
+
+  ;; runs tree
+  ((path-run-ids       (make-hash-table)) : hash-table) ;; path (target / runname) => id
+  (runs-tree           #f)
+  ((runs-tree-ht       (make-hash-table)) : hash-table) ;; track which targets added to tree (merge functionality with path-run-ids?)
+
+  ;; tab data
+  ((view-changed       #t)                : boolean)   
+  ((xadj               0)                 : number)     ;; x slider number (if using canvas)
+  ((yadj               0)                 : number)     ;; y slider number (if using canvas)
+  ;; runs-summary tab state
+  ((runs-summary-modes '((one-run . "Show One Run") (xor-two-runs . "XOR Two Runs") (xor-two-runs-hide-clean . "XOR; Hide Clean")) )   : list)
+  ((runs-summary-mode-buttons '())               : list)
+  ((runs-summary-mode  'one-run)            : symbol)
+  ((runs-summary-mode-change-callbacks '()) : list)
+  (runs-summary-source-runname-label #f)
+  (runs-summary-dest-runname-label #f)
+  ;; runs summary view
+  
+  tests-tree       ;; used in newdashboard
+  )
+
+;;======================================================================
+;; GRAPHDAT
+;;======================================================================
+
+;; RADT => Matrix defstruct addition
+(defstruct dboard:graph-dat
+    ((id           #f) : string)
+    ((color        #f) : vector)
+    ((flag         #t) : boolean)
+    ((cell         #f) : number)
+    )
+
+;;======================================================================
+;; RUNSDAT
+;;======================================================================
+
+;; data for runs, tests etc. was used in run summary?
+;;
+(defstruct dboard:runsdat
+  ;; new system
+  runs-index    ;; target/runname => colnum
+  tests-index   ;; testname/itempath => rownum
+  matrix-dat    ;; vector of vectors rows/cols
+  )
+
+;; used to keep the rundata from rmt:get-tests-for-run
+;; in sync. 
+;;
+(defstruct dboard:rundat
+  run
+  tests-drawn    ;; list of id's already drawn on screen
+  tests-notdrawn ;; list of id's NOT already drawn
+  rowsused       ;; hash of lists covering what areas used - replace with quadtree
+  hierdat        ;; put hierarchial sorted list here
+  tests          ;; hash of id => testdat
+  ((tests-by-name (make-hash-table)) : hash-table) ;; hash of testfullname => testdat
+  key-vals
+  ((last-update   0)                 : number)    ;; last query to db got records from before last-update
+  ((last-db-time  0)                 : number)    ;; last timestamp on megatest.db
+  ((data-changed  #f)                : boolean)   
+  ((run-data-offset  0)              : number)      ;; get only 100 items per call, set back to zero when received less than 100 items
+  (db-path #f))
+
+;;======================================================================the end
+)

Index: diff-report.scm
==================================================================
--- diff-report.scm
+++ diff-report.scm
@@ -18,10 +18,13 @@
 
 (declare (unit diff-report))
 (declare (uses common))
 (declare (uses rmt))
          
+(declare (uses commonmod))
+(import commonmod)
+
 (include "common_records.scm")
 (use matchable)
 (use fmt)
 (use ducttape-lib)
 (define css "")

Index: docs/manual/Makefile
==================================================================
--- docs/manual/Makefile
+++ docs/manual/Makefile
@@ -34,13 +34,16 @@
 
 megatest_manual.html : megatest_manual.txt  *.txt installation.txt *png
 	asciidoc  -b html5 -a icons -a iconsdir=$(DISPATH)/images/icons -a toc2 megatest_manual.txt
 #	dos2unix megatest_manual.html
 
-megatest_manual.pdf : megatest_manual.txt *.txt *png
+megatest_manual.pdf : megatest_manual.txt *.txt *png *.ps
 	a2x -a toc -f pdf megatest_manual.txt
 
+server.pdf : server.dot
+	dot -Tpdf server.dot > server.pdf
+
 server.ps : server.dot
 	dot -Tps server.dot > server.ps
 
 client.ps : client.dot
 	dot -Tps client.dot > client.ps

Index: docs/manual/megatest_manual.html
==================================================================
--- docs/manual/megatest_manual.html
+++ docs/manual/megatest_manual.html
@@ -1,10 +1,10 @@
 <!DOCTYPE html>
 <html lang="en">
 <head>
 <meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
-<meta name="generator" content="AsciiDoc 8.6.7">
+<meta name="generator" content="AsciiDoc 8.6.10">
 <title>The Megatest Users Manual</title>
 <style type="text/css">
 /* Shared CSS for AsciiDoc xhtml11 and html5 backends */
 
 /* Default font. */
@@ -84,14 +84,20 @@
   margin-top: 0;
 }
 ul > li     { color: #aaa; }
 ul > li > * { color: black; }
 
-pre {
+.monospaced, code, pre {
+  font-family: "Courier New", Courier, monospace;
+  font-size: inherit;
+  color: navy;
   padding: 0;
   margin: 0;
 }
+pre {
+  white-space: pre-wrap;
+}
 
 #author {
   color: #527bbd;
   font-weight: bold;
   font-size: 1.1em;
@@ -216,11 +222,11 @@
   border-left: 3px solid #dddddd;
   padding-left: 0.5em;
 }
 
 div.imageblock div.content { padding-left: 0; }
-span.image img { border-style: none; }
+span.image img { border-style: none; vertical-align: text-bottom; }
 a.image:visited { color: white; }
 
 dl {
   margin-top: 0.8em;
   margin-bottom: 0.8em;
@@ -412,16 +418,10 @@
 /*
  * xhtml11 specific
  *
  * */
 
-tt {
-  font-family: "Courier New", Courier, monospace;
-  font-size: inherit;
-  color: navy;
-}
-
 div.tableblock {
   margin-top: 1.0em;
   margin-bottom: 1.5em;
 }
 div.tableblock > table {
@@ -451,16 +451,10 @@
 /*
  * html5 specific
  *
  * */
 
-.monospaced {
-  font-family: "Courier New", Courier, monospace;
-  font-size: inherit;
-  color: navy;
-}
-
 table.tableblock {
   margin-top: 1.0em;
   margin-bottom: 1.5em;
 }
 thead, p.tableblock.header {
@@ -536,10 +530,12 @@
 }
 
 @media print {
   body.manpage div#toc { display: none; }
 }
+
+
 @media screen {
   body {
     max-width: 50em; /* approximately 80 characters wide */
     margin-left: 16em;
   }
@@ -2340,11 +2336,11 @@
 <div class="sect2">
 <h3 id="_trim_trailing_spaces">Trim trailing spaces</h3>
 <div class="admonitionblock">
 <table><tr>
 <td class="icon">
-<img src="/nfs/pdx/disks/ice.disk.002/icfadm/pkgs/asciidoc/8.6.7/images/icons/note.png" alt="Note">
+<img src="/usr/images/icons/note.png" alt="Note">
 </td>
 <td class="content">As of Megatest version v1.6548 trim-trailing-spaces defaults to yes.</td>
 </tr></table>
 </div>
 <div class="listingblock">
@@ -2642,11 +2638,11 @@
 waiton test1 test2</pre>
 </div></div>
 <div class="admonitionblock">
 <table><tr>
 <td class="icon">
-<img src="/nfs/pdx/disks/ice.disk.002/icfadm/pkgs/asciidoc/8.6.7/images/icons/note.png" alt="Note">
+<img src="/usr/images/icons/note.png" alt="Note">
 </td>
 <td class="content">Dynamic waiton lists must be capable of being calculated at the
 beginning of a run. This is because Megatest walks the tree of waitons
 to create the list of tests to execute.</td>
 </tr></table>
@@ -3147,11 +3143,11 @@
 COMPLETED/ xterm -e bash -s --</pre>
 </div></div>
 <div class="admonitionblock">
 <table><tr>
 <td class="icon">
-<img src="/nfs/pdx/disks/ice.disk.002/icfadm/pkgs/asciidoc/8.6.7/images/icons/note.png" alt="Note">
+<img src="/usr/images/icons/note.png" alt="Note">
 </td>
 <td class="content">There is a trailing space after the double-dash</td>
 </tr></table>
 </div>
 <div class="paragraph"><p>There are a number of environment variables available to the trigger script
@@ -3484,10 +3480,11 @@
 </div>
 <div id="footnotes"><hr></div>
 <div id="footer">
 <div id="footer-text">
 Version 1.5<br>
-Last updated 2020-09-08 08:39:29 PDT
+Last updated
+ 2021-01-25 11:33:16 MST
 </div>
 </div>
 </body>
 </html>

Index: docs/manual/server.dot
==================================================================
--- docs/manual/server.dot
+++ docs/manual/server.dot
@@ -14,65 +14,71 @@
 // 
 //     You should have received a copy of the GNU General Public License
 //     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
 digraph G {
 
-    subgraph cluster_1 {
-        node [style=filled,shape=box];
-
-	check_available_queue       -> remove_entries_over_10s_old;
-	remove_entries_over_10s_old -> set_available [label="num_avail < 3"];
-	remove_entries_over_10s_old -> exit [label="num_avail > 2"];
-
-	set_available               -> delay_2s;
-	delay_2s          -> check_place_in_queue;
-
-	check_place_in_queue        -> "http:transport-launch" [label="at head"];
-	check_place_in_queue        -> exit [label="not at head"];
-
-	"client:login"              -> "server:shutdown" [label="login failed"];
-	"server:shutdown"           -> exit;	
-
-	subgraph cluster_2 {
-		"http:transport-launch"       -> "http:transport-run";
-		"http:transport-launch"       -> "http:transport-keep-running";
-
-		"http:transport-keep-running" -> "tests running?";
-		"tests running?"              -> "client:login" [label=yes];
-		"tests running?"              -> "server:shutdown" [label=no];
-		"client:login"                -> delay_5s [label="login ok"];
-		delay_5s                      -> "http:transport-keep-running";
-	}
-
-	// start_server -> "server_running?";
-	// "server_running?" -> set_available [label="no"];
-	// "server_running?" -> delay_2s [label="yes"];
-	// delay_2s -> "still_running?";
-	// "still_running?" -> ping_server [label=yes];
-	// "still_running?" -> set_available [label=no];
-	// ping_server -> exit [label=alive];
-	// ping_server -> remove_server_record [label=dead];
-	// remove_server_record -> set_available;
-	// set_available -> avail_delay [label="delay 3s"];
-	// avail_delay -> "first_in_queue?";
-	// 
-	// "first_in_queue?" -> set_running [label=yes];
-	// set_running -> get_next_port -> handle_requests;
-	// "first_in_queue?" -> "dead_entry_in_queue?" [label=no];
-	// "dead_entry_in_queue?" -> "server_running?" [label=no];
-	// "dead_entry_in_queue?" -> "remove_dead_entries" [label=yes];
-	// remove_dead_entries -> "server_running?";
-	// 
-	// handle_requests -> start_shutdown [label="no traffic\nno running tests"];
-	// handle_requests -> shutdown_request;
-	// start_shutdown -> shutdown_delay;
-	// shutdown_request -> shutdown_delay;
-	// shutdown_delay -> exit;
-	
-        label = "server:launch";
-        color=brown;
-    }
-
-//     client_start_server -> start_server;
-//     handle_requests -> read_write;
-//     read_write -> handle_requests;
+  // connecting to server
+  subgraph cluster_1 {
+    label="Connect";
+    
+    node [style=filled,shape=box];
+    dotserver [label="Have .server file?"];
+    connect [label="Connect to server"];
+    // startserver [label="Start Server"];
+    connected [label="Connection Successful"];
+    anylive [label="Any live servers?"];
+    askstart [label="Ask existing server to start a new server"];
+    anydboard [label="Any live dashboards"];
+    askdboard [label="Ask dashboard to start server"];
+    serverlaunch [label="User server launch to start server process"];
+    wait5sec [label="Wait 5 seconds"];
+  
+    dotserver -> connect [label="yes"];
+    connect -> connected [label="yes"];
+    connect -> anylive [label="no"];
+
+    // startserver -> anylive;
+    anylive -> askstart [label="yes"];
+    anylive -> anydboard [label="no"];
+    anydboard -> askdboard [label="yes"];
+    anydboard -> serverlaunch [label="no"];
+    serverlaunch -> wait5sec;
+    askdboard -> wait5sec;
+    askstart -> wait5sec;
+    wait5sec -> dotserver;
+
+  }
+
+  // server bootstrap
+  subgraph cluster_2 {
+    label="Startup";
+    node [style=filled,shape=box];
+    getlock [label="Get file lock"];
+    starthttpcpdb [label="Start http server/copy db to /tmp"];
+    createsrvfile [label="Create .nnn.server file containing host:port"];
+    releaselock [label="Release file lock"];
+    chksrv [label="Check if server already exists"];
+    exitstartup [label="exit/stop"];
+    sleep1 [label="Sleep few seconds"];
+  
+    getlock -> starthttpcpdb [label="yes"];
+    getlock -> chksrv [label="no"];
+    starthttpcpdb -> createsrvfile -> releaselock;
+    chksrv -> exitstartup [label="yes"];
+    chksrv -> sleep1 [label="no"];
+    sleep1 -> getlock;
+  }
+
+  // shutting down server
+  subgraph cluster_3 {
+    label="Shutdown";
+    node [style=filled,shape=box];
+    shutdown [label="Start Shutdown"];
+    rejectmode [label="Put http server into reject requests mode"];
+    syncback [label="Sync db back"];
+    removesrvfile [label="Remove server file containing host:port"];
+    exit [label="Exit process"];
+   
+    shutdown -> rejectmode -> syncback -> removesrvfile -> exit;
+  }
+ 
 }

Index: docs/manual/server.png
==================================================================
--- docs/manual/server.png
+++ docs/manual/server.png
cannot compute difference between binary files

Index: env.scm
==================================================================
--- env.scm
+++ env.scm
@@ -17,10 +17,13 @@
 ;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
 
 ;;======================================================================
 
 (declare (unit env))
+
+(declare (uses commonmod))
+(import commonmod)
 
 (use sql-de-lite) ;; srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables)
 
 (define (env:open-db fname)
   (let* ((db-exists (common:file-exists? fname))

Index: ezsteps.scm
==================================================================
--- ezsteps.scm
+++ ezsteps.scm
@@ -27,24 +27,94 @@
 (declare (uses common))
 (declare (uses items))
 (declare (uses runconfig))
 ;; (declare (uses sdb))
 ;; (declare (uses filedb))
+
+(declare (uses commonmod))
+(import commonmod)
+
+(declare (uses configfmod))
+(import configfmod)
+
+(declare (uses dbmod))
+(import dbmod)
 
 (include "common_records.scm")
 (include "key_records.scm")
 (include "db_records.scm")
 (include "run_records.scm")
 
 
-;;(rmt:get-test-info-by-id run-id test-id) -> testdat
+(define (ezsteps:step-name->mode stepname)
+  (match (string-search "\\.([^\\.]+)$" stepname)
+    ((_ ext) (string->symbol ext))
+    (else    #f)))
+
+(define (ezsteps:create-step-script envdbf stepname prevstepname mode cmd shellexe)
+  (let* (#;(shebang (case mode
+		    ((sh)  "/bin/sh")
+		    ((csh) "/bin/csh")
+		    (else  "/bin/bash")))
+	 (sourcef (conc ".ezsteps/vars_" prevstepname "." mode))
+	 (scriptn (conc "ez_" stepname))) ;; remember the name already has an extension .sh, .csh etc.
+    (with-output-to-file scriptn
+      (lambda ()
+	;; the shebang line
+	(print "#!" shellexe)
+	;; save the env at start
+	(print "megatest -envcap "stepname"_start "envdbf)
+	;; source vars from previous steps
+	(if (file-exists? sourcef)
+	    (print "source " sourcef))
+	;; run the command
+	(print cmd)
+	(if (eq? mode 'csh)
+	    (print "set ecode=$?")
+	    (print "ecode=$?"))
+	;; save the env at end
+	(print "megatest -envcap "stepname"_end "envdbf)
+	;; write the delta
+	(print "megatest -envdelta "stepname"_start-"stepname"_end -dumpmode bash -o .ezsteps/vars_"stepname".sh "envdbf)
+	(print "megatest -envdelta "stepname"_start-"stepname"_end -dumpmode csh -o .ezsteps/vars_"stepname".csh "envdbf)
+	(print "exit $ecode")))
+    (system (conc "chmod a+x " scriptn))))
+
+(define (ezsteps:get-ezpropvars res) ;; testconfig)
+  ;; (let* ((res (configf:lookup testconfig "setup" "ezpropvars")))
+    (if (string? res)
+	(let* ((dat (string-split res)))
+	  (match dat
+	    ((s shellexe)
+	     (let ((shl (string->symbol s)))
+	       `(,shl . ,shellexe)))
+	    ((s)
+	     (let* ((shl      (string->symbol s))
+		    (shellexe (if (eq? shl 'csh) "/bin/csh" "/bin/bash")))
+	       `(,shl . ,shellexe)))
+	    (else #f)))
+	#f))
 
-;; TODO: deprecate me in favor of ezsteps.scm
+;; NOTE: returns logpro-used?
 ;;
-(define (launch:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat)
+(define (launch:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat prevstepname envdbf)
   (let* ((stepname       (car ezstep))  ;; do stuff to run the step
+	 (stepmode-n     (ezsteps:step-name->mode stepname))
 	 (stepinfo       (cadr ezstep))
+	 (shellmode      (ezsteps:get-ezpropvars  (configf:lookup testconfig "setup" "ezpropvars"))) ;; returns '(csh|sh . "/path/to/shell")
+	 (stepmode       (if stepmode-n ;; the .sh or .csh always wins
+			     stepmode-n
+			     (if shellmode
+				 (car shellmode)
+				 #f)))
+	 (shellexe       (if stepmode-n
+			     (case stepmode
+			       ((csh) "/bin/csh")
+			       (else  "/bin/bash"))
+			     (if shellmode
+				 (cdr shellmode)
+				 "/bin/bash")))
 	;; (let ((info (cadr ezstep)))
 	;; 		   (if (proc? info) "" info)))
 	;; (stepproc       (let ((info (cadr ezstep)))
 	;; 		   (if (proc? info) info #f)))
 	 (stepparts      (string-match (regexp "^(\\{([^\\}\\{]*)\\}\\s*|)(.*)$") stepinfo))
@@ -80,12 +150,14 @@
 		     ";;")
 	      (print tconfig-logpro)))
 	  (set! logpro-used #t)))
     
     ;; NB// can safely assume we are in test-area directory
-    (debug:print 4 *default-log-port* "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts
+    (debug:print 4 *default-log-port* "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo
+		 " stepparts: " stepparts
 		 " stepparams: " stepparams " stepcmd: " stepcmd)
+    (if stepmode (ezsteps:create-step-script envdbf stepname prevstepname stepmode stepcmd shellexe))
     
     ;; ;; first source the previous environment
     ;; (let ((prev-env (conc ".ezsteps/" prevstep (if (string-search (regexp "csh") 
     ;;      							 (get-environment-variable "SHELL")) ".csh" ".sh"))))
     ;;   (if (and prevstep (common:file-exists? prev-env))
@@ -98,18 +170,21 @@
     (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f)
     ;; now launch the actual process
     (call-with-environment-variables 
      (list (cons "PATH" (conc (get-environment-variable "PATH") ":.")))
      (lambda () ;; (process-run "/bin/bash" "-c" "exec ls -l /tmp/foobar > /tmp/delme-more.log 2>&1")
-       (let* ((cmd (conc stepcmd " > " stepname ".log 2>&1")) ;; >outfile 2>&1 
+       (let* ((cmd (conc (if stepmode
+			     (conc "ez_" stepname)
+			     stepcmd)
+			 " > " stepname ".log 2>&1")) ;; >outfile 2>&1 
 	      (pid #f))
 	 (let ((proc (lambda ()
 		       (set! pid (process-run "/bin/bash" (list "-c" cmd))))))
 	   (if subrun
                (begin
                  (debug:print-info 0 *default-log-port* "Running without MT_.* environment variables.")
-                 (common:without-vars proc "^MT_.*"))
+                 (common:propogate-mt-vars-to-subrun proc '("MT_TARGET" "MT_LINKTREE" "MT_RUNNAME")))
 	       (proc)))
 	 
          (with-output-to-file "Makefile.ezsteps"
            (lambda ()
              (print stepname ".log :")

DELETED fs-transport.scm
Index: fs-transport.scm
==================================================================
--- fs-transport.scm
+++ /dev/null
@@ -1,52 +0,0 @@
-
-;; Copyright 2006-2012, Matthew Welland.
-;; 
-;; This file is part of Megatest.
-;; 
-;;     Megatest is free software: you can redistribute it and/or modify
-;;     it under the terms of the GNU General Public License as published by
-;;     the Free Software Foundation, either version 3 of the License, or
-;;     (at your option) any later version.
-;; 
-;;     Megatest is distributed in the hope that it will be useful,
-;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;     GNU General Public License for more details.
-;; 
-;;     You should have received a copy of the GNU General Public License
-;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
-
-(require-extension (srfi 18) extras tcp s11n)
-
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)
-(import (prefix sqlite3 sqlite3:))
-
-(use spiffy uri-common intarweb http-client spiffy-request-vars)
-
-(tcp-buffer-size 2048)
-
-(declare (unit fs-transport))
-
-(declare (uses common))
-(declare (uses db))
-(declare (uses tests))
-(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
-
-(include "common_records.scm")
-(include "db_records.scm")
-
-
-;;======================================================================
-;; F S   T R A N S P O R T   S E R V E R
-;;======================================================================
-
-;; There is no "server" per se but a convience routine to make it non
-;; necessary to be reopening the db over and over again.
-;;
-
-(define (fs:process-queue-item packet)
-  (if (not *dbstruct-db*) ;; we will require that (setup-for-run) has already been called
-      (set! *dbstruct-db* (db:setup-db)))
-  (debug:print-info 11 *default-log-port* "fs:process-queue-item called with packet=" packet)
-  (db:process-queue-item *dbstruct-db* packet))
-      

Index: genexample.scm
==================================================================
--- genexample.scm
+++ genexample.scm
@@ -18,10 +18,13 @@
 
 ;;======================================================================
 
 (declare (unit genexample))
 (use posix regex matchable)
+
+(declare (uses commonmod))
+(import commonmod)
 
 (include "db_records.scm")
 
 (define genexample:example-logpro
 #<<EOF

Index: http-transport.scm
==================================================================
--- http-transport.scm
+++ http-transport.scm
@@ -1,6 +1,5 @@
-
 ;; Copyright 2006-2012, Matthew Welland.
 ;; 
 ;; This file is part of Megatest.
 ;; 
 ;;     Megatest is free software: you can redistribute it and/or modify
@@ -29,22 +28,34 @@
 
 (declare (unit http-transport))
 
 (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))
+;; (declare (uses server))
 ;; (declare (uses daemon))
 (declare (uses portlogger))
 (declare (uses rmt))
+
+(declare (uses commonmod))
+(import commonmod)
+
+(declare (uses configfmod))
+(import configfmod)
+
+(declare (uses dbmod))
+(import dbmod)
+
+(declare (uses servermod))
+(import servermod)
 
 (include "common_records.scm")
 (include "db_records.scm")
-(include "js-path.scm")
+;; (include "js-path.scm")
 
-(require-library stml)
+;; (require-library stml)
+
 (define (http-transport:make-server-url hostport)
   (if (not hostport)
       #f
       (conc "http://" (car hostport) ":" (cadr hostport))))
 
@@ -636,97 +647,7 @@
 ;; 			   "exit on ^C timer")))
 ;;      (thread-start! th2)
 ;;      (thread-start! th1)
 ;;      (thread-join! th2))))
 
-;;===============================================
-;; Java script
-;;===============================================
-(define (http-transport:show-jquery)
-  (let* ((data  (tests:readlines *java-script-lib*)))
-(string-join data "\n")))
-
-
-
-;;======================================================================
-;; web pages
-;;======================================================================
-
-(define (http-transport:html-test-log $)
-   (let* ((run-id ($ 'runid))
-         (test-item ($ 'testname))
-         (parts (string-split test-item ":"))
-         (test-name (car parts))
-             
-         (item-name (if (equal? (length parts) 1)
-             ""
-             (cadr parts))))
-  ;(print $) 
-(tests:get-test-log run-id test-name item-name)))
-
-
-(define (http-transport:html-dboard $)
-  (let* ((page ($ 'page))
-         (oup       (open-output-string)) 
-         (bdy "--------------------------")
-
-         (ret  (tests:dynamic-dboard page)))
-    (s:output-new  oup  ret)
-   (close-output-port oup)
-
-  (set! bdy   (get-output-string oup))
-     (conc "<h1>Dashboard</h1>" bdy "<br/> <br/> "  )))
-
-(define (http-transport:main-page)
-  (let ((linkpath (root-path)))
-    (conc "<head><h1>" (pathname-strip-directory *toppath*) "</h1></head>"
-	  "<body>"
-	  "Run area: " *toppath*
-	  "<h2>Server Stats</h2>"
-	  (http-transport:stats-table) 
-	  "<hr>"
-	  (http-transport:runs linkpath)
-	  "<hr>"
-	  ;; (http-transport:run-stats)
-	  "</body>"
-	  )))
-
-(define (http-transport:stats-table)
-  (mutex-lock! *heartbeat-mutex*)
-  (let ((res 
-	 (conc "<table>"
-	       ;; "<tr><td>Max cached queries</td>        <td>" *max-cache-size* "</td></tr>"
-	       "<tr><td>Number of cached writes</td>   <td>" *number-of-writes* "</td></tr>"
-	       "<tr><td>Average cached write time</td> <td>" (if (eq? *number-of-writes* 0)
-								 "n/a (no writes)"
-								 (/ *writes-total-delay*
-								    *number-of-writes*))
-	       " ms</td></tr>"
-	       "<tr><td>Number non-cached queries</td> <td>"  *number-non-write-queries* "</td></tr>"
-	       ;; "<tr><td>Average non-cached time</td>   <td>" (if (eq? *number-non-write-queries* 0)
-	       ;; 							 "n/a (no queries)"
-	       ;; 							 (/ *total-non-write-delay* 
-	       ;; 							    *number-non-write-queries*))
-	       " ms</td></tr>"
-	       "<tr><td>Last access</td><td>"              (seconds->time-string *db-last-access*) "</td></tr>"
-	       "</table>")))
-    (mutex-unlock! *heartbeat-mutex*)
-    res))
-
-(define (http-transport:runs linkpath)
-  (conc "<h3>Runs</h3>"
-	(string-intersperse
-	 (let ((files (map pathname-strip-directory (glob (conc linkpath "/*")))))
-	   (map (lambda (p)
-		  (conc "<a href=\"" p "\">" p "</a><br>"))
-		files))
-	 " ")))
-
-#;(define (http-transport:run-stats)
-  (let ((stats (open-run-close db:get-running-stats #f)))
-    (conc "<table>"
-	  (string-intersperse
-	   (map (lambda (stat)
-		  (conc "<tr><td>" (car stat) "</td><td>" (cadr stat) "</td></tr>"))
-		stats)
-	   " ")
-	  "</table>")))
+
+

Index: index-tree.scm
==================================================================
--- index-tree.scm
+++ index-tree.scm
@@ -29,10 +29,13 @@
 (declare (uses lock-queue))
 (declare (uses db))
 (declare (uses common))
 (declare (uses items))
 (declare (uses runconfig))
+
+(declare (uses commonmod))
+(import commonmod)
 
 (include "common_records.scm")
 (include "key_records.scm")
 (include "db_records.scm")
 (include "run_records.scm")

Index: items.scm
==================================================================
--- items.scm
+++ items.scm
@@ -21,10 +21,16 @@
 ;; 		     (temperature "cool medium hot")
 ;; 		     (season      "summer winter fall spring")))
 
 (declare (unit items))
 (declare (uses common))
+
+(declare (uses commonmod))
+(import commonmod)
+
+(declare (uses configfmod))
+(import configfmod)
 
 (include "common_records.scm")
 
 ;; Puts out all combinations
 (define (process-itemlist hierdepth curritemkey itemlist)

Index: key_records.scm
==================================================================
--- key_records.scm
+++ key_records.scm
@@ -16,17 +16,5 @@
 ;;     You should have received a copy of the GNU General Public License
 ;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
 
 ;;======================================================================
 
-(define-inline (keys->valslots keys) ;; => ?,?,? ....
-  (string-intersperse (map (lambda (x) "?") keys) ","))
-
-;; (define-inline (keys->key/field keys . additional)
-;;   (string-join (map (lambda (k)(conc k " TEXT"))
-;; 		    (append keys additional)) ","))
-
-(define-inline (item-list->path itemdat)
-  (if (list? itemdat)
-      (string-intersperse  (map cadr itemdat) "/")
-      ""))
-

DELETED keys.scm
Index: keys.scm
==================================================================
--- keys.scm
+++ /dev/null
@@ -1,85 +0,0 @@
-
-;; Copyright 2006-2012, Matthew Welland.
-;; 
-;; This file is part of Megatest.
-;; 
-;;     Megatest is free software: you can redistribute it and/or modify
-;;     it under the terms of the GNU General Public License as published by
-;;     the Free Software Foundation, either version 3 of the License, or
-;;     (at your option) any later version.
-;; 
-;;     Megatest is distributed in the hope that it will be useful,
-;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;     GNU General Public License for more details.
-;; 
-;;     You should have received a copy of the GNU General Public License
-;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
-;;
- 
-;;======================================================================
-;; Run keys, these are used to hierarchially organise tests and run areas
-;;======================================================================
-
-(use sqlite3 srfi-1 posix regex regex-case srfi-69)
-(import (prefix sqlite3 sqlite3:))
-
-(declare (unit keys))
-(declare (uses common))
-
-(include "key_records.scm")
-(include "common_records.scm")
-
-(define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ...
-  (string-intersperse keys ","))
-
-(define (args:usage . a) #f)
-
-;;======================================================================
-;; key <=> target routines
-;;======================================================================
-
-;; This invalidates using "/" in item names. Every key will be
-;; available via args:get-arg as :keyfield. Since this only needs to
-;; be called once let's use it to set the environment vars
-;;
-;; The setting of :keyfield in args should be turned off ASAP
-;;
-(define (keys:target-set-args keys target ht)
-  (if target
-      (let ((vals (string-split target "/")))
-	(if (eq? (length vals)(length keys))
-	    (for-each (lambda (key val)
-			(setenv key val)
-			(if ht (hash-table-set! ht (conc ":" key) val)))
-		      keys
-		      vals)
-	    (debug:print-error 0 *default-log-port* "wrong number of values in " target ", should match " keys))
-	vals)
-      (debug:print 4 *default-log-port* "ERROR: keys:target-set-args called with no target.")))
-
-;; given the keys (a list of vectors <key field> or a list of keys) and a target return a keyval list
-;; keyval list ( (key1 val1) (key2 val2) ...)
-(define (keys:target->keyval keys target)
-  (let* ((targlist (string-split target "/"))
-	 (numkeys  (length keys))
-	 (numtarg  (length targlist))
-	 (targtweaked (if (> numkeys numtarg)
-			  (append targlist (make-list (- numkeys numtarg) ""))
-			  targlist)))
-    (map (lambda (key targ)
-	   (list key targ))
-	 keys targtweaked)))
-
-;;======================================================================
-;; config file related routines
-;;======================================================================
-
-(define keys:config-get-fields common:get-fields)
-(define (keys:make-key/field-string confdat)
-  (let ((fields (configf:get-section confdat "fields")))
-    (string-join
-     (map (lambda (field)(conc (car field) " " (cadr field)))
-	  fields)
-     ",")))
-

Index: launch.scm
==================================================================
--- launch.scm
+++ launch.scm
@@ -32,10 +32,19 @@
 (declare (uses subrun))
 (declare (uses common))
 (declare (uses configf))
 (declare (uses db))
 (declare (uses ezsteps))
+
+(declare (uses commonmod))
+(import commonmod)
+
+(declare (uses configfmod))
+(import configfmod)
+
+(declare (uses dbmod))
+(import dbmod)
 
 (include "common_records.scm")
 (include "key_records.scm")
 (include "db_records.scm")
 (include "megatest-fossil-hash.scm")
@@ -168,22 +177,28 @@
                     (append (or ezstepslst '())
                             (list (list "subrun" (conc "{subrun=true} " mt-cmd)))))))
 
 	;; process the ezsteps
 	(if ezsteps
-	    (let* ((all-steps-dat (make-hash-table))) ;; keep all the info around as stepname ==> alist; where  'params is the params list (add other stuff as needed)
+	    (let* ((envdbf        (conc "/tmp/."(current-user-name)"-"(current-process-id)"-"run-id"-"test-id".db"))
+		   (all-steps-dat (make-hash-table))) ;; keep all the info around as stepname ==> alist;
+	                                              ;;; where  'params is the params list (add other
+	                                              ;;; stuff as needed)
 	      (if (not (common:file-exists? ".ezsteps"))(create-directory ".ezsteps"))
 	      ;; if ezsteps was defined then we are sure to have at least one step but check anyway
 	      (if (not (> (length ezstepslst) 0))
 		  (debug:print-error 0 *default-log-port* "ezsteps defined but ezstepslst is zero length")
+		  (let ((all-step-names (map car ezstepslst)))
+		    (setenv "MT_STEP_NAMES" (string-intersperse all-step-names " "))
 		  (let loop ((ezstep (car ezstepslst))
 			     (tal    (cdr ezstepslst))
 			     (prevstep #f))
                     (debug:print-info 0 *default-log-port* "Processing ezstep \"" (string-intersperse ezstep " ") "\"")
 		    ;; check exit-info (vector-ref exit-info 1)
 		    (if (launch:einf-exit-status exit-info) ;; (vector-ref exit-info 1)
-			(let* ((logpro-used (launch:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat))
+			  (let* ((logpro-used (launch:runstep ezstep run-id test-id exit-info m
+							      tal testconfig all-steps-dat prevstep envdbf))
 			       (stepname    (car ezstep))
 			       (stepparms   (hash-table-ref all-steps-dat stepname)))
 			  (setenv "MT_STEP_NAME" stepname)
 			  (pp (hash-table->alist all-steps-dat))
 			  ;; if logpro-used read in the stepname.dat file
@@ -191,11 +206,12 @@
 			      (launch:load-logpro-dat run-id test-id stepname))
 			  (if (steprun-good? logpro-used (launch:einf-exit-code exit-info) stepparms)
 			      (if (not (null? tal))
 				  (loop (car tal) (cdr tal) stepname))
 			      (debug:print 0 *default-log-port* "WARNING: step " (car ezstep) " failed. Stopping")))
-			(debug:print 0 *default-log-port* "WARNING: a prior step failed, stopping at " ezstep)))))))))
+			  (debug:print 0 *default-log-port* "WARNING: a prior step failed, stopping at " ezstep))
+		      ))))))))
 
 (define (launch:monitor-job run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m work-area runtlim misc-flags)
   (let* ((update-period (string->number (or (configf:lookup *configdat* "setup" "test-stats-update-period") "30")))
          (start-seconds (current-seconds))
 	 (calc-minutes  (lambda ()
@@ -254,11 +270,11 @@
         (when do-sync
           ;;(with-output-to-file (conc (getenv "MT_TEST_RUN_DIR") "/last-loadinfo.log" #:append)
           ;;  (lambda () (pp (list (current-seconds) new-cpu-load new-disk-free (calc-minutes)))))
           ;; (common:telemetry-log "zombie" (conc  "launch:monitor-job - dosync started at "(current-seconds)))
           (tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f)
-          ;; (common:telemetry-log "zombie" (conc "launch:monitor-job - dosync finished at "(current-seconds)))
+          ;;(common:telemetry-log "zombie" (conc "launch:monitor-job - dosync finished at "(current-seconds)))
 	  )
         
 	(if kill-job? 
 	    (begin
               (debug:print-info 0 *default-log-port* "proceeding to kill test: "kill-reason)
@@ -770,20 +786,10 @@
                  (item-path (vector-ref running-test 11)))
 			       	(debug:print 0 *default-log-port* "test " test-name "/" item-path " not completed")
               (if (not (null? tal))
 				  (loop (car tal) (cdr tal)))))))))))        
  
-(define (launch:is-test-alive host pid)
-  (if (and host pid (not (equal? host "n/a")))
-      (let* ((cmd (conc "ssh " host " pstree -A " pid))
-	     (output (with-input-from-pipe cmd read-lines)))
-	(debug:print 2 *default-log-port* "Running " cmd " received " output)
-	(if (eq? (length output) 0)
-	   #f
-	   #t))
-      #t))
- 
 (define (launch:kill-tests-if-dead run-id)
   (let* ((running-tests (rmt:get-tests-for-run run-id "%" `("RUNNING" "LAUNCHED" "REMOTEHOSTSTART") `() #f #f #f #f #f #f #f #f)))
        (let loop ((running-test (car running-tests))
 			     (tal    (cdr running-tests))
 			     (kill-cnt 0))
@@ -926,10 +932,11 @@
 	       (get-environment-variable "MT_RUN_AREA_HOME")
 	       (common:file-exists? mtcachef)
 	       (common:file-exists? rccachef))
           ;;(BB> "launch:setup-body -- cond branch 1 - use-cache")
           (set! *configdat*    (configf:read-alist mtcachef))
+	  (set! *db-keys*      (common:get-fields *configdat*))
           ;;(BB> "launch:setup-body -- 1 set! *configdat*="*configdat*)
 	  (set! *runconfigdat* (configf:read-alist rccachef))
 	  (set! *configinfo*   (list *configdat*  (get-environment-variable "MT_RUN_AREA_HOME")))
 	  (set! *configstatus* 'fulldata)
 	  (set! *toppath*      (get-environment-variable "MT_RUN_AREA_HOME"))
@@ -962,10 +969,11 @@
 		  (set! *configdat*  (car first-pass))
                   ;;(BB> "launch:setup-body -- 2 set! *configdat*="*configdat*)
 		  (set! *configinfo* first-pass)
 		  (set! *toppath*    (or toppath (cadr first-pass))) ;; use the gathered data unless already have it
 		  (set! toppath      *toppath*)
+		  (set! *db-keys*    (common:get-fields *configdat*))
 		  (if (not *toppath*)
 		      (begin
 			(debug:print-error 0 *default-log-port* "you are not in a megatest area!")
 			(exit 1)))
 		  (setenv "MT_RUN_AREA_HOME" *toppath*)
@@ -1025,10 +1033,11 @@
 		(let* ((toppath  (or (get-environment-variable "MT_RUN_AREA_HOME")(cadr cfgdat)))
 		       (rdat     (read-config (conc toppath  ;; convert this to use runconfig:read!
 						    "/runconfigs.config") *runconfigdat* #t sections: sections)))
 		  (set! *configinfo*   cfgdat)
 		  (set! *configdat*    (car cfgdat))
+		  (set! *db-keys*    (common:get-fields *configdat*))
 		  (set! *runconfigdat* rdat)
 		  (set! *toppath*      toppath)
 		  (set! *configstatus* 'partial))
 		(begin
 		  (debug:print-error 0 *default-log-port* "No " mtconfig " file found. Giving up.")

Index: lock-queue.scm
==================================================================
--- lock-queue.scm
+++ lock-queue.scm
@@ -20,10 +20,12 @@
 
 (declare (unit lock-queue))
 (declare (uses common))
 (declare (uses tasks))
 
+(declare (uses commonmod))
+(import commonmod)
 ;;======================================================================
 ;; attempt to prevent overlapping updates of rollup files by queueing
 ;; update requests in an sqlite db
 ;;======================================================================
 

Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -41,10 +41,41 @@
 (declare (uses tasks)) ;; only used for debugging.
 (declare (uses env))
 (declare (uses diff-report))
 ;; (declare (uses ftail))
 ;; (import ftail)
+
+;; Needed for repl even if not used here in megatest.scm
+;; ORDER MATTERS!
+
+(declare (uses commonmod))
+(import commonmod)
+(declare (uses commonmod.import))
+
+(declare (uses configfmod))
+(import configfmod)
+(declare (uses configfmod.import))
+
+(declare (uses ods))
+(import ods)
+(declare (uses ods.import))
+
+(declare (uses dbmod))
+(import dbmod)
+(declare (uses dbmod.import))
+
+(declare (uses servermod))
+(import servermod)
+(declare (uses servermod.import))
+
+(declare (uses apimod))
+(import apimod)
+(declare (uses apimod.import))
+
+(declare (uses rmtmod))
+(import rmtmod)
+(declare (uses rmtmod.import))
 
 (define *db* #f) ;; this is only for the repl, do not use in general!!!!
 
 (include "common_records.scm")
 (include "key_records.scm")
@@ -448,11 +479,11 @@
 			"-convert-to-norm"
 			"-convert-to-old"
 			"-import-megatest.db"
 			"-sync-to-megatest.db"
                         "-sync-brute-force"
-			"-logging"
+			;; "-logging"
 			"-v" ;; verbose 2, more than normal (normal is 1)
 			"-q" ;; quiet 0, errors/warnings only
 
                         "-diff-rep"
 
@@ -650,13 +681,13 @@
 
 ;;======================================================================
 ;; Misc setup stuff
 ;;======================================================================
 
-(debug:setup)
+(common:debug-setup)
 
-(if (args:get-arg "-logging")(set! *logging* #t))
+;; (if (args:get-arg "-logging")(set! *logging* #t))
 
 ;;(if (debug:debug-mode 3) ;; we are obviously debugging
 ;;    (set! open-run-close open-run-close-no-exception-handling))
 
 (if (args:get-arg "-itempatt")

ADDED   mofiles/README
Index: mofiles/README
==================================================================
--- /dev/null
+++ mofiles/README
@@ -0,0 +1,1 @@
+Built modules go here - an attempt to minimize clutter.

Index: mt.scm
==================================================================
--- mt.scm
+++ mt.scm
@@ -21,17 +21,26 @@
 (import (prefix sqlite3 sqlite3:))
 
 (declare (unit mt))
 (declare (uses db))
 (declare (uses common))
-(declare (uses items))
-(declare (uses runconfig))
+;; (declare (uses items))
+;; (declare (uses runconfig))
 (declare (uses tests))
-(declare (uses server))
-(declare (uses runs))
+;; (declare (uses server))
+;; (declare (uses runs))
 (declare (uses rmt))
 ;; (declare (uses filedb))
+
+(declare (uses commonmod))
+(import commonmod)
+
+(declare (uses configfmod))
+(import configfmod)
+
+(declare (uses dbmod))
+(import dbmod)
 
 (include "common_records.scm")
 (include "key_records.scm")
 (include "db_records.scm")
 (include "run_records.scm")
@@ -133,107 +142,10 @@
 			  (begin
 			    (debug:print 0 *default-log-port* "Discarding test " testn "(" test-dat ") due to " failed-test)
 			    res)
 			  (cons testn res)))))))))
 
-;;======================================================================
-;;  T R I G G E R S
-;;======================================================================
-
-(define (mt:run-trigger cmd test-id test-rundir trigger logname test-name item-path event-time actual-state actual-status)
-  ;; Putting the commandline into ( )'s means no control over the shell. 
-  ;; stdout and stderr will be caught in the NBFAKE or mt_launch.log files
-  ;; or equivalent. No need to do this. Just run it?
-  (let* ((fullcmd (conc "nbfake "
-			cmd           " "
-			test-id       " "
-			test-rundir   " "
-			trigger       " "
-			test-name     " "
-			item-path     " " ;; has / prepended to deal with toplevel tests
-			actual-state  " "
-			actual-status " "
-			event-time
-			))
-	 (prev-nbfake-log (get-environment-variable "NBFAKE_LOG")))
-    (setenv "NBFAKE_LOG" (conc (cond
-				((and (directory-exists? test-rundir)
-				      (file-write-access? test-rundir))
-				 test-rundir)
-				((and (directory-exists? *toppath*)
-				      (file-write-access? *toppath*))
-				 *toppath*)
-				(else (conc "/tmp/" (current-user-name))))
-			       "/" logname))
-    (debug:print-info 0 *default-log-port* "TRIGGERED on " trigger ", running command " fullcmd " output at " (get-environment-variable "NBFAKE_LOG"))
-    ;; (call-with-environment-variables
-    ;;  `(("NBFAKE_LOG" . ,(conc test-rundir "/" logname)))
-    ;;  (lambda ()
-    (process-run fullcmd)
-    (if prev-nbfake-log
-	(setenv "NBFAKE_LOG" prev-nbfake-log)
-	(unsetenv "NBFAKE_LOG"))
-    )) ;; ))
-
-(define (mt:process-triggers dbstruct run-id test-id newstate newstatus)
-  (if test-id 
-      (let* ((test-dat      (db:get-test-info-by-id dbstruct run-id test-id)))
-	(if test-dat
-	    (let* ((test-rundir   (db:test-get-rundir       test-dat)) ;; ) ;; )
-		   (test-name     (db:test-get-testname     test-dat))
-		   (item-path     (db:test-get-item-path    test-dat))
-		   (duration      (db:test-get-run_duration test-dat))
-		   (comment       (db:test-get-comment      test-dat))
-		   (event-time    (db:test-get-event_time   test-dat))
-		   (tconfig       #f)
-		   (state         (if newstate  newstate  (db:test-get-state  test-dat)))
-		   (status        (if newstatus newstatus (db:test-get-status test-dat))))
-	      ;; (mutex-lock! *triggers-mutex*)
-              (handle-exceptions
-               exn
-               (begin
-                 (debug:print-error 0 *default-log-port* " Exception in mt:process-triggers for run-id="run-id" test-id="test-id" newstate="newstate" newstatus="newstatus
-                                    "\n   error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn
-                                    "\n   test-rundir="test-rundir
-                                    "\n   test-name="test-name
-                                    "\n   item-path="item-path
-                                    "\n   state="state
-                                    "\n   status="status
-                                    "\n")
-                 (print-call-chain (current-error-port))
-                 #f)
-               (if (and test-name
-                        test-rundir)   ;; #f means no dir set yet
-                   ;; (common:file-exists? test-rundir)
-                   ;; (directory? test-rundir))
-                   (call-with-environment-variables
-                    (list (cons "MT_TEST_NAME"    (or test-name "no such test"))
-                          (cons "MT_TEST_RUN_DIR" (or test-rundir "no test directory yet"))
-                          (cons "MT_ITEMPATH"     (or item-path "")))
-                    (lambda ()
-                      (if (directory-exists? test-rundir)
-                          (push-directory test-rundir)
-                          (push-directory *toppath*))
-                      (set! tconfig (mt:lazy-read-test-config test-name))
-                      (for-each (lambda (trigger)
-                                  (let* ((munged-trigger (string-translate trigger "/ " "--"))
-					(logname        (conc "last-trigger-" munged-trigger ".log")))
-                                    ;; first any triggers from the testconfig
-                                    (let ((cmd  (configf:lookup tconfig "triggers" trigger)))
-                                      (if cmd (mt:run-trigger cmd test-id test-rundir trigger (conc "tconfig-" logname) test-name item-path event-time state status)))
-                                    ;; next any triggers from megatest.config
-                                    (let ((cmd  (configf:lookup *configdat* "triggers" trigger)))
-                                      (if cmd (mt:run-trigger cmd test-id test-rundir trigger (conc "mtconfig-" logname) test-name item-path event-time state status)))))
-                                (list
-                                 (conc state "/" status)
-                                 (conc state "/")
-                                 (conc "/" status)))
-		     (pop-directory))
-                    )))
-	      ;; (mutex-unlock! *triggers-mutex*)
-	      )))))
-
 ;;======================================================================
 ;;  S T A T E   A N D   S T A T U S   F O R   T E S T S 
 ;;======================================================================
 
 ;; speed up for common cases with a little logic
@@ -300,6 +212,66 @@
 		  (if (null? tal)
 		      (begin
 			(debug:print-error 0 *default-log-port* "No readable testconfig found for " test-name)
 			#f)
 		      (loop (car tal)(cdr tal))))))))))
+
+;; cannot move to dbmod until lazy-read-testconfig is unravelled.
+;;
+(define (mt:process-triggers dbstruct run-id test-id newstate newstatus)
+  (if test-id 
+      (let* ((test-dat      (db:get-test-info-by-id dbstruct run-id test-id)))
+	(if test-dat
+	    (let* ((test-rundir   (db:test-get-rundir       test-dat)) ;; ) ;; )
+		   (test-name     (db:test-get-testname     test-dat))
+		   (item-path     (db:test-get-item-path    test-dat))
+		   (duration      (db:test-get-run_duration test-dat))
+		   (comment       (db:test-get-comment      test-dat))
+		   (event-time    (db:test-get-event_time   test-dat))
+		   (tconfig       #f)
+		   (state         (if newstate  newstate  (db:test-get-state  test-dat)))
+		   (status        (if newstatus newstatus (db:test-get-status test-dat))))
+	      ;; (mutex-lock! *triggers-mutex*)
+              (handle-exceptions
+               exn
+               (begin
+                 (debug:print-error 0 *default-log-port* " Exception in mt:process-triggers for run-id="run-id" test-id="test-id" newstate="newstate" newstatus="newstatus
+                                    "\n   error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn
+                                    "\n   test-rundir="test-rundir
+                                    "\n   test-name="test-name
+                                    "\n   item-path="item-path
+                                    "\n   state="state
+                                    "\n   status="status
+                                    "\n")
+                 (print-call-chain (current-error-port))
+                 #f)
+               (if (and test-name
+                        test-rundir)   ;; #f means no dir set yet
+                   ;; (common:file-exists? test-rundir)
+                   ;; (directory? test-rundir))
+                   (call-with-environment-variables
+                    (list (cons "MT_TEST_NAME"    (or test-name "no such test"))
+                          (cons "MT_TEST_RUN_DIR" (or test-rundir "no test directory yet"))
+                          (cons "MT_ITEMPATH"     (or item-path "")))
+                    (lambda ()
+                      (if (directory-exists? test-rundir)
+                          (push-directory test-rundir)
+                          (push-directory *toppath*))
+                      (set! tconfig (mt:lazy-read-test-config test-name))
+                      (for-each (lambda (trigger)
+                                  (let* ((munged-trigger (string-translate trigger "/ " "--"))
+					(logname        (conc "last-trigger-" munged-trigger ".log")))
+                                    ;; first any triggers from the testconfig
+                                    (let ((cmd  (configf:lookup tconfig "triggers" trigger)))
+                                      (if cmd (mt:run-trigger cmd test-id test-rundir trigger (conc "tconfig-" logname) test-name item-path event-time state status)))
+                                    ;; next any triggers from megatest.config
+                                    (let ((cmd  (configf:lookup *configdat* "triggers" trigger)))
+                                      (if cmd (mt:run-trigger cmd test-id test-rundir trigger (conc "mtconfig-" logname) test-name item-path event-time state status)))))
+                                (list
+                                 (conc state "/" status)
+                                 (conc state "/")
+                                 (conc "/" status)))
+		     (pop-directory))
+                    )))
+	      ;; (mutex-unlock! *triggers-mutex*)
+	      )))))
 

ADDED   mtconfigf.scm
Index: mtconfigf.scm
==================================================================
--- /dev/null
+++ mtconfigf.scm
@@ -0,0 +1,23 @@
+;;======================================================================
+;; Copyright 2019, Matthew Welland.
+;; 
+;; This file is part of Megatest.
+;; 
+;;     Megatest is free software: you can redistribute it and/or modify
+;;     it under the terms of the GNU General Public License as published by
+;;     the Free Software Foundation, either version 3 of the License, or
+;;     (at your option) any later version.
+;; 
+;;     Megatest is distributed in the hope that it will be useful,
+;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;     GNU General Public License for more details.
+;; 
+;;     You should have received a copy of the GNU General Public License
+;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
+
+;;======================================================================
+
+(declare (unit mtconfigf))
+
+(include "mtconfigf/mtconfigf.scm")

ADDED   mtconfigf/Makefile
Index: mtconfigf/Makefile
==================================================================
--- /dev/null
+++ mtconfigf/Makefile
@@ -0,0 +1,2 @@
+test:
+	 env CHICKEN_REPOSITORY=../../../megatest/tmpinstall/eggs/lib/chicken/7 csi -s tests/run.scm

ADDED   mtconfigf/mtconfigf.meta
Index: mtconfigf/mtconfigf.meta
==================================================================
--- /dev/null
+++ mtconfigf/mtconfigf.meta
@@ -0,0 +1,20 @@
+(
+; Your egg's license:
+(license "LGPL")
+
+; Pick one from the list of categories (see below) for your egg and enter it
+; here.
+(category misc)
+
+; A list of eggs mpeg3 depends on.  If none, you can omit this declaration
+; altogether. If you are making an egg for chicken 3 and you need to use
+; procedures from the `files' unit, be sure to include the `files' egg in the
+; `needs' section (chicken versions < 3.4.0 don't provide the `files' unit).
+; `depends' is an alias to `needs'.
+(needs srfi-1 srfi-69 regex regex-case directory-utils extras srfi-13 posix typed-records)
+
+; A list of eggs required for TESTING ONLY.  See the `Tests' section.
+(test-depends test)
+
+(author "Matt Welland")
+(synopsis "Megatest config file (ini-space format) with many enhancements."))

ADDED   mtconfigf/mtconfigf.scm
Index: mtconfigf/mtconfigf.scm
==================================================================
--- /dev/null
+++ mtconfigf/mtconfigf.scm
@@ -0,0 +1,1171 @@
+;;======================================================================
+;; 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 <http://www.gnu.org/licenses/>.
+;;
+;;======================================================================
+
+;; NOTE: This is the configf module, long term it will replace configf.scm.
+
+(module mtconfigf
+        (
+	 set-debug-printers
+	 lazy-convert
+	 assoc-safe-add
+	 section-var-set!
+	 safe-file-exists?
+	 read-link-f
+	 nice-path
+	 eval-string-in-environment
+	 safe-setenv
+	 with-env-vars
+	 cmd-run->list
+	 port->list
+	 configf:system
+	 process-line
+	 shell
+	 configf:read-line
+	 cfgdat->env-alist
+	 calc-allow-system
+	 apply-wildcards
+	 val->alist
+	 section->val-alist
+	 read-config
+	 find-config
+	 find-and-read-config
+	 lookup
+	 var-is?
+	 lookup-number
+	 section-vars
+	 get-section
+	 set-section-var
+	 compress-multi-lines
+	 expand-multi-lines
+	 file->list
+	 write-config
+	 write-merge-config
+	 read-refdb
+	 map-all-hier-alist
+	 config->alist
+	 alist->config
+	 read-alist
+	 write-alist
+	 config->ini
+	 ;;set-verbosity
+         add-eval-string
+	 get-eval-string
+         squelch-debug-prints
+	 ;; misc
+	 realpath
+	 find-chicken-lib
+         )
+
+(import scheme (chicken base) (chicken string) (chicken file) (chicken port))
+(import typed-records srfi-18 pathname-expand)
+(import regex regex-case srfi-69 srfi-1 directory-utils srfi-13 )
+(import (chicken io) (chicken condition) (chicken process-context))
+(import (chicken process) (chicken pathname) (chicken pretty-print) (chicken time))
+(import srfi-69 (chicken platform) (chicken sort))
+
+;; stub debug printers overridden by set-debug-printers
+(define (debug:print n e . args)
+  (apply print args))
+(define (debug:print-info n e . args)
+  (apply print "INFO: " args))
+(define (debug:print-error n e . args)
+  (apply print "ERROR: " args))
+
+;;(import (prefix mtdebug debug:))
+;;(define args:any? args:any-defined?) ;; cannot name it any? in mtargs module
+
+
+;; FROM common.scm
+;;
+;; 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)))))
+;;;  (if (or (> chicken-release-number 4)
+;;;	  (and (eq? 4 chicken-release-number) (> chicken-major-version 9)))
+;;;      (define ##sys#expand-home-path pathname-expand)))
+
+
+ ;;(define (set-verbosity v)(debug:set-verbosity v))
+
+ (define *default-log-port* (current-error-port))
+
+ (define (debug:print-error n . args) ;;; n available to end-users but ignored for
+   ;; default provided function
+  (with-output-to-port (current-error-port)
+    (lambda ()
+      (apply print "ERROR: "args))))
+
+(define (set-debug-printers normal-fn info-fn error-fn default-port)
+  (if error-fn  (set! debug:print-error error-fn))
+  (if info-fn   (set! debug:print-info  info-fn))
+  (if normal-fn (set! debug:print       normal-fn))
+  (if default-port (set! *default-log-port* default-port)))
+
+(define (squelch-debug-prints)
+  (let ((noop (lambda x #f)))
+    (set! debug:print noop)
+    (set! debug:print-info noop)))
+
+
+;; if it looks like a number -> convert it to a number, else return it
+;;
+(define (lazy-convert inval)
+  (let* ((as-num (if (string? inval)(string->number inval) #f)))
+    (or as-num inval)))
+
+
+(define *eval-string* "")
+(define (add-eval-string str)
+  (if (not (string-contains *eval-string* str))
+      (set! *eval-string* (conc *eval-string* " " str))))
+(define (get-eval-string) *eval-string*)
+
+;; Moved to common
+;;
+;; return list (path fullpath configname)
+(define (find-config configname #!key (toppath #f))
+  (if toppath
+      (let ((cfname (conc toppath "/" configname)))
+	(if (safe-file-exists? cfname)
+	    (list toppath cfname configname)
+	    (list #f      #f     #f)))
+      (let* ((cwd (string-split (current-directory) "/")))
+	(let loop ((dir cwd))
+	  (let* ((path     (conc "/" (string-intersperse dir "/")))
+		 (fullpath (conc path "/" configname)))
+	    (if (safe-file-exists? fullpath)
+		(list path fullpath configname)
+		(let ((remcwd (take dir (- (length dir) 1))))
+		  (if (null? remcwd)
+		      (list #f #f #f) ;;  #f #f) 
+		  (loop remcwd)))))))))
+
+(define (assoc-safe-add alist key val #!key (metadata #f))
+  (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist)))
+    (append newalist (list (if metadata
+			       (list key val metadata)
+			       (list key val))))))
+
+(define (section-var-set! cfgdat section-name var value #!key (metadata #f))
+  (hash-table-set! cfgdat section-name
+		   (assoc-safe-add
+		    (hash-table-ref/default cfgdat section-name '())
+		    var value metadata: metadata)))
+;;======================================================================
+;; Environment handling stuff
+;;======================================================================
+
+(define (safe-file-exists? path)
+  (handle-exceptions exn #f (file-exists? path)))
+
+(define (read-link-f path)
+  (handle-exceptions
+      exn
+      (begin
+	(debug:print-error 0 *default-log-port* "command \"/bin/readlink -f " path "\" failed.")
+	path) ;; just give up
+    (with-input-from-pipe
+	(conc "/bin/readlink -f " path)
+      (lambda ()
+	(read-line)))))
+
+;; return a nice clean pathname made absolute
+(define (nice-path dir)
+  (let ((match (string-match "^(~[^\\/]*)(\\/.*|)$" dir)))
+    (if match ;; using ~ for home?
+	(nice-path (conc #;(read-link-f (cadr match))
+		    (realpath (cadr match))
+		    "/" (caddr match)))
+	(normalize-pathname (if (absolute-pathname? dir)
+				dir
+				(conc (current-directory) "/" dir))))))
+
+(define (eval-string-in-environment str)
+  (handle-exceptions
+   exn
+   (begin
+     (debug:print-error 0 *default-log-port* "problem evaluating \"" str "\" in the shell environment")
+     #f)
+   (let ((cmdres (cmd-run->list (conc "echo " str))))
+     (if (null? cmdres) ""
+	 (caar cmdres)))))
+
+(define (safe-setenv key val)
+  (if (substring-index ":" key) ;; variables containing : are for internal use and cannot be environment variables.
+      (debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\"")
+      (if (and (string? val)
+	       (string? key))
+	  (handle-exceptions
+	      exn
+	      (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val)
+	    (set-environment-variable! key val))
+	  (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val))))
+
+;; accept an alist or hash table containing envvar/env value pairs (value of #f causes unset) 
+;;   execute thunk in context of environment modified as per this list
+;;   restore env to prior state then return value of eval'd thunk.
+;;   ** this is not thread safe **
+(define (with-env-vars delta-env-alist-or-hash-table thunk)
+  (let* ((delta-env-alist (if (hash-table? delta-env-alist-or-hash-table)
+                              (hash-table->alist delta-env-alist-or-hash-table)
+                              delta-env-alist-or-hash-table))
+         (restore-thunks
+          (filter
+           identity
+           (map (lambda (env-pair)
+                  (let* ((env-var     (car env-pair))
+                         (new-val     (let ((tmp (cdr env-pair)))
+                                        (if (list? tmp) (car tmp) tmp)))
+                         (current-val (get-environment-variable env-var))
+                         (restore-thunk
+                          (cond
+                           ((not current-val) (lambda () (unset-environment-variable! env-var)))
+                           ((not (string? new-val)) #f)
+                           ((eq? current-val new-val) #f)
+                           (else 
+                            (lambda () (set-environment-variable! env-var current-val))))))
+                    ;;(when (not (string? new-val))
+                    ;;    (debug:print 0 *default-log-port* " PROBLEM: not a string: "new-val"\n from env-alist:\n"delta-env-alist)
+                    ;;    (pp delta-env-alist)
+                    ;;    (exit 1))
+                        
+                    
+                    (cond
+                     ((not new-val)  ;; modify env here
+                      (unset-environment-variable! env-var))
+                     ((string? new-val)
+                      (set-environment-variable! env-var new-val)))
+                    restore-thunk))
+                delta-env-alist))))
+    (let ((rv (thunk)))
+      (for-each (lambda (x) (x)) restore-thunks) ;; restore env to original state
+      rv)))
+
+(define (cmd-run->list cmd #!key (delta-env-alist-or-hash-table '()))
+  (with-env-vars
+   delta-env-alist-or-hash-table
+   (lambda ()
+     (let* ((fh (open-input-pipe cmd))
+            (res (port->list fh))
+            (status (close-input-pipe fh)))
+       (list res status)))))
+   
+(define (port->list fh)
+  (if (eof-object? fh) #f
+      (let loop ((curr (read-line fh))
+                 (result '()))
+        (if (not (eof-object? curr))
+            (loop (read-line fh)
+                  (append result (list curr)))
+            result))))
+
+;;======================================================================
+;; Make the regexp's needed globally available
+;;======================================================================
+
+(define configf:include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$"))
+(define configf:script-rx  (regexp "^\\[scriptinc\\s+(\\S+)([^\\]]*)\\]\\s*$")) ;; include output from a script
+(define configf:section-rx (regexp "^\\[(.*)\\]\\s*$"))
+(define configf:blank-l-rx (regexp "^\\s*$"))
+(define configf:key-sys-pr (regexp "^(\\S+)\\s+\\[system\\s+(\\S+.*)\\]\\s*$"))
+(define configf:key-val-pr (regexp "^(\\S+)(\\s+(.*)|())$"))
+(define configf:key-no-val (regexp "^(\\S+)(\\s*)$"))
+(define configf:comment-rx (regexp "^\\s*#.*"))
+(define configf:cont-ln-rx (regexp "^(\\s+)(\\S+.*)$"))
+(define configf:settings   (regexp "^\\[configf:settings\\s+(\\S+)\\s+(\\S+)]\\s*$"))
+(define configf:initstr-rx (regexp "^\\[configf:initstr\\s+(.*)\\]\\s*$"))
+
+;; read a line and process any #{ ... } constructs
+
+(define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get|rget|scm|sh|rp|gv|g|mtrah)\\s+([^\\}\\{]*)\\}(.*)"))
+
+(define (configf:system ht cmd)
+  (system cmd)
+  )
+
+;; Lookup a value in runconfigs based on -reqtarg or -target
+;; 
+(define (runconfigs-get config var) ;; .dvars is a special bin for storing metadata such as target
+  (let ((targ (lookup config ".dvars" "target"))) ;; (common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET"))))
+    (if targ
+	(or (lookup config targ var)
+	    (lookup config "default" var))
+	(lookup config "default" var))))
+
+(define (realpath x)
+  (let ((currdir (current-directory)))
+    (handle-exceptions
+	exn
+	(begin
+	  (change-directory currdir)
+	  x) ;; anything goes wrong - return given path
+      (change-directory x)
+      (let ((result (current-directory)))
+	(change-directory currdir)
+	result))))
+
+;;  (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))
+
+;; (use trace)
+;; (trace-call-sites #t)
+;; (trace realpath common:get-this-exe-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*))
+
+(define (find-chicken-lib)
+  (let* ((ckhome         (chicken-home))
+	 (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))
+	(conc "(repository-path \""libpath"\") ")
+	"")))
+  
+(define (process-line l ht allow-system #!key (linenum #f)(extend-eval ""))
+  (let loop ((res l))
+    (if (string? res)
+	(let ((matchdat (string-search configf:var-expand-regex res)))
+	  (if matchdat
+	      (let* ((prestr  (list-ref matchdat 1))
+		     (cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv
+		     (cmd     (list-ref matchdat 3))
+		     (poststr (list-ref matchdat 4))
+		     (result  #f)
+		     (start-time (current-milliseconds))
+		     (cmdsym  (string->symbol cmdtype))
+		     (presnip (conc "(import posix)(import directory-utils)"
+				    "(set! getenv get-environment-variable)"
+                                    ))
+		     (allsnip (conc "(import posix)(import directory-utils)"
+				    "(set! getenv get-environment-variable)"
+				    (find-chicken-lib)
+                                    "(import (prefix mtconfigf configf:))"
+				    "(import mtconfigf)"
+                                    *eval-string*))
+		     (fullcmd (case cmdsym
+				((scheme scm) (conc "(lambda (ht)" allsnip "" cmd "))"))
+				((system)     (conc "(lambda (ht)" allsnip "(configf:system ht \"" cmd "\"))"))
+				((shell sh)   (conc "(lambda (ht)" allsnip "(string-translate (shell \""  cmd "\") \"\n\" \" \"))"))
+				((realpath rp)(conc "(lambda (ht)" allsnip "(configf:nice-path \"" cmd "\"))"))
+				((getenv gv)  (conc "(lambda (ht)(get-environment-variable \"" cmd "\"))"))
+				((mtrah)      (conc "(lambda (ht)"
+						    allsnip
+                                                    "  (let ((extra \"" cmd "\"))"
+						    "     (conc (or *toppath* (get-environment-variable \"MT_RUN_AREA_HOME\"))"
+						    "        (if (string-null? extra) \"\" \"/\")"
+						    "     extra)))"))
+				((get g)   
+				 (let* ((parts (string-split cmd))
+					(sect  (car parts))
+					(var   (cadr parts)))
+				   (conc "(lambda (ht)(configf:lookup ht \"" sect "\" \"" var "\"))")))
+				;;((runconfigs-get rget) (conc "(lambda (ht)" allsnip "(configf:runconfigs-get ht \"" cmd "\"))"))
+                                ((runconfigs-get rget)
+                                 (runconfigs-get ht cmd))
+				(else "(lambda (ht)(print \"ERROR\") \"ERROR\")"))))
+
+		(handle-exceptions
+		    exn
+		    (let ((arguments ((condition-property-accessor 'exn 'arguments) exn))
+			  (message    ((condition-property-accessor 'exn 'message) exn))
+			  (allstr     (conc "#{( " cmdtype ") " cmd "}, full expansion: " fullcmd)))
+		      (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\"")
+		      (debug:print 0 *default-log-port* " message: " message 
+				   (if arguments
+				       (conc "; " (string-intersperse (map conc arguments) ", "))
+				       ""))
+		      (debug:print 0 *default-log-port* "INFO: allstr is\n" allstr)
+		      ;; (debug:print 0 *default-log-port* "exn=" (condition->list exn))
+		      (set! result allstr))
+		  (if (or allow-system
+			  (not (member cmdtype '("system" "shell" "sh"))))
+                      (if (member cmdsym '(runconfigs-get rget))
+                          (begin
+                            (set! result fullcmd)
+                            fullcmd)
+		          (with-input-from-string fullcmd
+			    (lambda ()
+			      (set! result ((eval (read)
+						  ;;(module-environment 'mtconfigf)
+						  ) ht)))))
+		      (set! result (conc "#{(" cmdtype ") "  cmd "}"))))
+		(case cmdsym
+		  ((system shell scheme scm sh)
+		   (let ((delta (- (current-milliseconds) start-time)))
+		     (if (> delta 2000)
+			 (debug:print-info 0 *default-log-port* "for line \"" l "\"\n command:  " cmd " took " (/ delta 1000) " seconds to run with output:\n   " result)
+			 (debug:print-info 9 *default-log-port* "for line \"" l "\"\n command:  " cmd " took " (/ delta 1000) " seconds to run with output:\n   " result)))))
+		(loop (conc prestr result poststr)))
+	      res))
+	res)))
+
+;; Run a shell command and return the output as a string
+(define (shell cmd)
+  (let* ((output (cmd-run->list cmd))
+	 (res    (car output))
+	 (status (cadr output)))
+    (if (equal? status 0)
+	(let ((outres (string-intersperse 
+		       res
+		       "\n")))
+	  (debug:print-info 4 *default-log-port* "shell result:\n" outres)
+	  outres)
+	(begin
+	  (with-output-to-port (current-error-port)
+	    (lambda ()
+	      (print "ERROR: " cmd " returned bad exit code " status)))
+	  ""))))
+
+;; this was inline but I'm pretty sure that is a hold over from when it was *very* simple ...
+;;
+(define (configf:read-line p ht allow-processing settings #!key ....)
+  (let loop ((inl (read-line p)))
+    (let ((cont-line (and (string? inl)
+			  (not (string-null? inl))
+			  (equal? "\\" (string-take-right inl 1)))))
+      (if cont-line ;; last character is \ 
+	  (let ((nextl (read-line p)))
+	    (if (not (eof-object? nextl))
+		(loop (string-append (if cont-line 
+					 (string-take inl (- (string-length inl) 1))
+					 inl)
+				     nextl))))
+	  (let ((res (case allow-processing ;; if (and allow-processing 
+		       ;;	   (not (eq? allow-processing 'return-string)))
+		       ((#t #f)
+			(process-line inl ht allow-processing))
+		       ((return-string)
+			inl)
+		       (else
+			(process-line inl ht allow-processing)))))
+	    (if (string? res)
+		(let* ((r1 (if (not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "no") "no"))
+			       (string-substitute "\\s+$" "" res)
+			       res))
+		       (r2 (if (not (equal? (hash-table-ref/default settings "line-end-comments" "no") "no"))
+			      (string-substitute "\\s*#+[^\\{]*.*$" "" r1)
+			      r1)))
+		  r2)
+		res))))))
+
+(define (cfgdat->env-alist section cfgdat-ht allow-system)
+  (filter
+   (lambda (pair)
+     (let* ((var (car pair))
+            (val (cdr pair)))
+       (cons var
+             (cond
+              ((and allow-system (procedure? val)) ;; if we decided to use something other than #t or #f for allow-system ('return-procs or 'return-string) , this may become problematic
+               (val))
+              ((procedure? val) #f)
+              ((string? val) val)
+              (else "#f")))))
+   (append
+    (hash-table-ref/default cfgdat-ht "default" '())
+    (if (equal? section "default") '() (hash-table-ref/default cfgdat-ht section '())))))
+
+(define (calc-allow-system allow-system section sections)
+  (if sections
+      (and (or (equal? "default" section)
+	       (member section sections))
+	   allow-system) ;; account for sections and return allow-system as it might be a symbol such as return-strings
+      allow-system))
+    
+;; given a config hash and a section name, apply that section to all matching sections (using wildcard % or regex if /..../)
+;; remove the section when done so that there is no downstream clobbering
+;;
+(define (apply-wildcards ht section-name)
+  (if (hash-table-exists? ht section-name)
+      (let* ((vars  (hash-table-ref ht section-name))
+	     (rxstr (if (string-contains section-name "%")
+			(string-substitute (regexp "%") ".*" section-name)
+			(string-substitute (regexp "^/(.*)/$") "\\1" section-name)))
+	     (rx    (regexp rxstr)))
+	;; (print "\nsection-name: " section-name " rxstr: " rxstr)
+        (for-each
+         (lambda (section)
+	   (if section
+	       (let ((same-section (string=? section-name section))
+		     (rx-match     (string-match rx section)))
+		 ;; (print "section: " section " vars: " vars " same-section: " same-section " rx-match: " rx-match)
+		 (if (and (not same-section) rx-match)
+		     (for-each
+		      (lambda (bundle)
+			;; (print "bundle: " bundle)
+			(let ((key  (car bundle))
+			      (val  (cadr bundle))
+			      (meta (if (> (length bundle) 2)(caddr bundle) #f)))
+			  (hash-table-set! ht section (assoc-safe-add (hash-table-ref ht section) key val metadata: meta))))
+		      vars)))))
+         (hash-table-keys ht))))
+  ht)
+
+;;======================================================================
+;; Extended config lines, allows storing more hierarchial data in the config lines
+;;   ABC a=1; b=hello world; c=a
+;;
+;; NOTE: implementation is quite limited. You currently cannot have
+;;       semicolons in your string values.
+;;======================================================================
+
+;; convert string a=1; b=2; c=a silly thing; d=
+;; to '((a . 1)(b . 2)(c . "a silly thing")(d . ""))
+;;
+(define (val->alist val #!key (convert #f))
+  (let ((val-list (string-split-fields ";\\s*" val #:infix)))
+    (if val-list
+	(map (lambda (x)
+	       (let ((f (string-split-fields "\\s*=\\s*" x #:infix)))
+		 (case (length f)
+		   ((0) `(,#f))  ;; null string case
+		   ((1) `(,(string->symbol (car f))))
+		   ((2) `(,(string->symbol (car f)) . ,(let ((inval (cadr f)))
+							 (if convert (lazy-convert inval) inval))))
+		   (else f))))
+	     val-list)
+	'())))
+
+;; I don't want configf to turn into a weak yaml format but this extention is really useful
+;;
+(define (section->val-alist cfgdat section-name #!key (convert #f))
+  (let ((section (get-section cfgdat section-name)))
+    (map (lambda (item)
+           (let ((key (car item))
+                 (val (cadr item))) ;; BUG IN WAIT. sections are not returned as proper alists, should fix this.
+             (cons key (val->alist val convert: convert))))
+         section)))
+  
+;; read a config file, returns hash table of alists
+
+;; read a config file, returns hash table of alists
+;; adds to ht if given (must be #f otherwise)
+;; allow-system:
+;;    #f - do not evaluate [system
+;;    #t - immediately evaluate [system and store result as string
+;;    'return-procs -- return a proc taking ht as an argument that may be evaulated at some future time
+;;    'return-string -- return a string representing a proc taking ht as an argument that may be evaulated at some future time
+;; envion-patt is a regex spec that identifies sections that will be eval'd
+;; in the environment on the fly
+;; sections: #f => get all, else list of sections to gather
+;; post-section-procs alist of section-pattern => proc, where: (proc section-name next-section-name ht curr-path)
+;; apply-wildcards: #t/#f - apply vars from targets with % wildcards to all matching sections
+;;
+;; NOTE: apply-wild variable is intentional (but a better name would be good)
+;;
+(define (read-config path ht allow-system #!key (environ-patt #f)            (curr-section #f)   
+		     (sections #f)              (settings (make-hash-table)) (keep-filenames #f)
+		     (post-section-procs '())   (apply-wild #t) )
+  (debug:print 9 *default-log-port* "BB> read-config > keep-filenames: " keep-filenames)
+  (debug:print 9 *default-log-port* "START: " path)
+;; (if *configdat*
+;;     (common:save-pkt `((action . read-config)
+;;       		 (f      . ,(cond ((string? path) path)
+;;       				  ((port?   path) "port")
+;;       				  (else (conc path))))
+;;                        (T      . configf))
+;;       	       *configdat* #t add-only: #t))
+  (if (and (not (port? path))
+	   (not (safe-file-exists? path))) ;; for case where we are handed a port
+      (begin 
+	(debug:print-info 1 *default-log-port* "read-config - file not found " path " current path: " (current-directory))
+	;; WARNING: This is a risky change but really, we should not return an empty hash table if no file read?
+	#f) ;; (if (not ht)(make-hash-table) ht))
+      (let* ((have-file  (string? path))
+	     (inp        (if have-file
+			     (open-input-file path)
+			     path)) ;; we can be handed a port
+	     (res        (if (not ht)(make-hash-table) ht))
+	     (metapath   (if keep-filenames
+			     path #f))
+	     (process-wildcards  (lambda (res curr-section-name)
+				   (if (and apply-wild
+					    (or (string-contains curr-section-name "%")   ;; wildcard
+						(string-match "/.*/" curr-section-name))) ;; regex
+				       (begin
+					 (apply-wildcards res curr-section-name)
+					 (hash-table-delete! res curr-section-name))))))  ;; NOTE: if the section is a wild card it will be REMOVED from res 
+	(let loop ((inl               (configf:read-line inp res (calc-allow-system allow-system curr-section sections) settings)) ;; (read-line inp))
+		   (curr-section-name (if curr-section curr-section "default"))
+		   (var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere
+		   (lead     #f))
+	  (debug:print-info 8 *default-log-port* "curr-section-name: " curr-section-name " var-flag: " var-flag "\n   inl: \"" inl "\"")
+	  (if (eof-object? inl) 
+	      (begin
+                ;; process last section for wildcards
+                (process-wildcards res curr-section-name)
+		(if have-file ;; we received a path, not a port, thus we are responsible for closing it.
+		    (close-input-port inp))
+		(if (list? sections) ;; delete all sections except given when sections is provided
+		    (for-each
+		     (lambda (section)
+		       (if (not (member section sections))
+			   (hash-table-delete! res section))) ;; we are using "" as a dumping ground and must remove it before returning the ht
+		     (hash-table-keys res)))
+		(debug:print 9 *default-log-port* "END: " path)
+                res
+                ) ;; retval
+	      (regex-case 
+	       inl 
+	       (configf:comment-rx _                  (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
+                                                            curr-section-name #f #f))
+               
+	       (configf:blank-l-rx _                  (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
+                                                            curr-section-name #f #f))
+	       (configf:settings   ( x setting val  )
+                                   (begin
+                                     (hash-table-set! settings setting val)
+                                     (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
+                                           curr-section-name #f #f)))
+	       
+	       (configf:initstr-rx ( x initstr  )
+                                   (begin
+				     (add-eval-string initstr)
+                                     (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
+                                           curr-section-name #f #f)))
+               
+	       (configf:include-rx ( x include-file )
+                                   (let* ((curr-conf-dir (pathname-directory path))
+                                          (full-conf     (if (and (absolute-pathname? include-file) (file-exists? include-file))
+                                                             include-file
+                                                             (nice-path 
+                                                              (conc (if curr-conf-dir
+                                                                        curr-conf-dir
+                                                                        ".")
+                                                                    "/" include-file))))
+					  (all-matches (sort (handle-exceptions exn (list) (glob full-conf)) string<=?)))
+				       (if (null? all-matches)
+					   (begin
+					     (debug:print '(2 9) #f "INFO: include file(s) matching " include-file " not found (called from " path ")")
+					     (debug:print 2 *default-log-port* "        " full-conf))
+					   (for-each
+					    (lambda (fpath)
+					      ;; (push-directory conf-dir)
+					      (debug:print 9 *default-log-port* "Including: " full-conf)
+					      (read-config fpath res allow-system environ-patt: environ-patt
+							   curr-section: curr-section-name sections: sections settings: settings
+							   keep-filenames: keep-filenames))
+					    all-matches))
+				       (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
+					     curr-section-name #f #f)))
+	       (configf:script-rx ( x include-script params);; handle-exceptions
+                                  ;;    exn
+                                  ;;    (begin
+                                  ;;      (debug:print '(0 2 9) #f "INFO: include from script " include-script " failed.")
+                                  ;;      (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
+                                  (if (and (safe-file-exists? include-script)(file-executable? include-script))
+                                      (let* ((local-allow-system  (calc-allow-system allow-system curr-section-name sections))
+                                             (env-delta  (cfgdat->env-alist curr-section-name res local-allow-system))
+                                             (new-inp-port
+                                              (with-env-vars
+                                               env-delta
+                                               (lambda ()
+                                                 (open-input-pipe (conc include-script " " params))))))
+                                        (debug:print '(2 9) *default-log-port* "Including from script output: " include-script)
+                                        ;;  (print "We got here, calling read-config next. Port is: " new-inp-port)
+                                        (read-config new-inp-port res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames)
+                                        (close-input-port new-inp-port)
+                                        (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
+                                      (begin
+                                        (debug:print 0 *default-log-port* "Script not found or not exectutable: " include-script)
+                                        (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))
+                                  ) ;; )
+	       (configf:section-rx ( x section-name )
+                                   (begin
+                                     ;; call post-section-procs
+                                     (for-each 
+                                      (lambda (dat)
+                                        (let ((patt (car dat))
+                                              (proc (cdr dat)))
+                                          (if (string-match patt curr-section-name)
+                                              (proc curr-section-name section-name res path))))
+                                      post-section-procs)
+                                     ;; after gathering the vars for a section and if apply-wildcards is true and if there is a wildcard in the section name process wildcards
+                                     ;; NOTE: we are processing the curr-section-name, NOT section-name.
+                                     (process-wildcards res curr-section-name)
+                                     (if (not (hash-table-ref/default res section-name #f))(hash-table-set! res section-name '())) ;; ensure that mere mention of a section is not lost
+                                     (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
+                                           ;; if we have the sections list then force all settings into "" and delete it later?
+                                           ;; (if (or (not sections) 
+                                           ;;	      (member section-name sections))
+                                           ;;	  section-name "") ;; stick everything into "". NOPE: We need new strategy. Put stuff in correct sections and then delete all sections later.
+                                           section-name
+                                           #f #f)))
+	       (configf:key-sys-pr ( x key cmd      )
+                                   (if (calc-allow-system allow-system curr-section-name sections)
+                                       (let ((alist    (hash-table-ref/default res curr-section-name '()))
+                                             (val-proc (lambda ()
+                                                         (let* ((start-time (current-seconds))
+                                                                (local-allow-system  (calc-allow-system allow-system curr-section-name sections))
+                                                                (env-delta  (cfgdat->env-alist curr-section-name res local-allow-system))
+                                                                (cmdres     (cmd-run->list cmd delta-env-alist-or-hash-table: env-delta)) ;; BB: here is where [system is exec'd.  needs to have env from other vars!
+                                                                (delta      (- (current-seconds) start-time))
+                                                                (status     (cadr cmdres))
+                                                                (res        (car  cmdres)))
+                                                           (debug:print-info 4 *default-log-port* "" inl "\n => " (string-intersperse res "\n"))
+                                                           (if (not (eq? status 0))
+                                                               (begin
+                                                                 (debug:print-error 0 *default-log-port* "problem with " inl ", return code " status
+                                                                                    " output: " cmdres)))
+                                                           (if (> delta 2)
+                                                               (debug:print-info 0 *default-log-port* "for line \"" inl "\"\n  command: " cmd " took " delta " seconds to run with output:\n   " res)
+                                                               (debug:print-info 9 *default-log-port* "for line \"" inl "\"\n  command: " cmd " took " delta " seconds to run with output:\n   " res))
+                                                           (if (null? res)
+                                                               ""
+                                                               (string-intersperse res " "))))))
+                                         (hash-table-set! res curr-section-name 
+                                                          (assoc-safe-add alist
+                                                                                 key 
+                                                                                 (case (calc-allow-system allow-system curr-section-name sections)
+                                                                                   ((return-procs) val-proc)
+                                                                                   ((return-string) cmd)
+                                                                                   (else (val-proc)))
+                                                                                 metadata: metapath))
+                                         (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
+                                       (loop (configf:read-line inp res
+                                                                (calc-allow-system allow-system curr-section-name sections)
+                                                                settings)
+                                             curr-section-name #f #f)))
+               
+	       (configf:key-no-val ( x key val)
+                                   (let* ((alist   (hash-table-ref/default res curr-section-name '()))
+                                          (fval    (or (if (string? val) val #f) ""))) ;; fval should be either "" or " " (one or more spaces)
+                                     (debug:print 10 *default-log-port* "   setting: [" curr-section-name "] " key " = #t")
+                                     (safe-setenv key fval)
+                                     (hash-table-set! res curr-section-name 
+                                                      (assoc-safe-add alist key fval metadata: metapath))
+                                     (loop (configf:read-line inp res
+                                                              (calc-allow-system allow-system curr-section-name sections)
+                                                              settings)
+                                           curr-section-name key #f)))
+               
+	       (configf:key-val-pr ( x key unk1 val unk2 )
+                                   (let* ((alist   (hash-table-ref/default res curr-section-name '()))
+                                          (envar   (and environ-patt
+							(string-search (regexp environ-patt) curr-section-name)
+							(and (not (string-null? key))
+							     (not (equal? "!" (substring key 0 1)))) ;; ! as leading character is a signature to NOT export to the environment
+							;; (string-match "^.*:.*:.*$" key) ;; ;; something:something:something reserved for triggers in runconfigs
+							)) 
+                                          (realval (if envar
+                                                       (eval-string-in-environment val)
+                                                       val)))
+                                     (debug:print-info 6 *default-log-port* "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name)
+                                     (if envar (safe-setenv key realval))
+                                     (debug:print 10 *default-log-port* "   setting: [" curr-section-name "] " key " = " val)
+                                     (hash-table-set! res curr-section-name 
+                                                      (assoc-safe-add alist key realval metadata: metapath))
+                                     (loop (configf:read-line inp res
+                                                              (calc-allow-system allow-system curr-section-name sections) settings)
+                                           curr-section-name key #f)))
+	       ;; if a continued line
+	       (configf:cont-ln-rx ( x whsp val     )
+                                   (let ((alist (hash-table-ref/default res curr-section-name '())))
+                                     (if var-flag             ;; if set to a string then we have a continued var
+                                         (let ((newval (conc 
+                                                        (lookup res curr-section-name var-flag) "\n"
+                                                        ;; trim lead from the incoming whsp to support some indenting.
+                                                        (if lead
+                                                            (string-substitute (regexp lead) "" whsp)
+                                                            "")
+                                                        val)))
+                                           ;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag)
+                                           (hash-table-set! res curr-section-name 
+                                                            (assoc-safe-add alist var-flag newval metadata: metapath))
+                                           (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name var-flag (if lead lead whsp)))
+                                         (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))
+	       (else (debug:print-error 0 *default-log-port* "problem parsing " path ",\n   \"" inl "\"")
+		     (set! var-flag #f)
+		     (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))
+          ) ;; end loop
+        )))
+
+;; look at common:set-fields for an example of how to use the set-fields proc
+;; pathenvvar will set the named var to the path of the config
+;;
+(define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f)(set-fields #f)(keep-filenames #f))
+  (let* ((curr-dir   (current-directory))
+         (configinfo (find-config fname toppath: given-toppath))
+	 (toppath    (car configinfo))
+	 (configfile (cadr configinfo)))
+    (if toppath (change-directory toppath)) 
+    (if (and toppath pathenvvar)(set-environment-variable! pathenvvar toppath))
+    (let ((configdat  (if configfile 
+			  (read-config configfile #f #t environ-patt: environ-patt
+				       post-section-procs: (if set-fields (list (cons "^fields$" set-fields)   ) '())
+				       #f
+                                       keep-filenames: keep-filenames))))
+      (if toppath (change-directory curr-dir))
+      (list configdat toppath configfile fname))))
+
+(define (lookup cfgdat section var)
+  (if (hash-table? cfgdat)
+      (let ((sectdat (hash-table-ref/default cfgdat section '())))
+	(if (null? sectdat)
+	    #f
+	    (let ((match (assoc var sectdat)))
+	      (if match ;; (and match (list? match)(> (length match) 1))
+		  (cadr match)
+		  #f))
+	    ))
+      #f))
+
+;; use to have definitive setting:
+;;  [foo]
+;;  var yes
+;;
+;;  (var-is? cfgdat "foo" "var" "yes") => #t
+;;
+(define (var-is? cfgdat section var expected-val)
+  (equal? (lookup cfgdat section var) expected-val))
+
+;; safely look up a value that is expected to be a number, return
+;; a default (#f unless provided)
+;;
+(define (lookup-number cfgdat section varname #!key (default #f))
+  (let* ((val (lookup cfgdat section varname))
+         (res (if val
+                  (string->number (string-substitute "\\s+" "" val #t))
+                  #f)))
+    (cond
+     (res  res)
+     (val  (debug:print 0 *default-log-port* "ERROR: no number found for [" section "], " varname ", got: " val))
+     (else default))))
+
+(define (section-vars cfgdat section)
+  (let ((sectdat (hash-table-ref/default cfgdat section '())))
+    (if (null? sectdat)
+	'()
+	(map car sectdat))))
+
+(define (get-section cfgdat section)
+  (hash-table-ref/default cfgdat section '()))
+
+(define (set-section-var cfgdat section var val)
+  (let ((sectdat (get-section cfgdat section)))
+    (hash-table-set! cfgdat section
+                     (assoc-safe-add sectdat var val))))
+
+    ;;(append (filter (lambda (x)(not (assoc var sectdat))) sectdat)
+    ;;	    (list var val))))
+
+;; moved to common
+;; (define (setup)
+;;   (let* ((configf (find-config "megatest.config"))
+;; 	 (config  (if configf (read-config configf #f #t) #f)))
+;;     (if config
+;; 	(setenv "RUN_AREA_HOME" (pathname-directory configf)))
+;;     config))
+
+;;======================================================================
+;; Non destructive writing of config file
+;;======================================================================
+
+(define (compress-multi-lines fdat)
+  ;; step 1.5 - compress any continued lines
+  (if (null? fdat) fdat
+	(let loop ((hed (car fdat))
+		   (tal (cdr fdat))
+		   (cur "")
+		   (led #f)
+		   (res '()))
+	  ;; ALL WHITESPACE LEADING LINES ARE TACKED ON!!
+	  ;;  1. remove led whitespace
+	  ;;  2. tack on to hed with "\n"
+	  (let ((match (string-match configf:cont-ln-rx hed)))
+	    (if match ;; blast! have to deal with a multiline
+		(let* ((lead (cadr match))
+		       (lval (caddr match))
+		       (newl (conc cur "\n" lval)))
+		  (if (not led)(set! led lead))
+		  (if (null? tal) 
+		      (set! fdat (append fdat (list newl)))
+		      (loop (car tal)(cdr tal) newl led res))) ;; NB// not tacking newl onto res
+		(let ((newres (if led 
+				  (append res (list cur hed))
+				  (append res (list hed)))))
+		  ;; prev was a multiline
+		  (if (null? tal)
+		      newres
+		      (loop (car tal)(cdr tal) "" #f newres))))))))
+
+;; note: I'm cheating a little here. I merely replace "\n" with "\n         "
+(define (expand-multi-lines fdat)
+  ;; step 1.5 - compress any continued lines
+  (if (null? fdat) fdat
+      (let loop ((hed (car fdat))
+		 (tal (cdr fdat))
+		 (res '()))
+	(let ((newres (append res (list (string-substitute (regexp "\n") "\n         " hed #t)))))
+	  (if (null? tal)
+	      newres
+	      (loop (car tal)(cdr tal) newres))))))
+
+(define (file->list fname)
+  (if (safe-file-exists? fname)
+      (let ((inp (open-input-file fname)))
+	(let loop ((inl (read-line inp))
+		   (res '()))
+	  (if (eof-object? inl)
+	      (begin
+		(close-input-port inp)
+		(reverse res))
+	      (loop (read-line inp)(cons inl res)))))
+      '()))
+
+;; raw basic write config in ini format
+;;
+(define (write-config cfgdat fname)
+  (with-output-to-file fname
+    (lambda ()
+      (config->ini cfgdat))))
+
+;;       (for-each
+;;        (lambda (section)
+;; 	 (let ((sec-dat (hash-table-ref cfgdat section)))
+;; 	   (for-each (lambda (entry)(print (car entry) " " (cadr entry))) sec-dat)))
+;;        (sort (hash-table-keys cfgdat) (lambda (a b)(string<= a b)))))))
+
+;;======================================================================
+;; Write a config
+;;   0. Given a refererence data structure "indat"
+;;   1. Open the output file and read it into a list
+;;   2. Flatten any multiline entries
+;;   3. Modify values per contents of "indat" and remove absent values
+;;   4. Append new values to the section (immediately after last legit entry)
+;;   5. Write out the new list 
+;;======================================================================
+
+(define (write-merge-config indat fname #!key (required-sections '()))
+  (let* (;; step 1: Open the output file and read it into a list
+	 (fdat    (file->list fname))
+	 (refdat  (make-hash-table))
+	 (sechash (make-hash-table)) ;; current section hash, init with hash for "default" section
+	 (new     #f) ;; put the line to be used in new, if it is to be deleted the set new to #f
+	 (secname #f))
+
+    ;; step 2: Flatten multiline entries
+    (if (not (null? fdat))(set! fdat (compress-multi-lines fdat)))
+
+    ;; step 3: Modify values per contents of "indat" and remove absent values
+    (if (not (null? fdat))
+	(let loop ((hed  (car fdat))
+		   (tal  (cadr fdat))
+		   (res  '())
+		   (lnum 0))
+	  (regex-case 
+	   hed
+	   (configf:comment-rx _                  (set! res (append res (list hed)))) ;; (loop (read-line inp) curr-section-name #f #f))
+	   (configf:blank-l-rx _                  (set! res (append res (list hed)))) ;; (loop (read-line inp) curr-section-name #f #f))
+	   (configf:section-rx ( x section-name ) (let ((section-hash (hash-table-ref/default refdat section-name #f)))
+						    (if (not section-hash)
+							(let ((newhash (make-hash-table)))
+							  (hash-table-set! refdat section-name newhash)
+							  (set! sechash newhash))
+							(set! sechash section-hash))
+						    (set! new hed) ;; will append this at the bottom of the loop
+						    (set! secname section-name)
+						    ))
+	   ;; No need to process key cmd, let it fall though to key val
+	   (configf:key-val-pr ( x key val      )
+		       (let ((newval (lookup indat secname key))) ;; secname was sec. I think that was a bug
+			 ;; can handle newval == #f here => that means key is removed
+			 (cond 
+			  ((equal? newval val)
+			   (set! res (append res (list hed))))
+			  ((not newval) ;; key has been removed
+			   (set! new #f))
+			  ((not (equal? newval val))
+			     (hash-table-set! sechash key newval)
+			     (set! new (conc key " " newval)))
+			  (else
+			   (debug:print-error 0 *default-log-port* "problem parsing line number " lnum "\"" hed "\"")))))
+	   (else
+	    (debug:print-error 0 *default-log-port* "Problem parsing line num " lnum " :\n   " hed )))
+	  (if (not (null? tal)) 
+	      (loop (car tal)(cdr tal)(if new (append res (list new)) res)(+ lnum 1)))
+	  ;; drop to here when done processing, res contains modified list of lines
+	  (set! fdat res)))
+
+    ;; step 4: Append new values to the section
+    (for-each 
+     (lambda (section)
+       (let ((sdat   '()) ;; append needed bits here
+	     (svars  (section-vars indat section)))
+	 (for-each 
+	  (lambda (var)
+	    (let ((val (lookup refdat section var)))
+	      (if (not val) ;; this one is new
+		  (begin
+		    (if (null? sdat)(set! sdat (list (conc "[" section "]"))))
+		    (set! sdat (append sdat (list (conc var " " val))))))))
+	  svars)
+	 (set! fdat (append fdat sdat))))
+     (delete-duplicates (append required-sections (hash-table-keys indat))))
+
+    ;; step 5: Write out new file
+    (with-output-to-file fname 
+      (lambda ()
+	(for-each 
+	 (lambda (line)
+	   (print line))
+	 (expand-multi-lines fdat))))))
+
+;;======================================================================
+;; refdb
+;;======================================================================
+
+;; reads a refdb into an assoc array of assoc arrays
+;;   returns (list dat msg)
+(define (read-refdb refdb-path)
+  (let ((sheets-file  (conc refdb-path "/sheet-names.cfg")))
+    (if (not (safe-file-exists? sheets-file))
+	(list #f (conc "ERROR: no refdb found at " refdb-path))
+	(if (not (file-readable? sheets-file))
+	    (list #f (conc "ERROR: refdb file not readable at " refdb-path))
+	    (let* ((sheets (with-input-from-file sheets-file
+			     (lambda ()
+			       (let loop ((inl (read-line))
+					  (res '()))
+				 (if (eof-object? inl)
+				     (reverse res)
+				     (loop (read-line)(cons inl res)))))))
+		   (data   '()))
+	      (for-each 
+	       (lambda (sheet-name)
+		 (let* ((dat-path  (conc refdb-path "/" sheet-name ".dat"))
+			(ref-dat   (read-config dat-path #f #t))
+			(ref-assoc (map (lambda (key)
+					  (list key (hash-table-ref ref-dat key)))
+					(hash-table-keys ref-dat))))
+				   ;; (hash-table->alist ref-dat)))
+		   ;; (set! data (append data (list (list sheet-name ref-assoc))))))
+		   (set! data (cons (list sheet-name ref-assoc) data))))
+	       sheets)
+	      (list data "NO ERRORS"))))))
+
+;; map over all pairs in a three level hierarchial alist and apply a function to the keys/val
+;;
+(define (map-all-hier-alist data proc #!key (initproc1 #f)(initproc2 #f)(initproc3 #f))
+  (for-each 
+   (lambda (sheetname)
+     (let* ((sheettmp  (assoc sheetname data))
+	    (sheetdat  (if sheettmp (cadr sheettmp) '())))
+       (if initproc1 (initproc1 sheetname))
+       (for-each 
+	(lambda (sectionname)
+	  (let* ((sectiontmp  (assoc sectionname sheetdat))
+		 (sectiondat  (if sectiontmp (cadr sectiontmp) '())))
+	    (if initproc2 (initproc2 sheetname sectionname))
+	    (for-each
+	     (lambda (varname)
+	       (let* ((valtmp (assoc varname sectiondat))
+		      (val    (if valtmp (cadr valtmp) "")))
+		 (proc sheetname sectionname varname val)))
+	     (map car sectiondat))))
+	(map car sheetdat))))
+   (map car data))
+  data)
+
+;;======================================================================
+;;  C O N F I G   T O / F R O M   A L I S T
+;;======================================================================
+
+(define (config->alist cfgdat)
+  (hash-table->alist cfgdat))
+
+(define (alist->config adat)
+  (let ((ht (make-hash-table)))
+    (for-each
+     (lambda (section)
+       (hash-table-set! ht (car section)(cdr section)))
+     adat)
+    ht))
+
+;; if 
+(define (read-alist fname)
+  (handle-exceptions
+      exn
+      #f
+    (alist->config
+     (with-input-from-file fname read))))
+
+(define (write-alist cdat fname #!key (locker #f)(unlocker #f))
+  (if (and locker (not (locker fname)))
+      (debug:print 0 *default-log-port* "INFO: Could not get lock on " fname))
+  (let* ((dat  (config->alist cdat))
+         (res
+          (begin
+            (with-output-to-file fname ;; first write out the file
+              (lambda ()
+                (pp dat)))
+            
+            (if (file-exists? fname)   ;; now verify it is readable
+                (if (read-alist fname)
+                    #t ;; data is good.
+                    (begin
+                      (handle-exceptions
+                       exn
+                       #f
+                       (debug:print 0 *default-log-port* "WARNING: content " dat " for cache " fname " is not readable. Deleting generated file.")
+                       (delete-file fname))
+                      #f))
+                #f))))
+    (if unlocker (unlocker fname))
+    res))
+  
+;; convert config hash-table/list data to ini format
+;;
+(define (config->ini data)
+  (map 
+   (lambda (section)
+     (let ((section-name (car section))
+	   (section-dat  (cdr section)))
+       (print "\n[" section-name "]")
+       (map (lambda (dat-pair)
+	      (let* ((var (car dat-pair))
+		     (val (cadr dat-pair))
+		     (fname (if (> (length dat-pair) 2)(caddr dat-pair) #f)))
+		(if fname (print "# " var "=>" fname))
+		(print var " " val)))
+	    section-dat))) ;;       (print "section-dat: " section-dat))
+   (hash-table->alist data)))
+
+;(use trace)
+;(trace-call-sites #t)
+;(trace read-config)
+
+)

ADDED   mtconfigf/mtconfigf.setup
Index: mtconfigf/mtconfigf.setup
==================================================================
--- /dev/null
+++ mtconfigf/mtconfigf.setup
@@ -0,0 +1,16 @@
+;; Copyright 2007-2010, Matthew Welland.
+;;
+;;  This program is made available under the GNU GPL version 2.0 or
+;;  greater. See the accompanying file COPYING for details.
+;;
+;;  This program is distributed WITHOUT ANY WARRANTY; without even the
+;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;  PURPOSE.
+
+;;;; mtconfig.setup
+
+;; compile the code into dynamically loadable shared objects
+;; and install as modules
+
+(compile -s mtconfigf.scm)
+(standard-extension 'mtconfigf "mtconfigf.so")

ADDED   mtconfigf/tests/run.scm
Index: mtconfigf/tests/run.scm
==================================================================
--- /dev/null
+++ mtconfigf/tests/run.scm
@@ -0,0 +1,48 @@
+(load "../mtdebug/mtdebug.scm")
+(import mtdebug)
+(load "mtconfigf.scm")
+(import (prefix mtconfigf config:))
+
+(use mtdebug)
+;; configure mtconfigf
+(let* ((normal-fn debug:print)
+       (info-fn   debug:print-info)
+       (error-fn  debug:print-error)
+       (default-port (current-output-port)))
+  (config:set-debug-printers normal-fn info-fn error-fn default-port))
+
+
+(use test)
+
+(let* ((cfgdat
+        (config:read-config "tests/test.config" #f #f)))
+
+  
+  (test #f "value" (config:lookup cfgdat "basic" "key"))
+  (test #f 2 (config:lookup-number cfgdat "basic" "two"))
+  
+  )
+
+(config:add-eval-string "(define (customfunc) \"hello\")")
+(let* ((cfgdat
+        (config:read-config "tests/test2.config" #f #f)))
+  (test #f "bar" (config:lookup cfgdat "schemy" "rgetreftarget"))
+  (test #f "baz" (config:lookup cfgdat "schemy" "rgetrefdefault"))
+  (test #f "2" (config:lookup cfgdat "schemy" "addup"))
+  (test #f 2 (config:lookup-number cfgdat "schemy" "addup"))
+  (test #f "hello" (config:lookup cfgdat "schemy" "custom"))
+  )
+
+(test #f
+      (conc "hello " (get-environment-variable "USER"))
+      (config:eval-string-in-environment "hello $USER"))
+
+(let* ((cfgdat
+        (config:read-config "tests/test3.config" #f #t)))
+  (test #f "hello" (config:lookup cfgdat "systemic" "hello"))
+  (test #f
+        (conc "hello " (get-environment-variable "USER"))
+        (config:lookup cfgdat "systemic" "hellouser"))
+
+  )
+

ADDED   mtconfigf/tests/test.config
Index: mtconfigf/tests/test.config
==================================================================
--- /dev/null
+++ mtconfigf/tests/test.config
@@ -0,0 +1,3 @@
+[basic]
+key value
+two 2

ADDED   mtconfigf/tests/test2.config
Index: mtconfigf/tests/test2.config
==================================================================
--- /dev/null
+++ mtconfigf/tests/test2.config
@@ -0,0 +1,15 @@
+[default]
+deffoo baz
+
+[a-target]
+foo bar
+
+[.dvars]
+target a-target
+
+
+[schemy]
+addup #{scheme (+ 1 1)}
+custom #{scheme (customfunc)}
+rgetreftarget #{rget foo}
+rgetrefdefault #{rget deffoo}

ADDED   mtconfigf/tests/test3.config
Index: mtconfigf/tests/test3.config
==================================================================
--- /dev/null
+++ mtconfigf/tests/test3.config
@@ -0,0 +1,3 @@
+[systemic]
+hello [system echo hello]
+hellouser [system echo hello $USER]

Index: mtexec.scm
==================================================================
--- mtexec.scm
+++ mtexec.scm
@@ -29,10 +29,13 @@
 
 ;; (declare (uses common))
 (declare (uses margs))
 (declare (uses configf))
 ;; (declare (uses rmt))
+
+(declare (uses configfmod))
+(import configfmod)
 
 ;; (use ducttape-lib)
 (include "megatest-version.scm")
 (include "megatest-fossil-hash.scm")
 

Index: mtut.scm
==================================================================
--- mtut.scm
+++ mtut.scm
@@ -30,10 +30,16 @@
 
 (declare (uses common))
 (declare (uses margs))
 (declare (uses configf))
 ;; (declare (uses rmt))
+
+(declare (uses commonmod))
+(import commonmod)
+
+(declare (uses configfmod))
+(import configfmod)
 
 (use ducttape-lib)
 
 (include "megatest-fossil-hash.scm")
 

Index: newdashboard.scm
==================================================================
--- newdashboard.scm
+++ newdashboard.scm
@@ -29,10 +29,16 @@
      (prefix dbi dbi:))
 
 (declare (uses common))
 (declare (uses megatest-version))
 (declare (uses margs))
+
+(declare (uses commonmod))
+(import commonmod)
+
+(declare (uses dbmod))
+(import dbmod)
 
 ;; (declare (uses launch))
 ;; (declare (uses gutils))
 ;; (declare (uses db))
 ;; (declare (uses server))
@@ -41,10 +47,14 @@
 ;; (declare (uses tree))
 ;; 
 ;; (include "common_records.scm")
 ;; (include "db_records.scm")
 ;; (include "key_records.scm")
+
+(declare (uses configfmod))
+(import configfmod)
+
 
 (define help (conc 
 "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
   version " megatest-version "
   license GPL, Copyright (C) Matt Welland 2011

Index: ods.scm
==================================================================
--- ods.scm
+++ ods.scm
@@ -16,11 +16,21 @@
 ;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
 ;;
 
 (use csv-xml regex)
 (declare (unit ods))
-(declare (uses common))
+(declare (uses commonmod))
+
+(module ods
+*
+
+(import scheme chicken data-structures extras files ports)
+(import commonmod)
+(import regex
+	srfi-13
+	posix
+	)
 
 (define ods:dirs
   '("Configurations2"
     "Configurations2/toolpanel"
     "Configurations2/menubar"
@@ -221,5 +231,8 @@
 	    (map print 
 		 (map ods:sheet data))
 	    (map display ods:content-footer)))
 	(system (conc "cd " path "; zip " fname " -n mimetype mimetype `find . |grep -v mimetype` > /dev/null")))))
 
+;;======================================================================the end
+
+)

DELETED portlogger-example.scm
Index: portlogger-example.scm
==================================================================
--- portlogger-example.scm
+++ /dev/null
@@ -1,21 +0,0 @@
-;;  Copyright 2006-2017, Matthew Welland.
-;; 
-;; This file is part of Megatest.
-;; 
-;;     Megatest is free software: you can redistribute it and/or modify
-;;     it under the terms of the GNU General Public License as published by
-;;     the Free Software Foundation, either version 3 of the License, or
-;;     (at your option) any later version.
-;; 
-;;     Megatest is distributed in the hope that it will be useful,
-;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;     GNU General Public License for more details.
-;; 
-;;     You should have received a copy of the GNU General Public License
-;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
-
-
-(declare (uses portlogger))
-
-(print (apply portlogger:main (cdr (argv))))

Index: portlogger.scm
==================================================================
--- portlogger.scm
+++ portlogger.scm
@@ -22,10 +22,19 @@
 (use sqlite3 srfi-1 posix srfi-69 hostinfo dot-locking z3)
 (import (prefix sqlite3 sqlite3:))
 
 (declare (unit portlogger))
 (declare (uses db))
+
+(declare (uses commonmod))
+(import commonmod)
+
+(declare (uses configfmod))
+(import configfmod)
+
+(declare (uses dbmod))
+(import dbmod)
 
 ;; 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: process.scm
==================================================================
--- process.scm
+++ process.scm
@@ -23,205 +23,8 @@
 ;;======================================================================
 
 (use regex directory-utils)
 (declare (unit process))
 
-(define (process:conservative-read port)
-  (let loop ((res ""))
-    (if (not (eof-object? (peek-char port)))
-	(loop (conc res (read-char port)))
-	res)))
-
-(define (process:cmd-run-with-stderr->list cmd . params)
-  ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params)
-;;  (handle-exceptions
-;;   exn
-;;   (begin
-;;     (print "ERROR:  Failed to run command: " cmd " " (string-intersperse params " "))
-;;     (print "       " ((condition-property-accessor 'exn 'message) exn))
-;;     #f)
-   (let-values (((fh fho pid fhe) (if (null? params)
-				      (process* cmd)
-				      (process* cmd params))))
-       (let loop ((curr (read-line fh))
-		  (result  '()))
-	 (let ((errstr (process:conservative-read fhe)))
-	   (if (not (string=? errstr ""))
-	       (set! result (append result (list errstr)))))
-       (if (not (eof-object? curr))
-	   (loop (read-line fh)
-		 (append result (list curr)))
-	   (begin
-	     (close-input-port fh)
-	     (close-input-port fhe)
-	     (close-output-port fho)
-	     result))))) ;; )
-
-(define (process:cmd-run-with-stderr-and-exitcode->list cmd . params)
-  ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params)
-;;  (handle-exceptions
-;;   exn
-;;   (begin
-;;     (print "ERROR:  Failed to run command: " cmd " " (string-intersperse params " "))
-;;     (print "       " ((condition-property-accessor 'exn 'message) exn))
-;;     #f)
-   (let-values (((fh fho pid fhe) (if (null? params)
-				      (process* cmd)
-				      (process* cmd params))))
-       (let loop ((curr (read-line fh))
-		  (result  '()))
-	 (let ((errstr (process:conservative-read fhe)))
-	   (if (not (string=? errstr ""))
-	       (set! result (append result (list errstr)))))
-       (if (not (eof-object? curr))
-	   (loop (read-line fh)
-		 (append result (list curr)))
-	   (begin
-             (let-values (((anotherpid normalexit? exitstatus)  (process-wait pid)))
-	     (close-input-port fh)
-	     (close-input-port fhe)
-	     (close-output-port fho)
-               (list result (if normalexit? exitstatus -1))))))))
-
-(define (process:cmd-run-proc-each-line cmd proc . params)
-  ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params)
-  (handle-exceptions
-   exn
-   (begin
-     (print "ERROR:  Failed to run command: " cmd " " (string-intersperse params " "))
-     (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
-     (debug:print 5 *default-log-port* "exn=" (condition->list exn))
-     #f)
-   (let-values (((fh fho pid) (if (null? params)
-				  (process cmd)
-				  (process cmd params))))
-       (let loop ((curr (read-line fh))
-		(result  '()))
-       (if (not (eof-object? curr))
-	   (loop (read-line fh)
-		 (append result (list (proc curr))))
-	   (begin
-	     (close-input-port fh)
-	     ;;(close-input-port fhe)
-	     (close-output-port fho)
-	     result))))))
-
-(define (process:cmd-run-proc-each-line-alt cmd proc)
-  (let* ((fh (open-input-pipe cmd))
-         (res (port-proc->list fh proc))
-         (status (close-input-pipe fh)))
-    (if (eq? status 0) res #f)))
-
-(define (process:cmd-run->list cmd #!key (delta-env-alist-or-hash-table '()))
-  (common:with-env-vars
-   delta-env-alist-or-hash-table
-   (lambda ()
-     (let* ((fh (open-input-pipe cmd))
-            (res (port->list fh))
-            (status (close-input-pipe fh)))
-       (list res status)))))
-   
-(define (port->list fh)
-  (if (eof-object? fh) #f
-      (let loop ((curr (read-line fh))
-                 (result '()))
-        (if (not (eof-object? curr))
-            (loop (read-line fh)
-                  (append result (list curr)))
-            result))))
-
-(define (port-proc->list fh proc)
-  (if (eof-object? fh) #f
-      (let loop ((curr (proc (read-line fh)))
-                 (result '()))
-        (if (not (eof-object? curr))
-            (loop (let ((l (read-line fh)))
-                    (if (eof-object? l) l (proc l)))
-                  (append result (list curr)))
-            result))))
-
-;; here is an example line where the shell is sh or bash
-;; "find / -print 2&>1 > findall.log"
-(define (run-n-wait cmdline #!key (params #f)(print-cmd #f)(run-dir #f))
-  (if print-cmd 
-      (debug:print 0 *default-log-port* 
-		   (if (string? print-cmd)
-		       print-cmd
-		       "")
-		   (if run-dir (conc "Run in " run-dir ";") "")
-		   cmdline
-		   (if params
-		       (conc " " (string-intersperse params " "))
-		       "")))
-  (if (and run-dir
-	   (directory-exists? run-dir))
-      (push-directory run-dir))
-  (let ((pid (if params
-		 (process-run cmdline params)
-		 (process-run cmdline))))
-    (let loop ((i 0))
-      (let-values (((pid-val exit-status exit-code) (process-wait pid #t)))
-         (if (eq? pid-val 0)
-	     (begin
-	       (thread-sleep! 2)
-	       (loop (+ i 1)))
-	     (begin
-	       (if (and run-dir
-			(directory-exists? run-dir))
-		   (pop-directory))
-	       (values pid-val exit-status exit-code)))))))
-  
-;;======================================================================
-;; MISC PROCESS RELATED STUFF
-;;======================================================================
-
-(define (process:children proc)
-  (with-input-from-pipe
-   (conc "ps h --ppid " (current-process-id) " -o pid")
-   (lambda ()
-     (let loop ((inl (read-line))
-		(res '()))
-       (if (eof-object? inl)
-	   (reverse res)
-	   (let ((pid (string->number inl)))
-	     (if proc (proc pid))
-	     (loop (read-line) (cons pid res))))))))
-
-(define (process:alive? pid)
-  (handle-exceptions
-   exn
-   ;; possibly pid is a process not a child, look in /proc to see if it is running still
-   (common:file-exists? (conc "/proc/" pid))
-   (let-values (((rpid exit-type exit-signal)(process-wait pid #t)))
-       (and (number? rpid)
-	    (equal? rpid pid)))))
-
-(define (process:alive-on-host? host pid)
-  (let ((cmd (conc "ssh " host " ps -o pid= -p " pid)))
-    (handle-exceptions
-	exn
-      (begin
-	(debug:print 0 *default-log-port* "failed to identify if process " pid ", on host " host " is alive. exn=" exn)
-	#f) ;; anything goes wrong - assume the process in NOT running.
-     (with-input-from-pipe 
-      cmd
-      (lambda ()
-	(let loop ((inl (read-line)))
-	  (if (eof-object? inl)
-	      #f
-	      (let* ((clean-str (string-substitute "^[^\\d]*([0-9]+)[^\\d]*$" "\\1" inl))
-		     (innum     (string->number clean-str)))
-		(and innum
-		     (eq? pid innum))))))))))
-
-(define (process:get-sub-pids pid)
-  (with-input-from-pipe
-   (conc "pstree -A -p " pid) ;; | tr 'a-z\\-+`()\\.' ' ' " pid)
-   (lambda ()
-     (let loop ((inl (read-line))
-		(res '()))
-       (if (eof-object? inl)
-	   (reverse res)
-	   (let ((nums (map string->number
-			    (string-split-fields "\\d+" inl))))
-	     (loop (read-line)
-		   (append res nums))))))))
+(declare (uses commonmod))
+(import commonmod)
+

Index: rmt.scm
==================================================================
--- rmt.scm
+++ rmt.scm
@@ -21,10 +21,30 @@
 (use format typed-records) ;; RADT => purpose of json format??
 
 (declare (unit rmt))
 (declare (uses api))
 (declare (uses http-transport))
+
+(declare (uses commonmod))
+(import commonmod)
+
+(declare (uses apimod))
+(import apimod)
+
+(declare (uses rmtmod))
+(import rmtmod)
+
+;; should not be here
+(declare (uses dbmod))
+(import dbmod)
+
+(declare (uses configfmod))
+(import configfmod)
+
+(declare (uses servermod))
+(import servermod)
+
 (include "common_records.scm")
 ;; (declare (uses rmtmod))
 
 ;; (import rmtmod)
 
@@ -54,12 +74,22 @@
 		  (client:setup areapath)
 		  #f))))
 
 ;;======================================================================
 
-(define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id
+(define (create-remote-record)
+  (let ((rr (make-remote)))
+    (rmt:init-remote rr)
+    rr))
 
+(define (rmt:init-remote rr)
+  (remote-hh-dat-set!         rr (common:get-homehost)) ;
+  (remote-server-info-set!    rr (if *toppath* (server:check-if-running *toppath*) #f))
+  (remote-transport-set!      rr *transport-type*)
+  (remote-server-timeout-set! rr (server:expiration-timeout))
+  rr)
+  
 ;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname))
 ;;
 (define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected
 
   #;(common:telemetry-log (conc "rmt:"(->string cmd))
@@ -83,11 +113,22 @@
   ;;DOT   node [shape="box"];
   ;;DOT "rmt:send-receive" -> MUTEXLOCK;
   ;;DOT { edge [style=invis];"case 1" -> "case 2" -> "case 3" -> "case 4" -> "case 5" -> "case 6" -> "case 7" -> "case 8" -> "case 9" -> "case 10" -> "case 11"; }
   ;; do all the prep locked under the rmt-mutex
   (mutex-lock! *rmt-mutex*)
-  
+
+  ;; set up runremote record earlier than the loop below
+  (if (not *runremote*)                   ;; can remove this one. should never get here.         
+      (begin
+	(set! *runremote* (create-remote-record))
+	(let* ((server-info (remote-server-info *runremote*))) 
+	  (if server-info
+	      (begin
+		(remote-server-url-set! *runremote* (server:record->url server-info))
+		(remote-server-id-set! *runremote* (server:record->id server-info)))))  
+	#;(set! area-dat *runremote*))) ;; new runremote will come from this on next iteration
+    
   ;; 1. check if server is started IFF cmd is a write OR if we are not on the homehost, store in runremote
   ;; 2. check the age of the connections. refresh the connection if it is older than timeout-20 seconds.
   ;; 3. do the query, if on homehost use local access
   ;;
   (let* ((start-time    (current-seconds)) ;; snapshot time so all use cases get same value
@@ -99,20 +140,10 @@
 
     ;; DOT INIT_RUNREMOTE; // leaving off - doesn't really add to the clarity
     ;; DOT MUTEXLOCK -> INIT_RUNREMOTE [label="no remote?"];
     ;; DOT INIT_RUNREMOTE -> MUTEXLOCK;
     ;; ensure we have a record for our connection for given area
-    (if (not runremote)                   ;; can remove this one. should never get here.         
-	(begin
-	  (set! *runremote* (make-remote))
-          (let* ((server-info (remote-server-info *runremote*))) 
-            (if server-info
-		(begin
-			(remote-server-url-set! *runremote* (server:record->url server-info))
-			(remote-server-id-set! *runremote* (server:record->id server-info)))))  
-	  (set! runremote   *runremote*))) ;; new runremote will come from this on next iteration
-    
     ;; DOT SET_HOMEHOST; // leaving off - doesn't really add to the clarity
     ;; DOT MUTEXLOCK -> SET_HOMEHOST [label="no homehost?"];
     ;; DOT SET_HOMEHOST -> MUTEXLOCK;
     ;; ensure we have a homehost record
     (if (not (pair? (remote-hh-dat runremote)))  ;; not on homehost
@@ -182,11 +213,11 @@
      ;; on homehost and this is a write, we already have a server, but server has died
      ((and (cdr (remote-hh-dat runremote))           ;; on homehost
            (not (member cmd api:read-only-queries))  ;; this is a write
            (remote-server-url runremote)             ;; have a server
            (not (server:ping (remote-server-url runremote) (remote-server-id runremote))))  ;; server has died. NOTE: this is not a cheap call! Need better approach.
-      (set! *runremote* (make-remote))
+      (set! *runremote* (create-remote-record)) 
       (let* ((server-info (remote-server-info *runremote*))) 
             (if server-info
 		(begin
 		  (remote-server-url-set! *runremote* (server:record->url server-info))
                   (remote-server-id-set! *runremote* (server:record->id server-info)))))
@@ -369,11 +400,11 @@
     (mutex-unlock! *db-stats-mutex*)
     res))
 
 (define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5))
   (let* ((qry-is-write   (not (member cmd api:read-only-queries)))
-	 (db-file-path   (db:dbfile-path)) ;;  0))
+	 (db-file-path   (common:get-db-tmp-area)) ;; db:dbfile-path)) ;;  0))
 	 (dbstruct-local (db:setup #t))  ;; make-dbr:dbstruct path:  dbdir local: #t)))
 	 (read-only      (not (file-write-access? db-file-path)))
 	 (start          (current-milliseconds))
 	 (resdat         (if (not (and read-only qry-is-write))
 			     (let ((v (api:execute-requests dbstruct-local (vector (symbol->string cmd) params))))
@@ -406,11 +437,11 @@
 	  ;; (rmt:update-db-stats run-id cmd params duration)
 	  ;; mark this run as dirty if this was a write, the watchdog is responsible for syncing it
 	  (if qry-is-write
 	      (let ((start-time (current-seconds)))
 		(mutex-lock! *db-multi-sync-mutex*)
-/		(set! *db-last-access* start-time)  ;; THIS IS PROBABLY USELESS? (we are on a client)
+		(set! *db-last-access* start-time)  ;; THIS IS PROBABLY USELESS? (we are on a client)
                 (mutex-unlock! *db-multi-sync-mutex*)))))
     res))
 
 (define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params)
   (let* ((run-id   (if run-id run-id 0))
@@ -443,10 +474,11 @@
 ;;======================================================================
 ;;  M I S C
 ;;======================================================================
 
 (define (rmt:login run-id)
+  (assert *my-client-signature* "ERROR: login attempted without first calling (client:get-signature).")
   (rmt:send-receive 'login run-id (list *toppath* megatest-version *my-client-signature*)))
 
 ;; This login does no retries under the hood - it acts a bit like a ping.
 ;; Deprecated for nmsg-transport.
 ;;
@@ -679,11 +711,13 @@
 
 (define (rmt:get-prereqs-not-met run-id waitons ref-test-name ref-item-path #!key (mode '(normal))(itemmaps #f))
   (rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-test-name ref-item-path mode itemmaps)))
 
 (define (rmt:get-count-tests-running-for-run-id run-id)
-  (rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id)))
+  (if (number? run-id)
+      (rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id))
+      0))
 
 (define (rmt:get-not-completed-cnt run-id)
   (rmt:send-receive 'get-not-completed-cnt run-id (list run-id)))
 
 
@@ -968,24 +1002,10 @@
   (rmt:send-receive 'test-set-archive-block-id run-id (list run-id test-id archive-block-id)))
 
 (define (rmt:test-get-archive-block-info archive-block-id)
   (rmt:send-receive 'test-get-archive-block-info #f (list archive-block-id)))
 
-
-(define (rmtmod:calc-ro-mode runremote *toppath*)
-  (if (and runremote
-	   (remote-ro-mode-checked runremote))
-      (remote-ro-mode runremote)
-      (let* ((dbfile  (conc *toppath* "/megatest.db"))
-	     (ro-mode (not (file-write-access? dbfile)))) ;; TODO: use dbstruct or runremote to figure this out in future
-	(if runremote
-	    (begin
-	      (remote-ro-mode-set! runremote ro-mode)
-	      (remote-ro-mode-checked-set! runremote #t)
-	      ro-mode)
-	    ro-mode))))
-
 (define (extras-readonly-mode rmt-mutex log-port cmd params)
   (mutex-unlock! rmt-mutex)
   (debug:print-info 12 log-port "rmt:send-receive, case 3")
   (debug:print 0 log-port "WARNING: write transaction requested on a readonly area.  cmd="cmd" params="params)
   #f)

Index: rmtmod.scm
==================================================================
--- rmtmod.scm
+++ rmtmod.scm
@@ -19,67 +19,34 @@
 ;;======================================================================
 
 (declare (unit rmtmod))
 (declare (uses commonmod))
 (declare (uses apimod))
-;; (declare (uses apimod.import))
-(declare (uses ulex))
-
-;; (include "ulex/ulex.scm")
+(declare (uses dbmod))
 
 (module rmtmod
 	*
 	
 (import scheme chicken data-structures extras)
 (import (prefix sqlite3 sqlite3:) posix typed-records srfi-18)
-(import (prefix commonmod cmod:))
+(import commonmod)
+(import dbmod)
 (import apimod)
-(import (prefix ulex ulex:))
 
 (defstruct alldat
   (areapath #f)
   (ulexdat  #f)
   )
 
-;;======================================================================
-;; return the handle struct for sending queries to a specific database
-;;  - initializes the connection object if this is the first access
-;;    - finds the "captain" and asks who to talk to for the given dbfname
-;;    - establishes the connection to the current dbowner
-;;
-#;(define (rmt:connect alldat dbfname dbtype)
-  (let* ((ulexdat    (or (alldat-ulexdat alldat)
-			 (rmt:setup-ulex alldat))))
-    (ulex:connect ulexdat dbfname dbtype)))
-
-;; setup the remote calls
-#;(define (rmt:setup-ulex alldat)
-  (let* ((udata (ulex:setup))) ;; establish connection to ulex
-    (alldat-ulexdat-set! alldat udata)
-    ;; register all needed procs
-    (ulex:register-handler udata 'ping cmod:get-full-version)  ;; override ping with get-full-version
-    (ulex:register-handler udata 'login cmod:get-full-version) ;; force setup of the connection
-    (ulex:register-handler udata 'execute api:execute-requests)
-    udata))
-
-;; set up a connection to the current owner of the dbfile associated with rid
-;; then send the query to that dbfile owner and wait for a response.
-;;
-#;(define (rmt:send-receive alldat cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected
-  (let* (;; (alldat   *alldat*)
-	 (areapath (alldat-areapath alldat))
-	 (dbtype   (if (or (not rid)(< rid 1)) ;; this is the criteria for "main.db"
-		       "main" "runs"))
-	 (dbfname  (if (equal? dbtype "main")
-		       "main.db"
-		       (conc rid ".db")))
-	 (dbfile   (conc areapath "/.db/" dbfname))
-	 (ulexconn (rmt:connect alldat dbfname dbtype))  ;; ulexconn is our new *runremote*, it is a dbowner struct < pdat lastrefresh >
-	 (udata    (alldat-ulexdat alldat)))
-    	(ulex:remote-request udata ulexconn 'immediate dbfile 'execute rid params)))
-    ;; need to call this on the other side 
-    ;; (api:execute-requests dbstruct-local (vector (symbol->string cmd) params))))
-    
-    #;(with-input-from-string
-	(ulex:remote-request udata ulexconn 'immediate dbfile 'execute rid (with-output-to-string (lambda ()(serialize params))))
-       (lambda ()(deserialize)))
+(define (rmtmod:calc-ro-mode runremote *toppath*)
+  (if (and runremote
+	   (remote-ro-mode-checked runremote))
+      (remote-ro-mode runremote)
+      (let* ((ro-mode (not (db:writeable *toppath* "megatest.db"))))
+	(if runremote
+	    (begin
+	      (remote-ro-mode-set! runremote ro-mode)
+	      (remote-ro-mode-checked-set! runremote #t)
+	      ro-mode)
+	    ro-mode))))
+
 )

Index: runconfig.scm
==================================================================
--- runconfig.scm
+++ runconfig.scm
@@ -22,10 +22,13 @@
 
 (use format directory-utils)
 
 (declare (unit runconfig))
 (declare (uses common))
+
+(declare (uses commonmod))
+(import commonmod)
 
 (include "common_records.scm")
 
 (define (runconfig:read fname target environ-patt)
   (let ((ht (make-hash-table)))

Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -29,10 +29,22 @@
 (declare (uses tests))
 (declare (uses server))
 (declare (uses mt))
 (declare (uses archive))
 ;; (declare (uses filedb))
+
+(declare (uses commonmod))
+(import commonmod)
+
+(declare (uses configfmod))
+(import configfmod)
+
+(declare (uses dbmod))
+(import dbmod)
+
+(declare (uses servermod))
+(import servermod)
 
 (include "common_records.scm")
 (include "key_records.scm")
 (include "db_records.scm")
 (include "run_records.scm")
@@ -804,11 +816,14 @@
 					      (for-each (lambda (run-id)
 							  (if keep-going
 							      (handle-exceptions
 							       exn
 							       (debug:print 0 *default-log-port* "error in calling find-and-mark-incomplete for run-id " run-id ", exn=" exn)
-							       (rmt:find-and-mark-incomplete run-id #f)))) ;; ovr-deadtime))) ;; could be root of https://hsdes.intel.com/appstore/article/#/220546828/main -- Title: Megatest jobs show DEAD even though they are still running (1.64/27)
+							       (rmt:find-and-mark-incomplete run-id #f)
+							       (launch:end-of-run-check run-id)
+
+							       ))) ;; ovr-deadtime))) ;; could be root of https://hsdes.intel.com/appstore/article/#/220546828/main -- Title: Megatest jobs show DEAD even though they are still running (1.64/27)
 							run-ids)))
 					  "runs: mark-incompletes")))
 	    ;; (thread-start! th1)
 	    (thread-start! th2)
 	    ;; (thread-join! th1)
@@ -1268,11 +1283,11 @@
      ((not have-resources) ;; simply try again after waiting a second
       (if (runs:lownoise "no resources" 60)
 	  (debug:print-info 1 *default-log-port* "no resources to run new tests, waiting ..."))
       ;; Have gone back and forth on this but db starvation is an issue.
       ;; wait one second before looking again to run jobs.
-      (thread-sleep! 0.25)
+      (thread-sleep! 1) ;; changed back to 1 from 0.25
       ;; could have done hed tal here but doing car/cdr of newtal to rotate tests
       (list (car newtal)(cdr newtal) reg reruns))
      
      ;; This is the final stage, everything is in place so launch the test
      ;;
@@ -1903,10 +1918,12 @@
 		(let ((actual-num-running (rmt:get-count-tests-running-for-run-id run-id)))
 		  (debug:print-info 0 *default-log-port* "Marking stuck tests as INCOMPLETE while waiting for run " run-id
 				    ". Running as pid " (current-process-id) " on " (get-host-name))
 		  (set! last-time-incomplete (current-seconds)) ;; FIXME, this might be causing slow down - use of set!
 		  (rmt:find-and-mark-incomplete run-id #f)
+		  ;;call end of eud of run detection for posthook
+		  (launch:end-of-run-check run-id)
 		  (debug:print-info 0 *default-log-port* "run-wait specified, waiting on " actual-num-running
 				    " tests in RUNNING, REMOTEHOSTSTART or LAUNCHED state at "
 				    (time->string (seconds->local-time (current-seconds))))))
 	    ;; (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat)))
 	    (thread-sleep! 5) ;; (if (>= num-running max-concurrent-jobs) 5 1))

DELETED sample-sauth-paths.scm
Index: sample-sauth-paths.scm
==================================================================
--- sample-sauth-paths.scm
+++ /dev/null
@@ -1,22 +0,0 @@
-;;  Copyright 2006-2017, Matthew Welland.
-;; 
-;; This file is part of Megatest.
-;; 
-;;     Megatest is free software: you can redistribute it and/or modify
-;;     it under the terms of the GNU General Public License as published by
-;;     the Free Software Foundation, either version 3 of the License, or
-;;     (at your option) any later version.
-;; 
-;;     Megatest is distributed in the hope that it will be useful,
-;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;     GNU General Public License for more details.
-;; 
-;;     You should have received a copy of the GNU General Public License
-;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
-;;
-(define *db-path* "/path/to/db") 
-(define *exe-path* "/path/to/store/suids")  
-(define *exe-src* "/path/to/spublish/and/sretrieve/executables")
-(define *sauth-path* "/path/to/production/sauthorize/exe")
-(define *super-users* '("user1" "user2"))

DELETED sauth-common.scm
Index: sauth-common.scm
==================================================================
--- sauth-common.scm
+++ /dev/null
@@ -1,328 +0,0 @@
-;;  Copyright 2006-2017, Matthew Welland.
-;; 
-;; This file is part of Megatest.
-;; 
-;;     Megatest is free software: you can redistribute it and/or modify
-;;     it under the terms of the GNU General Public License as published by
-;;     the Free Software Foundation, either version 3 of the License, or
-;;     (at your option) any later version.
-;; 
-;;     Megatest is distributed in the hope that it will be useful,
-;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;     GNU General Public License for more details.
-;; 
-;;     You should have received a copy of the GNU General Public License
-;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
-
-
-;; Create the sqlite db
-(define (sauthorize:db-do proc) 
-      (if (or (not *db-path*)
-              (not (file-exists? *db-path*))) 
-	(begin
-	  (print 0 "[database]\nlocation " *db-path* " \n\n Is missing from the config file!")
-	  (exit 1)))
-    (if (and *db-path*
-	     (directory? *db-path*)
-	     (file-read-access? *db-path*))
-	(let* ((dbpath    (conc *db-path* "/sauthorize.db"))
-	       (writeable (file-write-access? dbpath))
-	       (dbexists  (file-exists? dbpath)))
-	  (handle-exceptions
-	   exn
-	   (begin
-	     (print 2 "ERROR: problem accessing db " dbpath
-			  ((condition-property-accessor 'exn 'message) exn))
-	     (exit 1))
-            ;(print  "calling proc " proc "db path " dbpath )
-	   (call-with-database
-            dbpath
-	    (lambda (db)
-	       ;(print 0 "calling proc " proc " on db " db)
-	      (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout
-	      (if (not dbexists)(sauthorize:initialize-db db))
-	      (proc db)))))
-	(print 0 "ERROR: invalid path for storing database: " *db-path*)))
-
-;;execute a query
-(define (sauthorize:db-qry db qry)
-  ;(print qry)
-  (exec (sql db  qry)))
-
-
-(define (sauthorize:do-as-calling-user proc)
-  (let ((eid (current-effective-user-id))
-        (cid (current-user-id)))
-    (if (not (eq? eid cid)) ;; running suid
-            (set! (current-effective-user-id) cid))
-     ;(print 0 "cid " cid " eid:" eid)
-    (proc)
-    (if (not (eq? eid cid))
-        (set! (current-effective-user-id) eid))))
-
-
-(define (run-cmd cmd arg-list)
-  ; (print (current-effective-user-id))
-   ;(handle-exceptions
-;	     exn
-;	     (print 0 "ERROR: failed to run script " cmd " with params " arg-list " " (exn assert))
-	     (let ((pid (process-run cmd arg-list)))
-	       (process-wait pid))
-)
-;)
-
-
-(define (regster-log inl usr-id  area-id  cmd)
-  (sauth-common:shell-do-as-adm
-        (lambda ()
-         (sauthorize:db-do   (lambda (db)
-             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sretrieve " inl "'," usr-id ","  area-id ", 'cat' )")))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-; Check user types
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-
-;;check if a user is an admin
-(define (is-admin username)
-   (let* ((admin #f))
-    (sauthorize:db-do  (lambda (db)
-        (let* ((data-row (query fetch (sql db (conc "SELECT users.is_admin FROM  users where users.username = '" username "'")))))
-        (if (not (null? data-row))
-             (let ((col  (car data-row)))
-             (if (equal? col "yes")
-                   (set! admin #t)))))))  	        
-admin))
-
-
-;;check if a user is an read-admin
-(define (is-read-admin username)
-   (let* ((admin #f))
-    (sauthorize:db-do  (lambda (db)
-        (let* ((data-row (query fetch (sql db (conc "SELECT users.is_admin FROM  users where users.username = '" username "'")))))
-        (if (not (null? data-row))
-             (let ((col  (car data-row)))
-             (if (equal? col "read-admin")
-                   (set! admin #t)))))))  	        
-admin))
-
-
-;;check if user has specifc role for a area
-(define (is-user role username area)
-  (let* ((has-access #f))
-    (sauthorize:db-do  (lambda (db)
-        (let* ((data-row (query fetch (sql db (conc "SELECT  permissions.access_type, permissions.expiration FROM  users ,  areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and users.username = '" username "' and areas.code = '" area "'")))))
-        (if (not (null? data-row))
-           (begin
-               (let* ((access-type  (car data-row))
-                    (exdate (cadr data-row)))
-               (if (not (null? exdate)) 
-               (begin 
-                  (let ((valid (is-access-valid  exdate)))
-                   ;(print valid) 
-                  (if (and (equal? access-type role)
-                        (equal? valid #t))
-                   (set! has-access #t))))
-                (print "Access expired"))))))))
- ;(print has-access)
-has-access))
-
-(define (is-access-valid exp-str)
-    (let* ((ret-val #f )
-           (date-parts  (string-split exp-str "/"))
-           (yr (string->number (car date-parts)))
-           (month (string->number(car (cdr date-parts)))) 
-           (day (string->number(caddr date-parts)))
-           (exp-date (make-date 0 0 0 0 day month yr )))
-             ;(print  exp-date)
-             ;(print (current-date))   
-            (if (> (date-compare exp-date  (current-date)) 0)
-             (set! ret-val #t))
-   ;(print ret-val)
-   ret-val))
-
-
-;check if area exists
-(define (area-exists area)
-   (let* ((area-defined #f))
-    (sauthorize:db-do  (lambda (db)
-        (let* ((data-row (query fetch (sql db (conc "SELECT  id FROM  areas where areas.code = '" area "'")))))
-           (if (not (null? data-row))
-                 (set! area-defined #t)))))
-area-defined))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-; Get Record from database
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;gets area id by code 
-(define (get-area area)
-   (let* ((area-defined '()))
-    (sauthorize:db-do  (lambda (db)
-        (let* ((data-row (query fetch (sql db (conc "SELECT  id FROM  areas where areas.code = '" area "'")))))
-          (set!  area-defined data-row))))
-area-defined))
-
-;get id of users table by user name 
-(define (get-user user)
-  (let* ((user-defined '()))
-    (sauthorize:db-do  (lambda (db)
-        (let* ((data-row (query fetch (sql db (conc "SELECT  id FROM  users where users.username = '" user "'")))))
-          (set!  user-defined data-row))))
-user-defined))
-
-;get permissions id by userid and area id 
-(define (get-perm userid areaid)
-  (let* ((user-defined '()))
-    (sauthorize:db-do  (lambda (db)
-          (let* ((data-row (query fetch (sql db (conc "SELECT  id FROM  permissions where user_id = " userid " and area_id = " areaid)))))
-         (set!  user-defined data-row))))
-
-user-defined))
-
-(define (get-restrictions base-path usr)
-(let* ((user-defined '()))
-    (sauthorize:db-do  (lambda (db)
-          (let* ((data-row (query fetch (sql db (conc "SELECT  restriction FROM areas, users, permissions where  areas.id = permissions.area_id and users.id =  permissions.user_id and  users.username = '" usr "' and areas.basepath = '" base-path "'")))))
-         ;(print data-row) 
-         (set!  user-defined data-row))))
-    ;   (print user-defined)
-  (if (null? user-defined)
-      ""
-      (car user-defined))))
-
-
-(define (get-obj-by-path path)
-   (let* ((obj '()))
-    (sauthorize:db-do  (lambda (db)
-        (let* ((data-row (query fetch (sql db (conc "SELECT  code,exe_name, id, basepath FROM  areas where areas.basepath = '" path "'")))))
-         (set!  obj data-row))))
-obj))
-
-(define (get-obj-by-code code )
-  (let* ((obj '()))
-    (sauthorize:db-do  (lambda (db)
-        ;(print (conc "SELECT  code, exe_name,  id, basepath, required_grps  FROM  areas where areas.code = '" code "'"))
-        (let* ((data-row (query fetch (sql db (conc "SELECT  code, exe_name,  id, basepath, required_grps  FROM  areas where areas.code = '" code "'")))))
-         ;(print data-row)
-         (set!  obj data-row)
-         ;(print obj) 
-        )))
-    (if (not (null? obj))
-          (begin
-          (let* ((req-grp (caddr (cddr obj))))
-            (sauthorize:do-as-calling-user
-             (lambda ()
- (sauth-common:check-user-groups req-grp))))))
-obj))
-
-(define (sauth-common:check-user-groups req-grp)
-(let* ((current-groups  (get-groups) )
-        (req-grp-list (string-split req-grp ",")))
-        ;(print req-grp-list)
-        (for-each (lambda (grp)
-	  (let ((grp-info (group-information grp)))
-               ;(print grp-info " " grp)
-               (if (not (equal? grp-info #f))
-               (begin
-                 (if (not (member  (caddr grp-info) current-groups))
-                  (begin 
-                    (sauth:print-error (conc "Please wash " grp " group in your xterm!! " ))
-                     (exit 1)))))))
-	     req-grp-list)))
-
-(define (get-obj-by-code-no-grp-validation code )
-  (let* ((obj '()))
-    (sauthorize:db-do  (lambda (db)
-        (let* ((data-row (query fetch (sql db (conc "SELECT  code, exe_name,  id, basepath  FROM  areas where areas.code = '" code "'")))))
-         (set!  obj data-row))))
-;(print obj)
-obj))
-
-
-(define (sauth-common:src-size path)
-  (let ((output (with-input-from-pipe (conc "/usr/bin/du -s " path  "  | awk '{print $1}'")  
-                 (lambda()
-                  (read-line)))))
-      (string->number output)))  
-
-(define (sauth-common:space-left-at-dest path)
-   (let* ((output  (run/string (pipe (df ,path ) (tail -1))))
-         (size (caddr (cdr (string-split output " ")))))
-  (string->number size)))
-
-;; function to validate the users input for target path and resolve the path
-;; TODO: Check for restriction in subpath 
-(define (sauth-common:resolve-path  new current allowed-sheets)
-   (let* ((target-path (append  current (string-split new "/")))
-          (target-path-string (string-join target-path "/"))
-          (normal-path (normalize-pathname target-path-string))
-          (normal-list (string-split normal-path "/"))
-           (ret '()))
-   (if (string-contains   normal-path "..")
-    (begin
-      (print "ERROR: Path  " new " resolved outside target area ")
-      #f)
-    (if(equal? normal-path ".")
-      ret  
-    (if (not (member  (car normal-list) allowed-sheets))
-      (begin
-      (print "ERROR: Permision denied to  " new )
-       #f)
-    normal-list)))))
-
-(define (sauth-common:get-target-path base-path-list ext-path top-areas base-path)
-  (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas ))
-          (usr (current-user-name) ) )
-          (if (not (equal? resolved-path #f))
-           (if (null? resolved-path) 
-             #f
-           (let* ((sheet (car resolved-path))
-                   (restricted-areas (get-restrictions base-path usr))
-                   (restrictions (conc ".*" (string-join (string-split restricted-areas ",") ".*|.*") ".*"))
-           	   (target-path (if (null? (cdr resolved-path)) 
-                                     base-path 
-                                     (conc base-path "/" (string-join (cdr resolved-path) "/")))))
-                    
-	              
-                           (if (and (not (equal? restricted-areas "" ))
-                             (string-match (regexp  restrictions) target-path)) 
-                           (begin
-                              (sauth:print-error (conc "Access denied to " (string-join resolved-path "/")))
-                              ;(exit 1)   
-                            #f)
-                             target-path)
-                            
-))
-             #f)))
-
-(define (sauth-common:shell-ls-cmd base-path-list ext-path top-areas base-path tail-cmd-list)
-    (if (and (null? base-path-list) (equal? ext-path "") )
-      (print (string-intersperse top-areas " "))
-  (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas )))
-           ;(print resolved-path)
-           (if (not (equal? resolved-path #f))
-           (if (null? resolved-path) 
-             (print (string-intersperse top-areas " "))
-           (let* ((target-path (sauth-common:get-target-path  base-path-list  ext-path top-areas base-path)))
-                (print target-path)
-                (if (not (equal? target-path #f))
-                (begin 
-                (cond
-		  ((null? tail-cmd-list)
-		     (run (pipe
-      	      	      (ls "-lrt" ,target-path))))
-		  ((not (equal? (car tail-cmd-list) "|"))
-                         (print "ls cmd cannot accept " (string-join tail-cmd-list) " as an argument!!"))
-                  (else  
-                    (run (pipe
-      	      	      (ls "-lrt" ,target-path)
-                      (begin (system (string-join (cdr tail-cmd-list))))))))))))))))
-
-(define (sauth:print-error msg)
-  (with-output-to-port (current-error-port)
-	(lambda ()
-	       (print (conc "ERROR: " msg)))))
-

ADDED   sauth/sample-sauth-paths.scm
Index: sauth/sample-sauth-paths.scm
==================================================================
--- /dev/null
+++ sauth/sample-sauth-paths.scm
@@ -0,0 +1,22 @@
+;;  Copyright 2006-2017, Matthew Welland.
+;; 
+;; This file is part of Megatest.
+;; 
+;;     Megatest is free software: you can redistribute it and/or modify
+;;     it under the terms of the GNU General Public License as published by
+;;     the Free Software Foundation, either version 3 of the License, or
+;;     (at your option) any later version.
+;; 
+;;     Megatest is distributed in the hope that it will be useful,
+;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;     GNU General Public License for more details.
+;; 
+;;     You should have received a copy of the GNU General Public License
+;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
+;;
+(define *db-path* "/path/to/db") 
+(define *exe-path* "/path/to/store/suids")  
+(define *exe-src* "/path/to/spublish/and/sretrieve/executables")
+(define *sauth-path* "/path/to/production/sauthorize/exe")
+(define *super-users* '("user1" "user2"))

ADDED   sauth/sauth-common.scm
Index: sauth/sauth-common.scm
==================================================================
--- /dev/null
+++ sauth/sauth-common.scm
@@ -0,0 +1,328 @@
+;;  Copyright 2006-2017, Matthew Welland.
+;; 
+;; This file is part of Megatest.
+;; 
+;;     Megatest is free software: you can redistribute it and/or modify
+;;     it under the terms of the GNU General Public License as published by
+;;     the Free Software Foundation, either version 3 of the License, or
+;;     (at your option) any later version.
+;; 
+;;     Megatest is distributed in the hope that it will be useful,
+;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;     GNU General Public License for more details.
+;; 
+;;     You should have received a copy of the GNU General Public License
+;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
+
+
+;; Create the sqlite db
+(define (sauthorize:db-do proc) 
+      (if (or (not *db-path*)
+              (not (file-exists? *db-path*))) 
+	(begin
+	  (print 0 "[database]\nlocation " *db-path* " \n\n Is missing from the config file!")
+	  (exit 1)))
+    (if (and *db-path*
+	     (directory? *db-path*)
+	     (file-read-access? *db-path*))
+	(let* ((dbpath    (conc *db-path* "/sauthorize.db"))
+	       (writeable (file-write-access? dbpath))
+	       (dbexists  (file-exists? dbpath)))
+	  (handle-exceptions
+	   exn
+	   (begin
+	     (print 2 "ERROR: problem accessing db " dbpath
+			  ((condition-property-accessor 'exn 'message) exn))
+	     (exit 1))
+            ;(print  "calling proc " proc "db path " dbpath )
+	   (call-with-database
+            dbpath
+	    (lambda (db)
+	       ;(print 0 "calling proc " proc " on db " db)
+	      (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout
+	      (if (not dbexists)(sauthorize:initialize-db db))
+	      (proc db)))))
+	(print 0 "ERROR: invalid path for storing database: " *db-path*)))
+
+;;execute a query
+(define (sauthorize:db-qry db qry)
+  ;(print qry)
+  (exec (sql db  qry)))
+
+
+(define (sauthorize:do-as-calling-user proc)
+  (let ((eid (current-effective-user-id))
+        (cid (current-user-id)))
+    (if (not (eq? eid cid)) ;; running suid
+            (set! (current-effective-user-id) cid))
+     ;(print 0 "cid " cid " eid:" eid)
+    (proc)
+    (if (not (eq? eid cid))
+        (set! (current-effective-user-id) eid))))
+
+
+(define (run-cmd cmd arg-list)
+  ; (print (current-effective-user-id))
+   ;(handle-exceptions
+;	     exn
+;	     (print 0 "ERROR: failed to run script " cmd " with params " arg-list " " (exn assert))
+	     (let ((pid (process-run cmd arg-list)))
+	       (process-wait pid))
+)
+;)
+
+
+(define (regster-log inl usr-id  area-id  cmd)
+  (sauth-common:shell-do-as-adm
+        (lambda ()
+         (sauthorize:db-do   (lambda (db)
+             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sretrieve " inl "'," usr-id ","  area-id ", 'cat' )")))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; Check user types
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+
+;;check if a user is an admin
+(define (is-admin username)
+   (let* ((admin #f))
+    (sauthorize:db-do  (lambda (db)
+        (let* ((data-row (query fetch (sql db (conc "SELECT users.is_admin FROM  users where users.username = '" username "'")))))
+        (if (not (null? data-row))
+             (let ((col  (car data-row)))
+             (if (equal? col "yes")
+                   (set! admin #t)))))))  	        
+admin))
+
+
+;;check if a user is an read-admin
+(define (is-read-admin username)
+   (let* ((admin #f))
+    (sauthorize:db-do  (lambda (db)
+        (let* ((data-row (query fetch (sql db (conc "SELECT users.is_admin FROM  users where users.username = '" username "'")))))
+        (if (not (null? data-row))
+             (let ((col  (car data-row)))
+             (if (equal? col "read-admin")
+                   (set! admin #t)))))))  	        
+admin))
+
+
+;;check if user has specifc role for a area
+(define (is-user role username area)
+  (let* ((has-access #f))
+    (sauthorize:db-do  (lambda (db)
+        (let* ((data-row (query fetch (sql db (conc "SELECT  permissions.access_type, permissions.expiration FROM  users ,  areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and users.username = '" username "' and areas.code = '" area "'")))))
+        (if (not (null? data-row))
+           (begin
+               (let* ((access-type  (car data-row))
+                    (exdate (cadr data-row)))
+               (if (not (null? exdate)) 
+               (begin 
+                  (let ((valid (is-access-valid  exdate)))
+                   ;(print valid) 
+                  (if (and (equal? access-type role)
+                        (equal? valid #t))
+                   (set! has-access #t))))
+                (print "Access expired"))))))))
+ ;(print has-access)
+has-access))
+
+(define (is-access-valid exp-str)
+    (let* ((ret-val #f )
+           (date-parts  (string-split exp-str "/"))
+           (yr (string->number (car date-parts)))
+           (month (string->number(car (cdr date-parts)))) 
+           (day (string->number(caddr date-parts)))
+           (exp-date (make-date 0 0 0 0 day month yr )))
+             ;(print  exp-date)
+             ;(print (current-date))   
+            (if (> (date-compare exp-date  (current-date)) 0)
+             (set! ret-val #t))
+   ;(print ret-val)
+   ret-val))
+
+
+;check if area exists
+(define (area-exists area)
+   (let* ((area-defined #f))
+    (sauthorize:db-do  (lambda (db)
+        (let* ((data-row (query fetch (sql db (conc "SELECT  id FROM  areas where areas.code = '" area "'")))))
+           (if (not (null? data-row))
+                 (set! area-defined #t)))))
+area-defined))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; Get Record from database
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;gets area id by code 
+(define (get-area area)
+   (let* ((area-defined '()))
+    (sauthorize:db-do  (lambda (db)
+        (let* ((data-row (query fetch (sql db (conc "SELECT  id FROM  areas where areas.code = '" area "'")))))
+          (set!  area-defined data-row))))
+area-defined))
+
+;get id of users table by user name 
+(define (get-user user)
+  (let* ((user-defined '()))
+    (sauthorize:db-do  (lambda (db)
+        (let* ((data-row (query fetch (sql db (conc "SELECT  id FROM  users where users.username = '" user "'")))))
+          (set!  user-defined data-row))))
+user-defined))
+
+;get permissions id by userid and area id 
+(define (get-perm userid areaid)
+  (let* ((user-defined '()))
+    (sauthorize:db-do  (lambda (db)
+          (let* ((data-row (query fetch (sql db (conc "SELECT  id FROM  permissions where user_id = " userid " and area_id = " areaid)))))
+         (set!  user-defined data-row))))
+
+user-defined))
+
+(define (get-restrictions base-path usr)
+(let* ((user-defined '()))
+    (sauthorize:db-do  (lambda (db)
+          (let* ((data-row (query fetch (sql db (conc "SELECT  restriction FROM areas, users, permissions where  areas.id = permissions.area_id and users.id =  permissions.user_id and  users.username = '" usr "' and areas.basepath = '" base-path "'")))))
+         ;(print data-row) 
+         (set!  user-defined data-row))))
+    ;   (print user-defined)
+  (if (null? user-defined)
+      ""
+      (car user-defined))))
+
+
+(define (get-obj-by-path path)
+   (let* ((obj '()))
+    (sauthorize:db-do  (lambda (db)
+        (let* ((data-row (query fetch (sql db (conc "SELECT  code,exe_name, id, basepath FROM  areas where areas.basepath = '" path "'")))))
+         (set!  obj data-row))))
+obj))
+
+(define (get-obj-by-code code )
+  (let* ((obj '()))
+    (sauthorize:db-do  (lambda (db)
+        ;(print (conc "SELECT  code, exe_name,  id, basepath, required_grps  FROM  areas where areas.code = '" code "'"))
+        (let* ((data-row (query fetch (sql db (conc "SELECT  code, exe_name,  id, basepath, required_grps  FROM  areas where areas.code = '" code "'")))))
+         ;(print data-row)
+         (set!  obj data-row)
+         ;(print obj) 
+        )))
+    (if (not (null? obj))
+          (begin
+          (let* ((req-grp (caddr (cddr obj))))
+            (sauthorize:do-as-calling-user
+             (lambda ()
+ (sauth-common:check-user-groups req-grp))))))
+obj))
+
+(define (sauth-common:check-user-groups req-grp)
+(let* ((current-groups  (get-groups) )
+        (req-grp-list (string-split req-grp ",")))
+        ;(print req-grp-list)
+        (for-each (lambda (grp)
+	  (let ((grp-info (group-information grp)))
+               ;(print grp-info " " grp)
+               (if (not (equal? grp-info #f))
+               (begin
+                 (if (not (member  (caddr grp-info) current-groups))
+                  (begin 
+                    (sauth:print-error (conc "Please wash " grp " group in your xterm!! " ))
+                     (exit 1)))))))
+	     req-grp-list)))
+
+(define (get-obj-by-code-no-grp-validation code )
+  (let* ((obj '()))
+    (sauthorize:db-do  (lambda (db)
+        (let* ((data-row (query fetch (sql db (conc "SELECT  code, exe_name,  id, basepath  FROM  areas where areas.code = '" code "'")))))
+         (set!  obj data-row))))
+;(print obj)
+obj))
+
+
+(define (sauth-common:src-size path)
+  (let ((output (with-input-from-pipe (conc "/usr/bin/du -s " path  "  | awk '{print $1}'")  
+                 (lambda()
+                  (read-line)))))
+      (string->number output)))  
+
+(define (sauth-common:space-left-at-dest path)
+   (let* ((output  (run/string (pipe (df ,path ) (tail -1))))
+         (size (caddr (cdr (string-split output " ")))))
+  (string->number size)))
+
+;; function to validate the users input for target path and resolve the path
+;; TODO: Check for restriction in subpath 
+(define (sauth-common:resolve-path  new current allowed-sheets)
+   (let* ((target-path (append  current (string-split new "/")))
+          (target-path-string (string-join target-path "/"))
+          (normal-path (normalize-pathname target-path-string))
+          (normal-list (string-split normal-path "/"))
+           (ret '()))
+   (if (string-contains   normal-path "..")
+    (begin
+      (print "ERROR: Path  " new " resolved outside target area ")
+      #f)
+    (if(equal? normal-path ".")
+      ret  
+    (if (not (member  (car normal-list) allowed-sheets))
+      (begin
+      (print "ERROR: Permision denied to  " new )
+       #f)
+    normal-list)))))
+
+(define (sauth-common:get-target-path base-path-list ext-path top-areas base-path)
+  (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas ))
+          (usr (current-user-name) ) )
+          (if (not (equal? resolved-path #f))
+           (if (null? resolved-path) 
+             #f
+           (let* ((sheet (car resolved-path))
+                   (restricted-areas (get-restrictions base-path usr))
+                   (restrictions (conc ".*" (string-join (string-split restricted-areas ",") ".*|.*") ".*"))
+           	   (target-path (if (null? (cdr resolved-path)) 
+                                     base-path 
+                                     (conc base-path "/" (string-join (cdr resolved-path) "/")))))
+                    
+	              
+                           (if (and (not (equal? restricted-areas "" ))
+                             (string-match (regexp  restrictions) target-path)) 
+                           (begin
+                              (sauth:print-error (conc "Access denied to " (string-join resolved-path "/")))
+                              ;(exit 1)   
+                            #f)
+                             target-path)
+                            
+))
+             #f)))
+
+(define (sauth-common:shell-ls-cmd base-path-list ext-path top-areas base-path tail-cmd-list)
+    (if (and (null? base-path-list) (equal? ext-path "") )
+      (print (string-intersperse top-areas " "))
+  (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas )))
+           ;(print resolved-path)
+           (if (not (equal? resolved-path #f))
+           (if (null? resolved-path) 
+             (print (string-intersperse top-areas " "))
+           (let* ((target-path (sauth-common:get-target-path  base-path-list  ext-path top-areas base-path)))
+                (print target-path)
+                (if (not (equal? target-path #f))
+                (begin 
+                (cond
+		  ((null? tail-cmd-list)
+		     (run (pipe
+      	      	      (ls "-lrt" ,target-path))))
+		  ((not (equal? (car tail-cmd-list) "|"))
+                         (print "ls cmd cannot accept " (string-join tail-cmd-list) " as an argument!!"))
+                  (else  
+                    (run (pipe
+      	      	      (ls "-lrt" ,target-path)
+                      (begin (system (string-join (cdr tail-cmd-list))))))))))))))))
+
+(define (sauth:print-error msg)
+  (with-output-to-port (current-error-port)
+	(lambda ()
+	       (print (conc "ERROR: " msg)))))
+

ADDED   sauth/sauthorize.scm
Index: sauth/sauthorize.scm
==================================================================
--- /dev/null
+++ sauth/sauthorize.scm
@@ -0,0 +1,651 @@
+
+;; Copyright 2006-2013, Matthew Welland.
+;; 
+;; This file is part of Megatest.
+;; 
+;;     Megatest is free software: you can redistribute it and/or modify
+;;     it under the terms of the GNU General Public License as published by
+;;     the Free Software Foundation, either version 3 of the License, or
+;;     (at your option) any later version.
+;; 
+;;     Megatest is distributed in the hope that it will be useful,
+;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;     GNU General Public License for more details.
+;; 
+;;     You should have received a copy of the GNU General Public License
+;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
+;;
+
+(use defstruct)
+(use scsh-process)
+
+(use srfi-18)
+(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))
+
+(include "megatest-version.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")
+
+;;
+;; GLOBALS
+;;
+(define *verbosity* 1)
+(define *logging* #f)
+(define *exe-name* (pathname-file (car (argv))))
+(define *sretrieve:current-tab-number* 0)
+(define *args-hash* (make-hash-table))
+(define sauthorize:help (conc "Usage: " *exe-name* " [action [params ...]]
+
+  list                   		 			: list areas $USER's can access
+  log                    		 			: get listing of recent activity.
+  sauth  list-area-user <area code> 			: list the users that can access the area.
+  sauth open <path> --group <grpname>                      : Open up an area. User needs to be the owner of the area to open it. 
+              --code <unique short identifier for an area> 
+              --retrieve|--publish [--additional-grps <comma separated unix grps requierd to get to the path>]
+  sauth update <area code>  --retrieve|--publish             : update the binaries with the lates changes
+  sauth grant <username> --area <area identifier>          : Grant permission to read or write to a area that is alrady opend up.    
+             --expiration yyyy/mm/dd --retrieve|--publish 
+             [--restrict <comma separated directory names> ]  
+  sauth read-shell <area identifier>                       :  Open sretrieve shell for reading.  
+  sauth write-shell <area identifier>                      :  Open spublish shell for writing.
+   
+Part of the Megatest tool suite.
+Learn more at http://www.kiatoa.com/fossils/megatest
+
+Version: " megatest-fossil-hash)) ;; "
+
+;;======================================================================
+;; RECORDS
+;;======================================================================
+
+;;======================================================================
+;; DB
+;;======================================================================
+
+;; replace (strftime('%s','now')), with datetime('now'))
+(define (sauthorize:initialize-db db)
+  (for-each
+   (lambda (qry)
+     (exec (sql db qry)))
+   (list 
+    "CREATE TABLE IF NOT EXISTS actions
+         (id           INTEGER PRIMARY KEY,
+          cmd       TEXT NOT NULL,
+          user_id      INTEGER NOT NULL,
+          datetime     TIMESTAMP DEFAULT (datetime('now','localtime')),
+          area_id      INTEGER NOT NULL,
+          comment      TEXT DEFAULT '' NOT NULL,
+          action_type  TEXT NOT NULL);"
+        "CREATE TABLE IF NOT EXISTS users
+         (id           INTEGER PRIMARY KEY,
+          username     TEXT NOT NULL,
+          is_admin     TEXT NOT NULL,
+          datetime     TIMESTAMP DEFAULT (datetime('now','localtime'))
+          );" 
+          "CREATE TABLE IF NOT EXISTS areas
+         (id           INTEGER PRIMARY KEY,
+          basepath     TEXT NOT NULL,
+          code         TEXT NOT NULL,
+          exe_name     TEXT NOT NULL,
+          required_grps TEXT DEFAULT '' NOT NULL,
+          datetime     TIMESTAMP DEFAULT (datetime('now','localtime'))
+          );" 
+         "CREATE TABLE IF NOT EXISTS permissions
+         (id              INTEGER PRIMARY KEY,
+          access_type     TEXT NOT NULL,
+          user_id         INTEGER NOT NULL,
+          datetime        TIMESTAMP DEFAULT (datetime('now','localtime')),
+          area_id         INTEGER NOT NULL,
+          restriction     TEXT DEFAULT '' NOT NULL,
+          expiration       TIMESTAMP DEFAULT NULL);"
+    )))
+
+
+
+
+(define (get-access-type args)
+   (let loop ((hed (car args))
+		 (tal (cdr args)))
+                   (cond
+                   ((equal? hed "--retrieve")
+                      "retrieve") 
+                   ((equal? hed "--publish")
+                      "publish") 
+                   ((equal? hed "--area-admin")
+                      "area-admin")
+                   ((equal? hed "--writer-admin")
+                      "writer-admin")
+                   ((equal? hed "--read-admin")
+                      "read-admin")
+
+                   ((null? tal)
+                      #f) 
+                   (else 
+		  	(loop (car tal)(cdr tal))))))
+
+
+
+;; check if user can gran access to an area
+(define (can-grant-perm username access-type area)
+   (let* ((isadmin (is-admin username))
+          (is-area-admin (is-user "area-admin" username area ))
+          (is-read-admin (is-user "read-admin" username area) )
+          (is-writer-admin (is-user "writer-admin" username area) ) )
+   (cond
+   ((equal? isadmin  #t)
+     #t)
+   ((equal? is-area-admin #t ) 
+     #t)
+   ((and (equal? is-writer-admin #t ) (equal? access-type "retrieve"))
+     #t)
+   ((and (equal? is-read-admin #t ) (equal? access-type "retrieve"))
+     #t)
+
+   (else  
+    #f))))
+
+(define (sauthorize:list-areausers  area )
+  (sauthorize:db-do  (lambda (db)
+				     (print "Users having access to " area ":")
+				     (query (for-each-row
+					     (lambda (row)
+                                               (let* ((exp-date (cadr row)))
+                                                (if  (is-access-valid  exp-date)   
+					        (apply print (intersperse row " | "))))))
+					    (sql db (conc "SELECT users.username, permissions.expiration, permissions.access_type  FROM users, areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and areas.code = '" area "'"))))))
+
+
+
+
+; check if executable exists
+(define (exe-exist exe access-type)
+    (let* ((filepath (conc *exe-path* "/" access-type "/" exe)))
+    ; (print filepath)
+     (if (file-exists? filepath)
+       #t
+       #f)))
+
+(define (copy-exe access-type exe-name group)
+  (run-cmd "/bin/chmod" (list "g+w" (conc *exe-path* "/" access-type)))
+  (let* ((spath (conc *exe-src*  "/s" access-type))
+         (dpath (conc *exe-path* "/" access-type "/" exe-name)))
+         (sauthorize:do-as-calling-user
+        (lambda ()
+            (run-cmd "/bin/cp" (list spath dpath )) 
+            (if (equal? access-type "publish")
+              (run-cmd "/bin/chmod" (list "u+s,o+rx" dpath))
+              (begin
+               (if (equal? group "none")
+                 (run-cmd "/bin/chmod" (list "u+s,o+rx" dpath))
+                 (begin   
+                     (run-cmd "/bin/chgrp" (list group dpath))
+                       (run-cmd "/bin/chmod" (list "g+s,o+rx" dpath))))))))
+	(run-cmd "chmod" (list "g-w" (conc *exe-path* "/" access-type)))))
+
+(define (get-exe-name path group)
+   (let ((name ""))
+   (sauthorize:do-as-calling-user
+        (lambda ()
+        (if (equal? (current-effective-user-id) (file-owner path)) 
+          (set! name (conc (current-user-name) "_" group))
+          (begin
+            (print "You cannot open areas that you dont own!!")  
+             (exit 1)))))
+name))
+
+(define (sauthorize:valid-unix-user username)
+    (let* ((ret-val #f))
+    (let-values (((inp oup pid)
+              (process "/usr/bin/id" (list username))))
+        (let loop ((inl (read-line inp)))
+          (if (string? inl) 
+          (if (string-contains inl  "No such user") 
+            (set! ret-val #f)
+             (set! ret-val #t)))   
+          (if (eof-object? inl)
+              (begin
+                   (close-input-port inp)
+                  (close-output-port oup))
+            (loop (read-line inp)))))
+            ret-val))
+
+
+;check if a paths/codes are vaid and if area is alrady open  
+(define (open-area group path code access-type other-grps)
+   (let* ((exe-name (get-exe-name path group))
+           (path-obj (get-obj-by-path path))
+           (code-obj (get-obj-by-code-no-grp-validation code)))
+           ;(print path-obj)   
+          (cond
+            ((not (null? path-obj))
+                (if (equal? code (car path-obj))
+                  (begin
+                     (if (equal? exe-name (cadr path-obj))
+                        (begin
+                            (if (not (exe-exist exe-name  access-type))
+                                 (copy-exe access-type exe-name group)
+                                 (begin 
+                                  (print "Area already open!!")
+                                  (exit 1))))   
+			(begin
+                           (if (not (exe-exist exe-name  access-type))
+                                 (copy-exe access-type exe-name group))
+                           ;; update exe-name  in db 
+                      (sauthorize:db-do   (lambda (db)
+                         (sauthorize:db-qry db (conc "update areas set exe_name = '" exe-name "' where id = " (caddr path-obj)))))
+                        )))
+                   (begin
+                       (print "Path " path " is registered with --code " (car path-obj) ". To open this area please execute following cmd: \n  sauthorize open " path " --group " group " --code " (car path-obj) " --" access-type )
+                       (exit 1))))
+                      
+            ((not (null? code-obj))
+                   (print "Code " code " is used for diffrent path. Please try diffrent value of --code" ) 
+                   (exit 1))
+            (else
+               ; (print (exe-exist exe-name  access-type))
+                (if (not (exe-exist exe-name  access-type))
+                        (copy-exe access-type exe-name group))
+                (sauthorize:db-do   (lambda (db)
+               (print conc "insert into areas (code, basepath, exe_name, required_grps) values ('" code "', '" path "', '" exe-name "', '" other-grps "') ") 
+             (sauthorize:db-qry db (conc "insert into areas (code, basepath, exe_name, required_grps) values ('" code "', '" path "', '" exe-name "', '" other-grps "') "))))))))
+
+(define (user-has-open-perm user path access)
+  (let* ((has-access #f)
+         (eid (current-user-id)))
+    (cond
+     ((is-admin  user)
+       (set! has-access #t ))
+     ((and (is-read-admin  user) (equal? access "retrieve"))
+       (set! has-access #t ))
+     (else
+        (print "User " user " does not have permission to open areas")))
+        has-access))
+
+
+;;check if user has group access
+(define (is-group-washed req_grpid current-grp-list)
+  (let loop ((hed (car current-grp-list))
+		 (tal (cdr current-grp-list)))
+                   (cond
+                   ((equal? hed req_grpid)
+                    #t)    
+                   ((null? tal)
+                      #f)
+                   (else 
+		  	(loop (car tal)(cdr tal))))))
+
+;create executables with appropriate suids
+(define (sauthorize:open user path group code access-type other-groups)
+   (let* ((gpid (group-information group))
+         (req_grpid (if (equal? group "none")
+                      group 
+                      (if (equal? gpid #f)
+                           #f      
+                     (caddr gpid))))
+         (current-grp-list (get-groups))
+         (valid-grp (if (equal? group "none")
+                     group
+                    (is-group-washed req_grpid current-grp-list))))
+   (if (and (not (equal? group "none")) (equal? valid-grp #f ))
+       (begin
+       (print "Group " group " is not washed in the current xterm!!") 
+       (exit 1)))) 
+   (if (not (file-write-access? path))
+     (begin
+       (print "You can open areas owned by yourself. You do not have permissions to open path." path)
+        (exit 1)))
+   (if (user-has-open-perm user path access-type)
+      (begin 
+       ;(print "here")   
+       (open-area group path code access-type other-groups)
+       (sauthorize:grant user user code "2017/12/25"  "read-admin" "") 
+       (sauthorize:db-do   (lambda (db)
+             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize open " path " --code " code " --group " group " --" access-type "'," (car (get-user user)) "," (car (get-area code)) ", 'open' )"))))
+         (print "Area has " path "  been opened for " access-type ))))
+
+(define (sauthorize:update username exe area access-type)
+  (let* ((parts (string-split exe "_"))
+         (owner (car parts))
+         (group (cadr parts))
+         (gpid (group-information group))
+         (req_grpid (if (equal? group "none")
+                      group 
+                      (if (equal? gpid #f)
+                           #f      
+                     (caddr gpid))))
+ 
+         (current-grp-list (get-groups))
+         (valid-grp (if (equal? group "none")
+                     group
+                    (is-group-washed req_grpid current-grp-list))))
+         (if (not (equal? username owner))
+            (begin
+              (print "You cannot update " area ". Only " owner " can update this area!!") 
+               (exit 1)))
+          (copy-exe access-type exe group)
+           (print "recording action..")    
+          (sauthorize:db-do   (lambda (db)
+             
+             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize update " area " --" access-type "'," (car (get-user username)) "," (car (get-area area)) ", 'update' )"))))
+         (print "Area has " area "  been update!!" )))
+
+(define (sauthorize:grant auser guser area exp-date access-type restrict)
+    ; check if user exist in db
+    (let* ((area-obj (get-area area))
+           (auser-obj (get-user auser)) 
+           (user-obj (get-user guser)))
+          
+        (if (null? user-obj)
+           (begin
+            ;; is guser a valid unix user
+            (if (not (sauthorize:valid-unix-user guser))
+               (begin  
+                (print "User " guser " is Invalid unix user!!")
+                 (exit 1)))
+            (sauthorize:db-do   (lambda (db)
+             (sauthorize:db-qry db (conc "insert into users (username, is_admin) values ('" guser "', 'no') "))))
+             (set! user-obj (get-user guser))))
+        (let* ((perm-obj (get-perm (car user-obj) (car area-obj))))
+          (if(null? perm-obj)
+          (begin   
+            ;; insert permissions
+            (sauthorize:db-do   (lambda (db)
+            (sauthorize:db-qry db (conc "insert into permissions (access_type, user_id, area_id, restriction, expiration ) values ('" access-type "', " (car user-obj) ", " (car area-obj) ", '" restrict "', '" exp-date "')")))))
+          (begin 
+             ;update permissions
+             (sauthorize:db-do   (lambda (db)
+             (sauthorize:db-qry db (conc "update permissions set access_type = '" access-type "' , restriction = '" restrict "', expiration =  '" exp-date "' where user_id = " (car user-obj) " and area_id = " (car area-obj)))))))
+             (sauthorize:db-do   (lambda (db)
+             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize grant " guser " --area " area " --expiration " exp-date " --" access-type " --restrict " restrict "'," (car auser-obj) "," (car area-obj) ", 'grant' )"))))  
+             (print "Permission has been sucessfully granted to user " guser))))
+
+(define (sauthorize:process-action  username action . args)
+   (case (string->symbol action)
+   ((grant)
+      (if (< (length args) 6)
+         (begin 
+	     (print  "ERROR: Missing arguments; " (string-intersperse args ", "))
+	     (exit 1)))
+       (let* ((remargs     (args:get-args args '("--area" "--expiration" "--restrict") '() args:arg-hash 0))
+              (guser     (car args))
+	      (restrict         (or (args:get-arg "--restrict") ""))
+              (area         (or (args:get-arg "--area") ""))  
+              (exp-date        (or (args:get-arg "--expiration") ""))
+              (access-type (get-access-type remargs)))
+	; (print  "version " guser " restrict " restrict )
+        ; (print "area " area " exp-date " exp-date " access-type " access-type)
+        (cond
+           ((equal? guser "")
+              (print "Username not found!! Try \"sauthorize help\" for useage ")
+               (exit 1))   
+           ((equal? area "")
+              (print "Area not found!! Try \"sauthorize help\" for useage ")
+              (exit 1)) 
+           ((equal? access-type #f)
+              (print "Access type not found!! Try \"sauthorize help\" for useage ")
+               (exit 1)) 
+           ((equal? exp-date "")
+              (print "Date of expiration not found!! Try \"sauthorize help\" for useage ")
+              (exit 1)))
+           (if (not (area-exists area))
+              (begin
+              (print "Area does not exisit!!")
+              (exit 1)))   
+           (if (can-grant-perm username access-type area)
+	   (begin
+             (print "calling sauthorize:grant ") 
+              (sauthorize:grant username guser area exp-date access-type restrict))   
+           (begin
+              (print "User " username " does not have permission to grant permissions to area " area "!!")
+              (exit 1)))))
+       ((list-area-user)
+          (if (not (equal? (length args) 1))
+              (begin
+              (print "Missing argument area code to list-area-user ") 
+              (exit 1)))
+           (let* ((area (car args)))
+           (if (not (area-exists area))
+              (begin
+              (print "Area does not exisit!!")
+              (exit 1))) 
+                                
+                (sauthorize:list-areausers  area )
+              ))
+      ((read-shell)
+          (if (not (equal? (length args) 1))
+              (begin
+              (print "Missing argument area code to read-shell ") 
+              (exit 1)))
+           (let* ((area (car args))
+                  (code-obj (get-obj-by-code area)))
+           (if (or (null? code-obj)
+                   (not (exe-exist (cadr code-obj)  "retrieve")))
+              (begin
+              (print "Area " area " is not open for reading!!")
+              (exit 1))) 
+              (sauthorize:do-as-calling-user
+             (lambda ()
+                (run-cmd (conc *exe-path* "/retrieve/" (cadr code-obj) ) (list "shell" area ))))))
+      ((write-shell)
+          (if (not (equal? (length args) 1))
+              (begin
+              (print "Missing argument area code to read-shell ") 
+              (exit 1)))
+           (let* ((area (car args))
+                  (code-obj (get-obj-by-code area)))
+           (if (or (null? code-obj)
+                   (not (exe-exist (cadr code-obj)  "publish")))
+              (begin
+              (print "Area " area " is not open for Writing!!")
+              (exit 1))) 
+              (sauthorize:do-as-calling-user
+             (lambda ()
+                (run-cmd (conc *exe-path* "/publish/" (cadr code-obj) ) (list "shell" area))))))
+      ((publish)
+          (if (< (length args) 2)
+              (begin
+              (print "Missing argument to publish. \n publish <action> <area> [opts] ") 
+              (exit 1)))
+            
+           (let* ((action (car args))
+                  (area (cadr args))
+                  (cmd-args (cddr args)) 
+                  (code-obj (get-obj-by-code area)))
+           ;(print "area " area)
+           ;(print "code: " code-obj)  
+           ;(print (exe-exist (cadr code-obj)  "publish")) 
+           (if (or (null? code-obj)
+                   (not (exe-exist (cadr code-obj)  "publish")))
+              (begin
+              (print "Area " area " is not open for writing!!")
+              (exit 1)))
+              ;(print "hear") 
+              (sauthorize:do-as-calling-user
+             (lambda ()
+               ; (print  *exe-path* "/publish/" (cadr code-obj) action area cmd-args  )
+                (run-cmd (conc *exe-path* "/publish/" (cadr code-obj) ) (append (list action area ) cmd-args))))))
+      
+     ((retrieve)
+          (if (< (length args) 2)
+              (begin
+              (print "Missing argument to publish. \n publish <action> <area> [opts] ") 
+              (exit 1)))
+           (let* ((action (car args))
+                  (area (cadr args))
+                  (cmd-args (cddr args)) 
+                  (code-obj (get-obj-by-code area)))
+           (if (or (null? code-obj)
+                   (not (exe-exist (cadr code-obj)  "retrieve")))
+              (begin
+              (print "Area " area " is not open for reading!!")
+              (exit 1))) 
+               ;(print (conc *exe-path* "/retrieve/" (cadr code-obj) " " action " " area " " (string-join cmd-args)))
+              (sauthorize:do-as-calling-user
+             (lambda ()
+                (run-cmd (conc *exe-path* "/retrieve/" (cadr code-obj) ) (append (list action area ) cmd-args))))))
+
+ 
+ 
+      ((open)
+         (if (< (length args) 6)
+              (begin
+              (print "sauthorize open cmd takes 6 arguments!! \n Useage: sauthorize open <path> --group <grpname> --code <unique short identifier for an area> --retrieve|--publish") 
+              (exit 1)))
+         (let* ((remargs     (args:get-args args '("--group" "--code" "--additional-grps") '() args:arg-hash 0))
+              (path     (car args))
+	      (group         (or (args:get-arg "--group") ""))
+              (area         (or (args:get-arg "--code") ""))
+              (other-grps          (or (args:get-arg "--additional-grps") ""))     
+              (access-type (get-access-type remargs)))
+                
+              (cond
+                ((equal? path "")
+                  (print "path not found!! Try \"sauthorize help\" for useage ")
+                  (exit 1))   
+                ((equal? area "")
+                  (print "--code not found!! Try \"sauthorize help\" for useage ")
+                  (exit 1)) 
+                ((equal? access-type #f)
+                  (print "Access type not found!! Try \"sauthorize help\" for useage ")
+                  (exit 1)) 
+                ((and (not (equal? access-type "publish")) 
+                  (not (equal? access-type "retrieve")))
+                  (print "Access type can be eiter --retrieve or --publish !! Try \"sauthorize help\" for useage ")
+                  (exit 1)))
+                ; (print other-grps) 
+                (sauthorize:open username path group area access-type other-grps)))
+         ((update)
+            (if (< (length args) 2)
+              (begin
+              (print "sauthorize update cmd takes 2 arguments!! \n Useage: sauthorize update <area-code> --retrieve|--publish") 
+              (exit 1)))
+              (let* ((area (car args))
+                     (code-obj (get-obj-by-code area))
+                    (access-type (get-access-type (cdr args))))
+               (if  (and (not (equal? access-type "publish")) (not (equal? access-type "retrieve")))
+                  (begin 
+                  (print "Access type can be --retrieve|--publish ")
+                  (exit 1)))
+              (if (or (null? code-obj)
+                   (not (exe-exist (cadr code-obj)  access-type)))
+              (begin
+              (print "Area " area " is not open for reading!!")
+              (exit 1))) 
+              (sauthorize:update username (cadr code-obj) area access-type ))) 
+         ((area-admin)
+           (let* ((usr (car args))
+                  (usr-obj (get-user usr))
+                  (user-id (car (get-user username))))
+           
+                (if (is-admin  username)
+                (begin
+                  ; (print usr-obj) 
+                  (if (null? usr-obj)
+                    (begin
+                        (sauthorize:db-do   (lambda (db)
+              ;(print (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'read-admin' )"))
+             (sauthorize:db-qry db (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'read-admin' )")))))
+               (begin
+                ; (print (conc "update users set is_admin = 'no' where id = " (car usr-obj) ))
+                 (sauthorize:db-do   (lambda (db)
+                (sauthorize:db-qry db (conc "update users set is_admin = 'read-admin' where id = " (car usr-obj)))))))
+                (print "User " usr " is updated with area-admin access!"))
+                (print "Admin only function"))
+                (sauthorize:db-do   (lambda (db)
+             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('area-admin " usr " ', " user-id ",0, 'area-admin ')" )))))) 
+          ((mk-admin)
+           (let* ((usr (car args))
+                  (usr-obj (get-user usr))
+                  (user-id (car (get-user username))))
+                (if (not (sauthorize:valid-unix-user usr))
+               (begin  
+                (print "User " usr " is Invalid unix user!!")
+                 (exit 1)))
+
+                (if (member  username  *super-users*)
+                (begin
+                  (if (null? usr-obj)
+                    (begin
+                        (sauthorize:db-do   (lambda (db)
+                           (sauthorize:db-qry db (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'yes' )")))))
+               (begin
+                 (sauthorize:db-do   (lambda (db)
+                (sauthorize:db-qry db (conc "update users set is_admin = 'yes' where id = " (car usr-obj)))))))
+                (print "User " usr " is updated with admin access!"))
+                (print "Super-Admin only function"))
+                (sauthorize:db-do   (lambda (db)
+             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('mk-admin " usr " ', " user-id ",0, 'mk-admin ')" )))))) 
+
+         ((register-log)
+            (if (< (length args) 4)
+                (print "Invalid arguments"))
+             ;(print args)
+             (let* ((cmd-line (car args))
+                     (user-id (cadr args))
+                     (area-id (caddr args))
+                     (user-obj (get-user username))
+                      (cmd (cadddr args)))
+                
+               (if (and (not (null? user-obj)) (equal? user-id (number->string(car user-obj))))
+                (begin 
+                (sauthorize:db-do   (lambda (db)
+             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('" cmd-line"', " user-id "," area-id ", '" cmd "')" )))))
+                (print "You ar not authorised to run this cmd")
+
+)))     
+
+       
+      (else (print 0 "Unrecognised command " action))))
+  
+(define (main)
+  (let* ((args      (argv))
+	 (prog      (car args))
+	 (rema      (cdr args))
+         (username     (current-user-name)))
+    ;; preserve the exe data in the config file
+    (cond
+     ;; one-word commands
+     ((eq? (length rema) 1)
+      (case (string->symbol (car rema))
+	((help -h -help --h --help)
+	 (print sauthorize:help))
+	((list)
+            
+          (sauthorize:db-do  (lambda (db)
+				     (print "My Area accesses: ")
+				     (query (for-each-row
+					     (lambda (row)
+                                               (let* ((exp-date (car row)))
+                                                (if  (is-access-valid  exp-date)     
+					           (apply print (intersperse (cdr row) " | "))))))
+					    (sql db (conc "SELECT permissions.expiration, areas.basepath, areas.code, permissions.access_type  FROM users, areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and users.username = '" username "'"))))))
+         
+	((log)
+	 (sauthorize:db-do  (lambda (db)
+				     (print "Logs : ")
+				     (query (for-each-row
+					     (lambda (row)
+                                                   
+					       (apply print (intersperse row " | "))))
+					    (sql db "SELECT actions.cmd, users.username, actions.action_type, actions.datetime, areas.code  FROM actions, users, areas where actions.user_id = users.id and actions.area_id = areas.id ")))))
+	(else
+	 (print "ERROR: Unrecognised command. Try \"sauthorize help\""))))
+     ;; multi-word commands
+     ((null? rema)(print sauthorize:help))
+     ((>= (length rema) 2)
+      (apply sauthorize:process-action username (car rema)(cdr rema)))
+     (else (debug:print 0 "ERROR: Unrecognised command. Try \"sauthorize help\"")))))
+
+(main)
+
+
+      

ADDED   sauth/sretrieve.scm
Index: sauth/sretrieve.scm
==================================================================
--- /dev/null
+++ sauth/sretrieve.scm
@@ -0,0 +1,1112 @@
+
+;; Copyright 2006-2013, Matthew Welland.
+;; 
+;; This file is part of Megatest.
+;; 
+;;     Megatest is free software: you can redistribute it and/or modify
+;;     it under the terms of the GNU General Public License as published by
+;;     the Free Software Foundation, either version 3 of the License, or
+;;     (at your option) any later version.
+;; 
+;;     Megatest is distributed in the hope that it will be useful,
+;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;     GNU General Public License for more details.
+;; 
+;;     You should have received a copy of the GNU General Public License
+;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
+;;
+
+(use defstruct)
+(use scsh-process)
+(use srfi-18)
+(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))
+
+(include "megatest-version.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")
+
+(define (toplevel-command . args) #f)
+(use readline)
+
+
+
+
+;;
+;; GLOBALS
+;;
+(define *verbosity* 1)
+(define *logging* #f)
+(define *exe-name* (pathname-file (car (argv))))
+(define *sretrieve:current-tab-number* 0)
+(define *args-hash* (make-hash-table))
+(define sretrieve:help (conc "Usage: " *exe-name* " [action [params ...]]
+
+  ls   <area>                        : list contents of target area
+  get  <area>  <reletive path>       : retrieve path to the data within <area>
+     -m \"message\"       : why retrieved?
+  shell  <area>                   : start a shell-like interface
+
+Part of the Megatest tool suite.
+Learn more at http://www.kiatoa.com/fossils/megatest
+
+Version: " megatest-fossil-hash)) ;; "
+
+;;======================================================================
+;; RECORDS
+;;======================================================================
+
+;;======================================================================
+;; DB
+;;======================================================================
+
+;; replace (strftime('%s','now')), with datetime('now'))
+;(define (sretrieve:initialize-db db)
+;  (for-each
+;   (lambda (qry)
+;     (exec (sql db qry)))
+;   (list 
+;    "CREATE TABLE IF NOT EXISTS actions
+;         (id           INTEGER PRIMARY KEY,
+;          action       TEXT NOT NULL,
+;          retriever    TEXT NOT NULL,
+;          datetime     TIMESTAMP DEFAULT (datetime('now','localtime')),
+;          srcpath      TEXT NOT NULL,
+;          comment      TEXT DEFAULT '' NOT NULL,
+;          state        TEXT DEFAULT 'new');"
+;    "CREATE TABLE IF NOT EXISTS bundles
+;         (id           INTEGER PRIMARY KEY,
+;          bundle       TEXT NOT NULL,
+;          release      TEXT NOT NULL,
+;          status       TEXT NOT NULL,
+;          event_date   TEXT NOT NULL);"
+;    )))
+;
+;(define (sretrieve:register-action db action submitter source-path comment)
+; ; (print "(sretrieve:register-action db " db " action " action " submitter " submitter " source-path " source-path " comment " comment)
+;  (exec (sql db "INSERT INTO actions (action,retriever,srcpath,comment)
+;                 VALUES(?,?,?,?)")
+;	action
+;	submitter
+;	source-path
+;	(or comment "")))
+
+;; (call-with-database
+;;  (lambda (db)
+;;   (set-busy-handler! db (busy-timeout 10000)) ; 10 second timeout
+;;   ...))
+
+;; Create the sqlite db
+;(define (sretrieve:db-do configdat proc) 
+;  (let ((path (configf:lookup configdat "database" "location")))
+;    (if (not path)
+;	(begin
+;	  (debug:print 0 "[database]\nlocation /some/path\n\n Is missing from the config file!")
+;	  (exit 1)))
+;    (if (and path
+;	     (directory? path)
+;	     (file-read-access? path))
+;	(let* ((dbpath    (conc path "/" *exe-name* ".db"))
+;	       (writeable (file-write-access? dbpath))
+;	       (dbexists  (file-exists? dbpath)))
+;	  (handle-exceptions
+;	   exn
+;	   (begin
+;	     (debug:print 2 "ERROR: problem accessing db " dbpath
+;			  ((condition-property-accessor 'exn 'message) exn))
+;	     (exit 1))
+;            ;;(debug:print 0 "calling proc " proc "db path " dbpath )
+;	   (call-with-database
+;            dbpath
+;	    (lambda (db)
+;	       ;;(debug:print 0 "calling proc " proc " on db " db)
+;	      (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout
+;	      (if (not dbexists)(sretrieve:initialize-db db))
+;	      (proc db)))))
+;	(debug:print 0 "ERROR: invalid path for storing database: " path))))
+
+;; copy in directory to dest, validation is done BEFORE calling this
+;;
+;(define (sretrieve:get configdat retriever version comment)
+;  (let* ((base-dir  (configf:lookup configdat "settings" "base-dir"))
+;	 (datadir   (conc base-dir "/" version)))
+;    (if (or (not base-dir)
+;	    (not (file-exists? base-dir)))
+;	(begin
+;	  (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found")
+;	  (exit 1)))
+;    (print datadir)
+;    (if (not (file-exists? datadir))
+;	(begin
+;	  (debug:print 0 "ERROR: Bad version (" version "), no data found at " datadir "." )
+;	  (exit 1)))
+;    
+;    (sretrieve:db-do
+;     configdat
+;     (lambda (db)
+;       (sretrieve:register-action db "get" retriever datadir comment)))
+;      (sretrieve:do-as-calling-user
+;       (lambda ()
+;         (if (directory? datadir)
+;	   (begin
+;  	    (change-directory datadir)
+;	    (let ((files (filter (lambda (x)
+;				(not (member x '("." ".."))))
+;			      (glob "*" ".*"))))
+;	     (print "files: " files)
+;	     (process-execute "/bin/tar" (append (append (list  "chfv" "-") files) (list "--ignore-failed-read")))))
+;             (begin
+;               (let* ((parent-dir (pathname-directory datadir) )
+;                      (filename  (conc(pathname-file datadir) "." (pathname-extension datadir))))
+;                  (change-directory parent-dir)  
+;                  (process-execute "/bin/tar" (list "chfv" "-" filename))
+;             )))
+;))))
+;
+;
+;;; copy in file to dest, validation is done BEFORE calling this
+;;;
+;(define (sretrieve:cp configdat retriever file comment)
+;  (let* ((base-dir  (configf:lookup configdat "settings" "base-dir"))
+;         (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths"))    
+;	 (datadir   (conc base-dir "/" file))
+;         (filename  (conc(pathname-file datadir) "." (pathname-extension datadir))))
+;    (if (or (not base-dir)
+;	    (not (file-exists? base-dir)))
+;	(begin
+;	  (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found")
+;	  (exit 1)))
+;    (print datadir)
+;    (if (not (file-exists? datadir))
+;	(begin
+;	  (debug:print 0 "ERROR: File  (" file "), not found at " base-dir "." )
+;	  (exit 1)))
+;    (if (directory? datadir)
+;	(begin
+;	  (debug:print 0 "ERROR: (" file ") is a dirctory!! cp cmd works only on files ." )
+;	  (exit 1)))
+;    (if(not (string-match (regexp  allowed-sub-paths) file))
+;        (begin
+;	  (debug:print 0 "ERROR: Access denied to file (" file ")!! " )
+;	  (exit 1)))
+;     
+;     (sretrieve:db-do
+;     configdat
+;     (lambda (db)
+;       (sretrieve:register-action db "cp" retriever datadir comment)))
+;      (sretrieve:do-as-calling-user
+;      ;;  (debug:print 0 "ph:  "(pathname-directory datadir)  "!! " )
+;       (change-directory (pathname-directory datadir))  
+;       ;;(debug:print 0 "ph: /bin/tar" (list "chfv" "-" filename) )
+;      (process-execute "/bin/tar" (list "chfv" "-" filename)))
+;      ))
+;
+;;; ls in file to dest, validation is done BEFORE calling this
+;;;
+;(define (sretrieve:ls configdat retriever file comment)
+;  (let* ((base-dir  (configf:lookup configdat "settings" "base-dir"))
+;         (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths"))    
+;	 (datadir   (conc base-dir "/" file))
+;         (filename  (conc(pathname-file datadir) "." (pathname-extension datadir))))
+;    (if (or (not base-dir)
+;	    (not (file-exists? base-dir)))
+;	(begin
+;	  (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found")
+;	  (exit 1)))
+;    (print datadir)
+;    (if (not (file-exists? datadir))
+;	(begin
+;	  (debug:print 0 "ERROR: File  (" file "), not found at " base-dir "." )
+;	  (exit 1)))
+;      (if(not (string-match (regexp  allowed-sub-paths) file))
+;        (begin
+;	  (debug:print 0 "ERROR: Access denied to file (" file ")!! " )
+;	  (exit 1)))
+;   
+;        (sretrieve:do-as-calling-user
+;        (lambda ()
+;	  (process-execute "/bin/ls" (list "-ls"  "-lrt" datadir ))
+; ))))
+
+
+
+(define (sretrieve:validate target-dir targ-mk)
+  (let* ((normal-path (normalize-pathname targ-mk))
+        (targ-path (conc target-dir "/" normal-path)))
+    (if (string-contains   normal-path "..")
+    (begin
+      (debug:print 0 "ERROR: Path  " targ-mk " resolved outside target area "  target-dir )
+      (exit 1)))
+
+    (if (not (string-contains targ-path target-dir))
+    (begin
+      (debug:print 0 "ERROR: You cannot update data outside " target-dir ".")
+      (exit 1)))
+    (debug:print 0 "Path " targ-mk " is valid.")   
+ ))
+
+
+;(define (sretrieve:backup-move path)
+;  (let* ((trashdir  (conc (pathname-directory path) "/.trash"))
+;	 (trashfile (conc trashdir "/" (current-seconds) "-" (pathname-file path))))
+;    (create-directory trashdir #t)
+;    (if (directory? path)
+;	(system (conc "mv " path " " trashfile))
+;	(file-move path trash-file))))
+;
+;
+;(define (sretrieve:lst->path pathlst)
+;  (conc "/" (string-intersperse (map conc pathlst) "/")))
+;
+;(define (sretrieve:path->lst path)
+;  (string-split path "/"))
+;
+;(define (sretrieve:pathdat-apply-heuristics configdat path)
+;  (cond
+;   ((file-exists? path) "found")
+;   (else (conc path " not installed"))))
+
+;;======================================================================
+;; MISC
+;;======================================================================
+
+(define (sretrieve:do-as-calling-user proc)
+  (let ((eid (current-effective-user-id))
+        (cid (current-user-id)))
+    (if (not (eq? eid cid)) ;; running suid
+            (set! (current-effective-user-id) cid))
+    ;; (debug:print 0 "running as " (current-effective-user-id))
+    (proc)
+    (if (not (eq? eid cid))
+        (set! (current-effective-user-id) eid))))
+
+(define (sretrieve:find name paths)
+  (if (null? paths)
+      #f
+      (let loop ((hed (car paths))
+		 (tal (cdr paths)))
+	(if (file-exists? (conc hed "/" name))
+	    hed
+	    (if (null? tal)
+		#f
+		(loop (car tal)(cdr tal)))))))
+
+(define (sretrieve:stderr-print . args)
+  (with-output-to-port (current-error-port)
+    (lambda ()
+      (apply print args))))
+
+;;======================================================================
+;; SHELL
+;;======================================================================
+
+;; Create the sqlite db for shell
+;(define (sretrieve:shell-db-do path proc) 
+;    (if (not path)
+;	(begin
+;	  (debug:print 0 "[database]\nlocation /some/path\n\n Is missing from the config file!")
+;	  (exit 1)))
+;    (if (and path
+;	     (directory? path)
+;	     (file-read-access? path))
+;	(let* ((dbpath    (conc path "/" *exe-name* ".db"))
+;	       (writeable (file-write-access? dbpath))
+;	       (dbexists  (file-exists? dbpath)))
+;	  (handle-exceptions
+;	   exn
+;	   (begin
+;	     (debug:print 2 "ERROR: problem accessing db " dbpath
+;			  ((condition-property-accessor 'exn 'message) exn))
+;	     (exit 1))
+;            ;;(debug:print 0 "calling proc " proc "db path " dbpath )
+;	   (call-with-database
+;            dbpath
+;	    (lambda (db)
+;	       ;;(debug:print 0 "calling proc " proc " on db " db)
+;	      (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout
+;	      (if (not dbexists)(sretrieve:initialize-db db))
+;	      (proc db)))))
+;	(debug:print 0 "ERROR: invalid path for storing database: " path)))
+
+
+
+;; function to find sheets to which use has access 
+(define (sretrieve:has-permission  area)
+  (let ((username     (current-user-name)))
+  (cond
+   ((is-admin username)
+     #t)
+   ((is-user "retrieve" username area) 
+     #t)
+    ((is-user "publish" username area) 
+     #t)
+   ((is-user "writer-admin" username area) 
+     #t)
+   ((is-user "read-admin" username area) 
+     #t)
+   ((is-user "area-admin" username area) 
+     #t)
+   (else  
+    #f))))
+ 
+
+(define (sretrieve:get-accessable-projects  area)
+   (let* ((projects `()))
+         
+        (if (sretrieve:has-permission area)
+               (set! projects (cons area projects))
+               (begin
+                 (sauth:print-error (conc "User cannot access area " area "!!"))  
+                (exit 1))) 
+   ; (print projects)
+    projects))
+		 
+(define (sauth-common:shell-ls-cmd base-path-list ext-path top-areas base-path tail-cmd-list)
+    (if (and (null? base-path-list) (equal? ext-path "") )
+      (print (string-intersperse top-areas " "))
+  (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas )))
+           ;(print resolved-path)
+           (if (not (equal? resolved-path #f))
+           (if (null? resolved-path) 
+             (print (string-intersperse top-areas " "))
+           (let* ((target-path (sauth-common:get-target-path  base-path-list  ext-path top-areas base-path)))
+                ;(print "Resolved path: " target-path)
+                (if (not (equal? target-path #f))
+                  (begin   
+                (if (symbolic-link? target-path)
+                   (set! target-path (conc target-path "/"))) 
+                (if (not (equal? target-path #f))
+                (begin 
+                (cond
+		  ((null? tail-cmd-list)
+		     (run (pipe
+      	      	      (ls "-lrt" ,target-path))))
+		  ((not (equal? (car tail-cmd-list) "|"))
+                         (print "ls cmd cannot accept "(string-join tail-cmd-list) " as an argument!!"))
+                  (else  
+                    (run (pipe
+      	      	      (ls "-lrt" ,target-path)
+                      (begin (system (string-join (cdr tail-cmd-list))))))
+      ))))))))))))
+
+(define (sretrieve:shell-cat-cmd base-pathlist ext-path top-areas base-path tail-cmd-list)
+  (let* ((resolved-path (sauth-common:resolve-path ext-path base-pathlist top-areas ))
+          (data "") )
+         (if (not (equal? resolved-path #f))
+           (if (null? resolved-path) 
+             (print "Path could not be resolved!!")
+           (let* ((target-path (sauth-common:get-target-path  base-pathlist  ext-path top-areas base-path)))
+             (if (not (equal? target-path #f))
+               (if (or (not (file-exists? target-path)) (directory? target-path))
+               (print "Target path does not exist or is a directory!") 
+               (begin 
+                 (cond
+		  ((null? tail-cmd-list)
+		     (run (pipe
+      	      	      (cat  ,target-path))))
+		  ((not (equal? (car tail-cmd-list) "|"))
+                         (print "cat cmd cannot accept "(string-join tail-cmd-list) " as an argument!!"))
+                  (else  
+                    (run (pipe
+      	      	      (cat ,target-path)
+                      (begin (system (string-join (cdr tail-cmd-list))))))))))
+)))
+             (print "Path could not be resolved!!"))))
+
+(define (get-options cmd-list split-str)
+    (if (null? cmd-list)
+              (list '() '())
+    (let loop ((hed (car cmd-list))
+		 (tal (cdr cmd-list))
+                  (res '()))
+                   (cond
+                   ((equal? hed split-str)
+                      (list res tal))
+                   ((null? tal)
+                      (list (cons hed res) tal)) 
+                   (else 
+		  	(loop (car tal)(cdr tal)(cons hed res)))))))
+
+  
+(define (sretrieve:shell-grep-cmd base-pathlist ext-path top-areas base-path tail-cmd-list)
+  (let* ((resolved-path (sauth-common:resolve-path ext-path base-pathlist top-areas ))
+          (pattern (car tail-cmd-list))
+          (pipe-cmd-list (get-options (cdr tail-cmd-list) "|"))
+          (options (string-join (car pipe-cmd-list)))
+          (pipe-cmd (cadr  pipe-cmd-list))
+          (redirect-split (string-split (string-join  tail-cmd-list) ">"))   )
+         (if(and ( > (length redirect-split) 2 ))
+            (print "sgrep  cmd cannot accept > " (string-join redirect-split) " as an argument!!" )  
+         (if (not (equal? resolved-path #f))
+           (if (null? resolved-path) 
+             (print "Path could not be resolved!!")
+           (let* ((target-path (sauth-common:get-target-path  base-pathlist  ext-path top-areas base-path))
+                  (restrictions (if (equal? target-path #f)
+                                                 ""
+                                               (sretrieve:shell-lookup base-path)))
+                 (rest-str  (string-split (conc " --exclude-dir=" (string-join (string-split restrictions ",") " --exclude-dir=") ))))
+             (if (not (file-exists? target-path))
+               (print "Target path does not exist!") 
+               (begin 
+                 (cond
+	 	  ((and (null? pipe-cmd) (string-null? options))
+	 	     (run (pipe
+      	      	      (grep ,pattern ,target-path ))))
+		  ((and (null? pipe-cmd) (not (string-null? options)))
+		     (run (pipe
+      	      	      (begin (process-execute "/usr/bin/grep" (append (list options pattern target-path) rest-str))))))
+                  ((and (not (null? pipe-cmd)) (string-null? options))
+                        (run (pipe
+      	      	      (grep ,exclude-dir ,pattern ,target-path)
+                      (begin (system (string-join pipe-cmd))))))
+                  (else   
+                      (run (pipe
+      	      	      ;(grep  ,options ,exclude-dir ,pattern ,target-path)
+                       (begin (process-execute "/usr/bin/grep" (append (list options pattern target-path) rest-str)))
+
+                      (begin (system (string-join  pipe-cmd)))))))
+))))
+             (print "Path could not be resolved!!")))))
+
+
+(define (sretrieve:shell-less-cmd base-pathlist ext-path top-areas base-path)
+  (let* ((resolved-path (sauth-common:resolve-path ext-path base-pathlist top-areas )))
+         (if (not (equal? resolved-path #f))
+           (if (null? resolved-path) 
+             (print "Path could not be resolved!!")
+           (let* ((target-path (sauth-common:get-target-path  base-pathlist  ext-path top-areas base-path)))
+               (if (not (equal? target-path #f))
+           	 (if (or (not (file-exists? target-path)) (directory? target-path))
+                   (print "Target path does not exist or is a directory!") 
+                   (begin 
+                     ;(sretrieve:shell-db-do
+         	     ;     db-location
+     		     ;	  (lambda (db)
+       		;		(sretrieve:register-action db "less" (current-user-name) target-path (conc "Executing cmd: less "  target-path))))   
+ 
+                     (setenv "LESSSECURE" "1")
+                     (run (pipe
+      	      	     (less ,target-path))))))))
+             (print "Path could not be resolved!!"))))
+
+
+
+(define (sretrieve:shell-lookup base-path)
+  (let* ((usr (current-user-name))
+          (value (get-restrictions base-path usr)))
+                              value))
+             
+
+(define (sretrieve:load-shell-config fname)
+          (if (file-exists? fname)
+	(read-config fname #f #f)
+	))
+
+
+(define (is_directory target-path) 
+  (let* ((retval #f))
+  (sretrieve:do-as-calling-user
+    	(lambda ()
+          ;(print (current-effective-user-id) ) 
+          (if (directory? target-path)
+               (set! retval  #t))))
+             ;(print (current-effective-user-id))
+     retval)) 
+
+(define (make-exclude-pattern  restriction-list  )
+  (if (null? restriction-list)
+     ""
+   (let loop ((hed (car restriction-list))
+		 (tal (cdr restriction-list))
+                  (ret-str ""))
+                   (cond
+                   ((null? tal)
+                      (conc ret-str ".+" hed ".*")) 
+                   (else 
+		  	(loop (car tal)(cdr tal)(conc ret-str ".+" hed ".*|"))))))    )
+
+(define (sretrieve:get-shell-cmd target-path base-path restrictions iport)
+     (if (not (file-exists? target-path))
+        (sauth:print-error "Target path does not exist!")
+    (begin
+    (if (not (equal? target-path #f))
+    (begin     
+        (if (is_directory target-path) 
+        (begin
+           (let* ((tmpfile (conc "/tmp/" (current-user-name) "/my-pipe"))
+                  (parent-dir target-path)
+                  (last-dir-name (if  (pathname-extension target-path)  
+                                      (conc(pathname-file target-path) "." (pathname-extension target-path))
+                                      (pathname-file target-path)))
+                  (curr-dir (current-directory))   
+                  (start-dir (conc (current-directory) "/" last-dir-name))
+                  (execlude (make-exclude-pattern (string-split restrictions ","))))
+                  ; (print tmpfile)
+                    (if  (file-exists? start-dir)
+                    (begin
+                         (print last-dir-name " already exist in your work dir. Do you want to over write it? [y|n]")
+                        (let* ((inl (read-line iport)))
+                            (if (equal? inl "y")
+                              (begin
+                                 (change-directory parent-dir)
+                                  (create-fifo  tmpfile)
+                                  (process-fork 
+    				   (lambda()
+                                       (sleep 1) 
+       					(with-output-to-file tmpfile
+         				(lambda ()
+            				(sretrieve:make_file parent-dir execlude parent-dir)))))
+ 
+                                  (run (pipe
+                   		   (tar "chfv" "-" "-T" ,tmpfile )
+                   		   (begin (system (conc "cd " start-dir ";tar  xUf - "   )))))
+                                   (change-directory curr-dir)
+                                    (system (conc "rm " tmpfile)) )
+			      (begin	
+                               (print  "Nothing has been retrieved!!  ")))))
+                     (begin
+                       (sretrieve:do-as-calling-user
+                    (lambda ()
+		      (create-directory start-dir #t)))
+                          (change-directory parent-dir)
+                          ; (print execlude)
+                           (create-fifo tmpfile)
+                            (process-fork 
+    				   (lambda()
+                                       (sleep 1) 
+       					(with-output-to-file tmpfile
+         				(lambda ()
+            				(sretrieve:make_file parent-dir execlude parent-dir)))))
+
+                                  (run (pipe
+                   		   (tar "chfv" "-"  "-T" ,tmpfile)
+                   		   (begin (system (conc "cd " start-dir ";tar  xUf - "    )))))
+                           (change-directory curr-dir)
+                            (system (conc "rm " tmpfile)))))) 
+        (begin
+           (let*((parent-dir (pathname-directory target-path))
+                 (start-dir (current-directory))
+                 (filename (if  (pathname-extension target-path)  
+                                      (conc(pathname-file target-path) "." (pathname-extension target-path))
+                                      (pathname-file target-path)))
+                 (work-dir-file (conc (current-directory) "/" filename)))
+                 (if  (file-exists? work-dir-file)
+                    (begin
+                       (print filename " already exist in your work dir. Do you want to over write it? [y|n]")
+                        (let* ((inl (read-line iport)))
+                            (if (equal? inl "y")
+                              (begin
+                                 (change-directory parent-dir)
+                                  (run (pipe
+                   		   (tar "chfv" "-" ,filename)
+                   		   (begin (system (conc "cd " start-dir ";tar  xUf - "   )))))
+                                     (change-directory start-dir))
+			      (begin	
+                               (print  "Nothing has been retrieved!!  ")))))
+                    (begin
+               (change-directory parent-dir)  
+                 (run (pipe
+                   (tar "chfv" "-" ,filename)
+                   (begin (system (conc "cd " start-dir ";tar xUf -")))))
+                    (change-directory start-dir)))))))))))
+
+(define (sretrieve:get-shell-cmd-line target-path base-path restrictions iport)
+   (handle-exceptions
+	   exn 
+	   (begin
+	     (sauth:print-error (conc "Problem fetching the data. Sauth provieds sudo access to only one unix group. Please ensure you have washed all the remaining groups. System Error: " 
+			  ((condition-property-accessor 'exn 'message) exn)))
+	     (exit 1))
+  
+    (if (not (file-exists? target-path))
+        (sauth:print-error "Error:Target path does not exist!")
+    (begin
+    (if (not (equal? target-path #f))
+    (begin     
+        (if (is_directory target-path) 
+        (begin
+           (let* ((parent-dir target-path)
+                  (last-dir-name (if  (pathname-extension target-path)  
+                                      (conc(pathname-file target-path) "." (pathname-extension target-path))
+                                      (pathname-file target-path)))
+                  (curr-dir (current-directory))   
+                  (start-dir (conc (current-directory) "/" last-dir-name))
+                  (execlude (make-exclude-pattern (string-split restrictions ",")))
+                   (tmpfile (conc "/tmp/my-pipe-" (current-process-id))))
+                    (if  (file-exists? start-dir)
+                    (begin
+                         (sauth:print-error (conclast-dir-name " already exist in your work dir."))
+                         (sauth:print-error  "Nothing has been retrieved!!  "))
+                     (begin
+                   ;    (sretrieve:do-as-calling-user
+                   ; (lambda ()
+                  ; (print tmpfile) 
+                  ;(if (not (file-exists?  (conc "/tmp/" (current-user-name)))) 
+		  ;    (create-directory (conc "/tmp/" (current-user-name)) #t))
+                          (change-directory parent-dir)
+                            (create-fifo  tmpfile)
+                                  (process-fork 
+    				   (lambda()
+                                       (sleep 1) 
+       					(with-output-to-file tmpfile
+         				(lambda ()
+            				(sretrieve:make_file parent-dir execlude parent-dir)))))
+
+                           (process-execute "/bin/tar" (append (list  "chfv" "-"  "-T" tmpfile)  (list "--ignore-failed-read")))    
+                                  ;(run (pipe
+                   		   ;(tar "chfv" "-" "." )
+                   		   ;(begin (system (conc "cd " start-dir ";tar  xUf - "   execlude )))))
+                            (system (conc "rm " tmpfile))    
+                           (change-directory curr-dir))))) 
+        (begin
+           (let*((parent-dir (pathname-directory target-path))
+                 (start-dir (current-directory))
+                 (filename (if  (pathname-extension target-path)  
+                                      (conc(pathname-file target-path) "." (pathname-extension target-path))
+                                      (pathname-file target-path)))
+                 (work-dir-file (conc (current-directory) "/" filename)))
+                 (if  (file-exists? work-dir-file)
+                    (begin
+                       (print filename " already exist in your work dir.")
+                               (print  "Nothing has been retrieved!!  "))
+                    (begin
+               (change-directory parent-dir)
+                (process-execute "/bin/tar" (append (append (list  "chfv" "-") (list filename)) (list "--ignore-failed-read"))) 
+                 ;(run (pipe
+                  ; (tar "chfv" "-" ,filename)
+                  ; (begin (system (conc "cd " start-dir ";tar xUf -")))))
+                    (change-directory start-dir))))))))))))
+
+(define (sretrieve:make_file path exclude base_path)
+   (find-files 
+     path
+     action: (lambda (p res)
+           (cond
+                ((symbolic-link? p)   
+                 (if (directory?(read-symbolic-link p)) 
+                      (sretrieve:make_file p exclude base_path)
+                      (print (string-substitute (conc base_path "/") "" p "-"))))
+                 ((directory? p)              
+                 ;;do nothing for dirs)
+                 ) 
+                (else 
+                                        
+                     (if (not (string-match (regexp exclude)  p ))
+                        (print (string-substitute (conc base_path "/") "" p "-"))))))
+         dotfiles: #t))
+
+(define (sretrieve:shell-help)
+(conc "Usage: " *exe-name* " [action [params ...]]
+
+  ls    [target path]               	  : list contents of target area. The output of the cmd can be piped into other system cmd. eg ls <path> | grep txt
+  cd    <target directory>	     	  : To change the current directory within the sretrive shell. 
+  pwd				     	  : Prints the full pathname of the current directory within the sretrive shell.
+  get   <file or directory path>     	  : download directory/files into the directory where sretrieve shell cmd was invoked   
+  less  <file path>		     	  : Read input file to allows backward movement in the file as well as forward movement 
+  cat   <file path>                  	  : show the contents of a file. The output of the cmd can be piped into other system cmd.
+
+  sgrep <search path> <pattern> [options] : Similar to unix grep cmd But with diffrent parameter ordering. The output of the cmd can be piped into other system cmd. 
+Part of the Megatest tool suite.
+Learn more at http://www.kiatoa.com/fossils/megatest
+
+Version: " megatest-fossil-hash)
+)	
+;(define (toplevel-command . args) #f)
+(define (sretrieve:shell area)
+ ; (print area)
+  (use readline)
+  (let* ((path      '())
+	 (prompt    "sretrieve> ")
+	 (args      (argv))
+         (usr (current-user-name) )   
+         (top-areas (sretrieve:get-accessable-projects area))
+         (close-port     #f)
+         (area-obj  (get-obj-by-code area))
+         (user-obj (get-user usr)) 
+         (base-path (if (null? area-obj) 
+                         "" 
+                        (caddr (cdr area-obj))))      
+	 (iport     (make-readline-port prompt)))
+        (if (null? area-obj)
+          (begin 
+             (print "Area " area " does not exist")
+          (exit 1)))
+	(let loop ((inl (read-line iport)))
+          ;(print 1) 
+	  (if (not (or (or (eof-object? inl)
+		       (equal? inl "exit")) (port-closed? iport)))
+	      (let* ((parts (string-split inl))
+		     (cmd   (if (null? parts) #f (car parts))))
+              ;  (print "2")
+		(if (and (not cmd) (not (port-closed? iport)))
+		    (loop (read-line))
+		    (case (string->symbol cmd)
+		      ((cd)
+		       (if (> (length parts) 1) ;; have a parameter
+                           (begin
+                             (let*((arg (cadr parts))
+                                   (resolved-path (sauth-common:resolve-path  arg path top-areas))
+                                   (target-path (sauth-common:get-target-path path  arg top-areas base-path)))
+                                 (if (not (equal? target-path #f))
+                                 (if (or (equal? resolved-path #f) (not (file-exists? target-path)))    
+                                 (print "Invalid argument " arg ".. ")
+                                  (begin      
+			            (set! path resolved-path)
+                                     (sauthorize:do-as-calling-user
+                              (lambda ()
+			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "cd"))))
+                                  )))))  
+   			   (set! path '())))
+                      ((pwd)
+                         (if (null? path)
+                           (print "/")  
+                           (print "/" (string-join path "/")))) 
+		      ((ls)
+		       (let* ((thepath (if (> (length parts) 1) ;; have a parameter
+					   (cdr parts)
+					   `()))
+			      (plen    (length thepath)))
+                         (cond
+			  ((null? thepath)
+                           (sauth-common:shell-ls-cmd path "" top-areas base-path  '())
+                            (sauthorize:do-as-calling-user
+                              (lambda ()
+			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "ls"))))   )
+			  ((< plen 2)
+                  
+                            (sauth-common:shell-ls-cmd path  (car thepath) top-areas base-path '())
+                              (sauthorize:do-as-calling-user
+                              (lambda ()
+			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "ls")))))
+                          (else 
+                            (if (equal? (car thepath) "|")
+                              (sauth-common:shell-ls-cmd path "" top-areas base-path thepath)
+                              (sauth-common:shell-ls-cmd path  (car thepath) top-areas base-path (cdr thepath)))
+                           (sauthorize:do-as-calling-user
+                              (lambda ()
+			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "ls"))))))))
+                       ((cat)
+		       (let* ((thepath (if (> (length parts) 1) ;; have a parameter
+					   (cdr parts)
+					   `()))
+			      (plen    (length thepath)))
+			 (cond
+			  ((null? thepath)
+                          (print "Error: Missing argument to cat"))
+			  ((< plen 2)
+                            (sretrieve:shell-cat-cmd path  (car thepath) top-areas base-path '())
+                              (sauthorize:do-as-calling-user
+                              (lambda ()
+			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "cat")))))
+
+			  (else
+                             (sretrieve:shell-cat-cmd path  (car thepath) top-areas base-path (cdr thepath))
+                             (sauthorize:do-as-calling-user
+                              (lambda ()
+			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "cat"))))
+))))
+                       ((sgrep)
+		       (let* ((thepath (if (> (length parts) 1) ;; have a parameter
+					   (cdr parts)
+					   `()))
+			      (plen    (length thepath)))
+			 (cond
+			  ((null? thepath) 
+                            (print "Error: Missing arguments to grep!! Useage: grep <search path> <pattern> [options] "))
+                          ((< plen  2)
+                          (print "Error: Missing arguments to grep!! Useage: grep <search path> <pattern> [options] "))
+			  (else
+                             (sretrieve:shell-grep-cmd path  (car thepath) top-areas base-path  (cdr thepath))
+				(sauthorize:do-as-calling-user
+                              (lambda ()
+			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "grep"))))))))
+
+                      ((less)
+		       (let* ((thepath (if (> (length parts) 1) ;; have a parameter
+					   (cdr parts)
+					   `()))
+			      (plen    (length thepath)))
+			 (cond
+			  ((null? thepath)
+                          (print "Error: Missing argument to less"))
+			  ((< plen 2)
+                            (sretrieve:shell-less-cmd path  (car thepath) top-areas base-path)
+                             (sauthorize:do-as-calling-user
+                              (lambda ()
+			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "less")))))
+			  (else
+                             (print "less cmd takes only one (<file path>) argument!!")))))
+                      ((get)
+                         (let* ((thepath (if (> (length parts) 1) ;; have a parameter
+					   (cdr parts)
+					   `()))
+			      (plen    (length thepath)))
+			 (cond
+			  ((null? thepath)
+                          (print "Error: Missing argument <path> to get"))
+			  ((< plen 2)
+                           (let* ((target-path (sauth-common:get-target-path path  (car thepath) top-areas base-path))
+				 (restrictions (if (equal? target-path #f)
+                                                 ""
+                                               (sretrieve:shell-lookup base-path))))
+                               (if (not (equal? target-path #f))
+                             (begin  
+                                 (sretrieve:get-shell-cmd target-path base-path restrictions iport)
+                                  (sauthorize:do-as-calling-user
+                              (lambda ()
+			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "get"))))))))
+			  (else
+                            (print "Error: get cmd takes only one argument ")))))
+                      ((exit)
+                          (print "got exit"))  
+                      ((help)
+                          (print (sretrieve:shell-help)))
+		      (else 
+		       (print "Got command: " inl))))
+                 (loop (read-line iport)))))))
+;;))
+    
+
+;;======================================================================
+;; MAIN
+;;======================================================================
+;;(define *default-log-port* (current-error-port))
+
+;(define (sretrieve:load-config exe-dir exe-name)
+;  (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 #f)
+;	(make-hash-table))))
+
+;; package-type is "megatest", "builds", "kits" etc.
+;;
+
+;(define (sretrieve:load-packages configdat exe-dir package-type)
+;  (push-directory exe-dir)
+;  (let* ((packages-metadir  (configf:lookup configdat "settings" "packages-metadir"))
+;	 (conversion-script (configf:lookup configdat "settings" "conversion-script"))
+;	 (upstream-file     (configf:lookup configdat "settings" "upstream-file"))
+;	 (package-config    (conc packages-metadir "/" package-type ".config")))
+;       (if (file-exists? upstream-file)
+;	(if (or (not (file-exists? package-config)) ;; if not created call the updater, otherwise call only if upstream newer
+;		(> (file-modification-time upstream-file)(file-modification-time package-config)))
+;	    (handle-exceptions
+;	     exn
+;	     (debug:print 0 "ERROR: failed to run script " conversion-script " with params " upstream-file " " package-config)
+;	     (let ((pid (process-run conversion-script (list upstream-file package-config))))
+;	       (process-wait pid)))
+;	    (debug:print 0 "Skipping update of " package-config " from " upstream-file))
+;	(debug:print 0 "Skipping update of " package-config " as " upstream-file " not found"))
+;       (let ((res (if (file-exists? package-config)
+;		   (begin
+;		     (debug:print 0 "Reading package config " package-config)
+;		     (read-config package-config #f #t))
+;		   (make-hash-table))))
+;      (pop-directory)
+;      res)))
+
+(define (toplevel-command . args) #f)
+(define (sretrieve:process-action  action . args)
+    ; (print action)
+ ;  (use readline)
+    (case (string->symbol action)
+      ((get)
+       (if (< (length args) 2)
+	   (begin 
+	     (sauth:print-error  "Missing arguments; <area> <relative path>" )
+	     (exit 1)))
+       (let* ((remargs     (args:get-args args '("-m" ) '() args:arg-hash 0))
+              (iport (make-readline-port ">"))
+              (area     (car args))
+              (usr (current-user-name))
+              (area-obj  (get-obj-by-code area))
+              (user-obj (get-user usr))
+              (top-areas (sretrieve:get-accessable-projects area)) 
+              (base-path (if (null? area-obj) 
+                                      "" 
+                                     (caddr (cdr area-obj))))
+	      (sub-path       (if (null? remargs) 
+                                       "" 
+                                       (car remargs))))
+
+          (if (null? area-obj)
+          	    (begin 
+             		(sauth:print-error (conc "Area " area " does not exist"))
+          	         (exit 1)))
+              (let* ((target-path (sauth-common:get-target-path '()  (conc area "/" sub-path) top-areas base-path))
+		     (restrictions (if (equal? target-path #f)
+                                        ""
+                                       (sretrieve:shell-lookup base-path))))
+             (if (not (equal? target-path #f))
+                 (begin  
+                   (sauthorize:do-as-calling-user
+                      (lambda ()
+   		        (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "get " area " " sub-path) (number->string (car user-obj))  (number->string (caddr area-obj))  "get"))))
+                        (sretrieve:get-shell-cmd-line target-path base-path restrictions  iport))))))
+         ((cp)
+             (if (< (length args) 2)
+	   (begin 
+	     (sauth:print-error  "Missing arguments; <area> <relative path>" )
+	     (exit 1)))
+       (let* ((remargs     (args:get-args args '("-m" ) '() args:arg-hash 0))
+              (iport (make-readline-port ">"))
+              (area     (car args))
+              (usr (current-user-name))
+              (area-obj  (get-obj-by-code area))
+              (user-obj (get-user usr))
+              (top-areas (sretrieve:get-accessable-projects area)) 
+              (base-path (if (null? area-obj) 
+                                      "" 
+                                     (caddr (cdr area-obj))))
+	      (sub-path       (if (null? remargs) 
+                                       "" 
+                                       (car remargs))))
+         ;  (print args)
+          (if (null? area-obj)
+          	    (begin 
+             		(sauth:print-error (conc "Area " area " does not exist"))
+          	         (exit 1)))
+              (let* ((target-path (sauth-common:get-target-path '()  (conc area "/" sub-path) top-areas base-path))
+				 (restrictions (if (equal? target-path #f)
+                                                 ""
+                                              (sretrieve:shell-lookup base-path))))
+                          ;(print target-path) 
+                          (if (not (equal? target-path #f))
+                             (begin  
+                              (sauthorize:do-as-calling-user
+                              (lambda ()
+			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "get " area " " sub-path) (number->string (car user-obj))  (number->string (caddr area-obj))  "get"))))
+                            (sretrieve:get-shell-cmd-line target-path base-path restrictions  iport))))))
+      ((cat)
+      (if (< (length args) 2)
+	   (begin 
+	     (sauth:print-error  "Missing arguments; <area> <relative path>" )
+	     (exit 1)))
+       (let* ((remargs     (args:get-args args '("-m" ) '() args:arg-hash 0))
+              (area     (car args))
+              (usr (current-user-name))
+              (area-obj  (get-obj-by-code area))
+              (user-obj (get-user usr))
+              (top-areas (sretrieve:get-accessable-projects area)) 
+              (base-path (if (null? area-obj) 
+                                      "" 
+                                     (caddr (cdr area-obj))))
+	            (sub-path       (if (null? remargs) 
+                                       "" 
+                                       (car remargs))))
+
+          (if (null? area-obj)
+          	    (begin 
+             		(sauth:print-error (conc "Area " area " does not exist"))
+          	         (exit 1)))
+              (let* ((target-path (sauth-common:get-target-path '()  (conc area "/" sub-path) top-areas base-path))
+		     (restrictions (if (equal? target-path #f)
+                                        ""
+                                       (sretrieve:shell-lookup base-path))))
+;(sauth-common:shell-ls-cmd base-path-list ext-path top-areas base-path tail-cmd-list)
+
+             (if (not (equal? target-path #f))
+                 (begin  
+                   (sauthorize:do-as-calling-user
+                      (lambda ()
+   		        (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "get " area " " sub-path) (number->string (car user-obj))  (number->string (caddr area-obj))  "get"))))
+               (sretrieve:shell-cat-cmd (list area) sub-path  top-areas base-path '())))))) 
+      ((ls)
+          (cond
+            ((< (length args) 1)
+              (begin 
+	      (print  "ERROR: Missing arguments; <area> ")
+	      (exit 1)))
+              ((equal? (length args) 1)
+                 (let*  ((area     (car args))
+                         (usr (current-user-name))
+                         (area-obj  (get-obj-by-code area))
+                         (user-obj (get-user usr))
+                         (top-areas (sretrieve:get-accessable-projects area)) 
+                         (base-path (if (null? area-obj) 
+                                      "" 
+                                     (caddr (cdr area-obj)))))
+                  (if (null? area-obj)
+          	    (begin 
+             		(print "Area " area " does not exist")
+          	         (exit 1)))
+             
+            ; (sretrieve:shell-cat-cmd base-pathlist ext-path top-areas base-path tail-cmd-list)
+   
+           	 (sauth-common:shell-ls-cmd '() area top-areas base-path  '())
+                 (sauthorize:do-as-calling-user
+                   (lambda ()
+		    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" "ls" (number->string (car user-obj)) (number->string (caddr area-obj)) "ls"))))))
+             ((> (length args) 1)
+               (let*  ((remargs     (args:get-args args '("-m" ) '() args:arg-hash 0))
+                        (usr (current-user-name))
+                        (user-obj (get-user usr))
+                         (area     (car args)))
+                         (let* ((area-obj  (get-obj-by-code area))
+                               (top-areas (sretrieve:get-accessable-projects area)) 
+                               (base-path (if (null? area-obj) 
+                                      "" 
+                                     (caddr (cdr area-obj))))
+                                 
+                               (sub-path (if (null? remargs) 
+                                       area 
+                                      (conc area "/" (car remargs)))))
+                             ;(print "sub path "  sub-path)
+                            (if (null? area-obj)
+          	              (begin 
+             		        (print "Area " area " does not exist")
+          	                 (exit 1)))
+                              (sauth-common:shell-ls-cmd `()  sub-path top-areas base-path '())
+                            (sauthorize:do-as-calling-user
+				(lambda ()
+                       	       (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "ls " sub-path) (number->string (car user-obj)) (number->string (caddr area-obj)) "ls")))))))))
+
+       ((shell)
+          (if (< (length args) 1)
+             (begin 
+	     (print  "ERROR: Missing arguments <area>!!" )
+	     (exit 1))
+             (sretrieve:shell (car args)))) 
+      (else (print 0 "Unrecognised command " action))))
+
+(define (main)
+  (let* ((args      (argv))
+	 (prog      (car args))
+	 (rema      (cdr args))
+	 (exe-name  (pathname-file (car (argv))))
+	 ;(exe-dir   (or (pathname-directory prog)
+	;		(sretrieve:find exe-name (string-split (get-environment-variable "PATH") ":"))))
+	 ;(configdat (sretrieve:load-config exe-dir exe-name))
+)
+    ;; preserve the exe data in the config file
+    ;(hash-table-set! configdat "exe-info" (list (list "exe-name" exe-name)
+					;	(list "exe-dir"  exe-dir)))
+    (cond
+     ;; one-word commands
+     ((eq? (length rema) 1)
+      (case (string->symbol (car rema))
+	((help -h -help --h --help)
+	 (print sretrieve:help))
+	(else
+	 (print "ERROR: Unrecognised command. Try \"sretrieve help\""))))
+     ;; multi-word commands
+     ((null? rema)(print sretrieve:help))
+     ((>= (length rema) 2)
+      
+      (apply sretrieve:process-action  (car rema) (cdr rema)))
+     (else (debug:print 0 "ERROR: Unrecognised command. Try \"sretrieve help\"")))))
+
+(main)
+
+
+      

DELETED sauthorize.scm
Index: sauthorize.scm
==================================================================
--- sauthorize.scm
+++ /dev/null
@@ -1,651 +0,0 @@
-
-;; Copyright 2006-2013, Matthew Welland.
-;; 
-;; This file is part of Megatest.
-;; 
-;;     Megatest is free software: you can redistribute it and/or modify
-;;     it under the terms of the GNU General Public License as published by
-;;     the Free Software Foundation, either version 3 of the License, or
-;;     (at your option) any later version.
-;; 
-;;     Megatest is distributed in the hope that it will be useful,
-;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;     GNU General Public License for more details.
-;; 
-;;     You should have received a copy of the GNU General Public License
-;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
-;;
-
-(use defstruct)
-(use scsh-process)
-
-(use srfi-18)
-(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))
-
-(include "megatest-version.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")
-
-;;
-;; GLOBALS
-;;
-(define *verbosity* 1)
-(define *logging* #f)
-(define *exe-name* (pathname-file (car (argv))))
-(define *sretrieve:current-tab-number* 0)
-(define *args-hash* (make-hash-table))
-(define sauthorize:help (conc "Usage: " *exe-name* " [action [params ...]]
-
-  list                   		 			: list areas $USER's can access
-  log                    		 			: get listing of recent activity.
-  sauth  list-area-user <area code> 			: list the users that can access the area.
-  sauth open <path> --group <grpname>                      : Open up an area. User needs to be the owner of the area to open it. 
-              --code <unique short identifier for an area> 
-              --retrieve|--publish [--additional-grps <comma separated unix grps requierd to get to the path>]
-  sauth update <area code>  --retrieve|--publish             : update the binaries with the lates changes
-  sauth grant <username> --area <area identifier>          : Grant permission to read or write to a area that is alrady opend up.    
-             --expiration yyyy/mm/dd --retrieve|--publish 
-             [--restrict <comma separated directory names> ]  
-  sauth read-shell <area identifier>                       :  Open sretrieve shell for reading.  
-  sauth write-shell <area identifier>                      :  Open spublish shell for writing.
-   
-Part of the Megatest tool suite.
-Learn more at http://www.kiatoa.com/fossils/megatest
-
-Version: " megatest-fossil-hash)) ;; "
-
-;;======================================================================
-;; RECORDS
-;;======================================================================
-
-;;======================================================================
-;; DB
-;;======================================================================
-
-;; replace (strftime('%s','now')), with datetime('now'))
-(define (sauthorize:initialize-db db)
-  (for-each
-   (lambda (qry)
-     (exec (sql db qry)))
-   (list 
-    "CREATE TABLE IF NOT EXISTS actions
-         (id           INTEGER PRIMARY KEY,
-          cmd       TEXT NOT NULL,
-          user_id      INTEGER NOT NULL,
-          datetime     TIMESTAMP DEFAULT (datetime('now','localtime')),
-          area_id      INTEGER NOT NULL,
-          comment      TEXT DEFAULT '' NOT NULL,
-          action_type  TEXT NOT NULL);"
-        "CREATE TABLE IF NOT EXISTS users
-         (id           INTEGER PRIMARY KEY,
-          username     TEXT NOT NULL,
-          is_admin     TEXT NOT NULL,
-          datetime     TIMESTAMP DEFAULT (datetime('now','localtime'))
-          );" 
-          "CREATE TABLE IF NOT EXISTS areas
-         (id           INTEGER PRIMARY KEY,
-          basepath     TEXT NOT NULL,
-          code         TEXT NOT NULL,
-          exe_name     TEXT NOT NULL,
-          required_grps TEXT DEFAULT '' NOT NULL,
-          datetime     TIMESTAMP DEFAULT (datetime('now','localtime'))
-          );" 
-         "CREATE TABLE IF NOT EXISTS permissions
-         (id              INTEGER PRIMARY KEY,
-          access_type     TEXT NOT NULL,
-          user_id         INTEGER NOT NULL,
-          datetime        TIMESTAMP DEFAULT (datetime('now','localtime')),
-          area_id         INTEGER NOT NULL,
-          restriction     TEXT DEFAULT '' NOT NULL,
-          expiration       TIMESTAMP DEFAULT NULL);"
-    )))
-
-
-
-
-(define (get-access-type args)
-   (let loop ((hed (car args))
-		 (tal (cdr args)))
-                   (cond
-                   ((equal? hed "--retrieve")
-                      "retrieve") 
-                   ((equal? hed "--publish")
-                      "publish") 
-                   ((equal? hed "--area-admin")
-                      "area-admin")
-                   ((equal? hed "--writer-admin")
-                      "writer-admin")
-                   ((equal? hed "--read-admin")
-                      "read-admin")
-
-                   ((null? tal)
-                      #f) 
-                   (else 
-		  	(loop (car tal)(cdr tal))))))
-
-
-
-;; check if user can gran access to an area
-(define (can-grant-perm username access-type area)
-   (let* ((isadmin (is-admin username))
-          (is-area-admin (is-user "area-admin" username area ))
-          (is-read-admin (is-user "read-admin" username area) )
-          (is-writer-admin (is-user "writer-admin" username area) ) )
-   (cond
-   ((equal? isadmin  #t)
-     #t)
-   ((equal? is-area-admin #t ) 
-     #t)
-   ((and (equal? is-writer-admin #t ) (equal? access-type "retrieve"))
-     #t)
-   ((and (equal? is-read-admin #t ) (equal? access-type "retrieve"))
-     #t)
-
-   (else  
-    #f))))
-
-(define (sauthorize:list-areausers  area )
-  (sauthorize:db-do  (lambda (db)
-				     (print "Users having access to " area ":")
-				     (query (for-each-row
-					     (lambda (row)
-                                               (let* ((exp-date (cadr row)))
-                                                (if  (is-access-valid  exp-date)   
-					        (apply print (intersperse row " | "))))))
-					    (sql db (conc "SELECT users.username, permissions.expiration, permissions.access_type  FROM users, areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and areas.code = '" area "'"))))))
-
-
-
-
-; check if executable exists
-(define (exe-exist exe access-type)
-    (let* ((filepath (conc *exe-path* "/" access-type "/" exe)))
-    ; (print filepath)
-     (if (file-exists? filepath)
-       #t
-       #f)))
-
-(define (copy-exe access-type exe-name group)
-  (run-cmd "/bin/chmod" (list "g+w" (conc *exe-path* "/" access-type)))
-  (let* ((spath (conc *exe-src*  "/s" access-type))
-         (dpath (conc *exe-path* "/" access-type "/" exe-name)))
-         (sauthorize:do-as-calling-user
-        (lambda ()
-            (run-cmd "/bin/cp" (list spath dpath )) 
-            (if (equal? access-type "publish")
-              (run-cmd "/bin/chmod" (list "u+s,o+rx" dpath))
-              (begin
-               (if (equal? group "none")
-                 (run-cmd "/bin/chmod" (list "u+s,o+rx" dpath))
-                 (begin   
-                     (run-cmd "/bin/chgrp" (list group dpath))
-                       (run-cmd "/bin/chmod" (list "g+s,o+rx" dpath))))))))
-	(run-cmd "chmod" (list "g-w" (conc *exe-path* "/" access-type)))))
-
-(define (get-exe-name path group)
-   (let ((name ""))
-   (sauthorize:do-as-calling-user
-        (lambda ()
-        (if (equal? (current-effective-user-id) (file-owner path)) 
-          (set! name (conc (current-user-name) "_" group))
-          (begin
-            (print "You cannot open areas that you dont own!!")  
-             (exit 1)))))
-name))
-
-(define (sauthorize:valid-unix-user username)
-    (let* ((ret-val #f))
-    (let-values (((inp oup pid)
-              (process "/usr/bin/id" (list username))))
-        (let loop ((inl (read-line inp)))
-          (if (string? inl) 
-          (if (string-contains inl  "No such user") 
-            (set! ret-val #f)
-             (set! ret-val #t)))   
-          (if (eof-object? inl)
-              (begin
-                   (close-input-port inp)
-                  (close-output-port oup))
-            (loop (read-line inp)))))
-            ret-val))
-
-
-;check if a paths/codes are vaid and if area is alrady open  
-(define (open-area group path code access-type other-grps)
-   (let* ((exe-name (get-exe-name path group))
-           (path-obj (get-obj-by-path path))
-           (code-obj (get-obj-by-code-no-grp-validation code)))
-           ;(print path-obj)   
-          (cond
-            ((not (null? path-obj))
-                (if (equal? code (car path-obj))
-                  (begin
-                     (if (equal? exe-name (cadr path-obj))
-                        (begin
-                            (if (not (exe-exist exe-name  access-type))
-                                 (copy-exe access-type exe-name group)
-                                 (begin 
-                                  (print "Area already open!!")
-                                  (exit 1))))   
-			(begin
-                           (if (not (exe-exist exe-name  access-type))
-                                 (copy-exe access-type exe-name group))
-                           ;; update exe-name  in db 
-                      (sauthorize:db-do   (lambda (db)
-                         (sauthorize:db-qry db (conc "update areas set exe_name = '" exe-name "' where id = " (caddr path-obj)))))
-                        )))
-                   (begin
-                       (print "Path " path " is registered with --code " (car path-obj) ". To open this area please execute following cmd: \n  sauthorize open " path " --group " group " --code " (car path-obj) " --" access-type )
-                       (exit 1))))
-                      
-            ((not (null? code-obj))
-                   (print "Code " code " is used for diffrent path. Please try diffrent value of --code" ) 
-                   (exit 1))
-            (else
-               ; (print (exe-exist exe-name  access-type))
-                (if (not (exe-exist exe-name  access-type))
-                        (copy-exe access-type exe-name group))
-                (sauthorize:db-do   (lambda (db)
-               (print conc "insert into areas (code, basepath, exe_name, required_grps) values ('" code "', '" path "', '" exe-name "', '" other-grps "') ") 
-             (sauthorize:db-qry db (conc "insert into areas (code, basepath, exe_name, required_grps) values ('" code "', '" path "', '" exe-name "', '" other-grps "') "))))))))
-
-(define (user-has-open-perm user path access)
-  (let* ((has-access #f)
-         (eid (current-user-id)))
-    (cond
-     ((is-admin  user)
-       (set! has-access #t ))
-     ((and (is-read-admin  user) (equal? access "retrieve"))
-       (set! has-access #t ))
-     (else
-        (print "User " user " does not have permission to open areas")))
-        has-access))
-
-
-;;check if user has group access
-(define (is-group-washed req_grpid current-grp-list)
-  (let loop ((hed (car current-grp-list))
-		 (tal (cdr current-grp-list)))
-                   (cond
-                   ((equal? hed req_grpid)
-                    #t)    
-                   ((null? tal)
-                      #f)
-                   (else 
-		  	(loop (car tal)(cdr tal))))))
-
-;create executables with appropriate suids
-(define (sauthorize:open user path group code access-type other-groups)
-   (let* ((gpid (group-information group))
-         (req_grpid (if (equal? group "none")
-                      group 
-                      (if (equal? gpid #f)
-                           #f      
-                     (caddr gpid))))
-         (current-grp-list (get-groups))
-         (valid-grp (if (equal? group "none")
-                     group
-                    (is-group-washed req_grpid current-grp-list))))
-   (if (and (not (equal? group "none")) (equal? valid-grp #f ))
-       (begin
-       (print "Group " group " is not washed in the current xterm!!") 
-       (exit 1)))) 
-   (if (not (file-write-access? path))
-     (begin
-       (print "You can open areas owned by yourself. You do not have permissions to open path." path)
-        (exit 1)))
-   (if (user-has-open-perm user path access-type)
-      (begin 
-       ;(print "here")   
-       (open-area group path code access-type other-groups)
-       (sauthorize:grant user user code "2017/12/25"  "read-admin" "") 
-       (sauthorize:db-do   (lambda (db)
-             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize open " path " --code " code " --group " group " --" access-type "'," (car (get-user user)) "," (car (get-area code)) ", 'open' )"))))
-         (print "Area has " path "  been opened for " access-type ))))
-
-(define (sauthorize:update username exe area access-type)
-  (let* ((parts (string-split exe "_"))
-         (owner (car parts))
-         (group (cadr parts))
-         (gpid (group-information group))
-         (req_grpid (if (equal? group "none")
-                      group 
-                      (if (equal? gpid #f)
-                           #f      
-                     (caddr gpid))))
- 
-         (current-grp-list (get-groups))
-         (valid-grp (if (equal? group "none")
-                     group
-                    (is-group-washed req_grpid current-grp-list))))
-         (if (not (equal? username owner))
-            (begin
-              (print "You cannot update " area ". Only " owner " can update this area!!") 
-               (exit 1)))
-          (copy-exe access-type exe group)
-           (print "recording action..")    
-          (sauthorize:db-do   (lambda (db)
-             
-             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize update " area " --" access-type "'," (car (get-user username)) "," (car (get-area area)) ", 'update' )"))))
-         (print "Area has " area "  been update!!" )))
-
-(define (sauthorize:grant auser guser area exp-date access-type restrict)
-    ; check if user exist in db
-    (let* ((area-obj (get-area area))
-           (auser-obj (get-user auser)) 
-           (user-obj (get-user guser)))
-          
-        (if (null? user-obj)
-           (begin
-            ;; is guser a valid unix user
-            (if (not (sauthorize:valid-unix-user guser))
-               (begin  
-                (print "User " guser " is Invalid unix user!!")
-                 (exit 1)))
-            (sauthorize:db-do   (lambda (db)
-             (sauthorize:db-qry db (conc "insert into users (username, is_admin) values ('" guser "', 'no') "))))
-             (set! user-obj (get-user guser))))
-        (let* ((perm-obj (get-perm (car user-obj) (car area-obj))))
-          (if(null? perm-obj)
-          (begin   
-            ;; insert permissions
-            (sauthorize:db-do   (lambda (db)
-            (sauthorize:db-qry db (conc "insert into permissions (access_type, user_id, area_id, restriction, expiration ) values ('" access-type "', " (car user-obj) ", " (car area-obj) ", '" restrict "', '" exp-date "')")))))
-          (begin 
-             ;update permissions
-             (sauthorize:db-do   (lambda (db)
-             (sauthorize:db-qry db (conc "update permissions set access_type = '" access-type "' , restriction = '" restrict "', expiration =  '" exp-date "' where user_id = " (car user-obj) " and area_id = " (car area-obj)))))))
-             (sauthorize:db-do   (lambda (db)
-             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize grant " guser " --area " area " --expiration " exp-date " --" access-type " --restrict " restrict "'," (car auser-obj) "," (car area-obj) ", 'grant' )"))))  
-             (print "Permission has been sucessfully granted to user " guser))))
-
-(define (sauthorize:process-action  username action . args)
-   (case (string->symbol action)
-   ((grant)
-      (if (< (length args) 6)
-         (begin 
-	     (print  "ERROR: Missing arguments; " (string-intersperse args ", "))
-	     (exit 1)))
-       (let* ((remargs     (args:get-args args '("--area" "--expiration" "--restrict") '() args:arg-hash 0))
-              (guser     (car args))
-	      (restrict         (or (args:get-arg "--restrict") ""))
-              (area         (or (args:get-arg "--area") ""))  
-              (exp-date        (or (args:get-arg "--expiration") ""))
-              (access-type (get-access-type remargs)))
-	; (print  "version " guser " restrict " restrict )
-        ; (print "area " area " exp-date " exp-date " access-type " access-type)
-        (cond
-           ((equal? guser "")
-              (print "Username not found!! Try \"sauthorize help\" for useage ")
-               (exit 1))   
-           ((equal? area "")
-              (print "Area not found!! Try \"sauthorize help\" for useage ")
-              (exit 1)) 
-           ((equal? access-type #f)
-              (print "Access type not found!! Try \"sauthorize help\" for useage ")
-               (exit 1)) 
-           ((equal? exp-date "")
-              (print "Date of expiration not found!! Try \"sauthorize help\" for useage ")
-              (exit 1)))
-           (if (not (area-exists area))
-              (begin
-              (print "Area does not exisit!!")
-              (exit 1)))   
-           (if (can-grant-perm username access-type area)
-	   (begin
-             (print "calling sauthorize:grant ") 
-              (sauthorize:grant username guser area exp-date access-type restrict))   
-           (begin
-              (print "User " username " does not have permission to grant permissions to area " area "!!")
-              (exit 1)))))
-       ((list-area-user)
-          (if (not (equal? (length args) 1))
-              (begin
-              (print "Missing argument area code to list-area-user ") 
-              (exit 1)))
-           (let* ((area (car args)))
-           (if (not (area-exists area))
-              (begin
-              (print "Area does not exisit!!")
-              (exit 1))) 
-                                
-                (sauthorize:list-areausers  area )
-              ))
-      ((read-shell)
-          (if (not (equal? (length args) 1))
-              (begin
-              (print "Missing argument area code to read-shell ") 
-              (exit 1)))
-           (let* ((area (car args))
-                  (code-obj (get-obj-by-code area)))
-           (if (or (null? code-obj)
-                   (not (exe-exist (cadr code-obj)  "retrieve")))
-              (begin
-              (print "Area " area " is not open for reading!!")
-              (exit 1))) 
-              (sauthorize:do-as-calling-user
-             (lambda ()
-                (run-cmd (conc *exe-path* "/retrieve/" (cadr code-obj) ) (list "shell" area ))))))
-      ((write-shell)
-          (if (not (equal? (length args) 1))
-              (begin
-              (print "Missing argument area code to read-shell ") 
-              (exit 1)))
-           (let* ((area (car args))
-                  (code-obj (get-obj-by-code area)))
-           (if (or (null? code-obj)
-                   (not (exe-exist (cadr code-obj)  "publish")))
-              (begin
-              (print "Area " area " is not open for Writing!!")
-              (exit 1))) 
-              (sauthorize:do-as-calling-user
-             (lambda ()
-                (run-cmd (conc *exe-path* "/publish/" (cadr code-obj) ) (list "shell" area))))))
-      ((publish)
-          (if (< (length args) 2)
-              (begin
-              (print "Missing argument to publish. \n publish <action> <area> [opts] ") 
-              (exit 1)))
-            
-           (let* ((action (car args))
-                  (area (cadr args))
-                  (cmd-args (cddr args)) 
-                  (code-obj (get-obj-by-code area)))
-           ;(print "area " area)
-           ;(print "code: " code-obj)  
-           ;(print (exe-exist (cadr code-obj)  "publish")) 
-           (if (or (null? code-obj)
-                   (not (exe-exist (cadr code-obj)  "publish")))
-              (begin
-              (print "Area " area " is not open for writing!!")
-              (exit 1)))
-              ;(print "hear") 
-              (sauthorize:do-as-calling-user
-             (lambda ()
-               ; (print  *exe-path* "/publish/" (cadr code-obj) action area cmd-args  )
-                (run-cmd (conc *exe-path* "/publish/" (cadr code-obj) ) (append (list action area ) cmd-args))))))
-      
-     ((retrieve)
-          (if (< (length args) 2)
-              (begin
-              (print "Missing argument to publish. \n publish <action> <area> [opts] ") 
-              (exit 1)))
-           (let* ((action (car args))
-                  (area (cadr args))
-                  (cmd-args (cddr args)) 
-                  (code-obj (get-obj-by-code area)))
-           (if (or (null? code-obj)
-                   (not (exe-exist (cadr code-obj)  "retrieve")))
-              (begin
-              (print "Area " area " is not open for reading!!")
-              (exit 1))) 
-               ;(print (conc *exe-path* "/retrieve/" (cadr code-obj) " " action " " area " " (string-join cmd-args)))
-              (sauthorize:do-as-calling-user
-             (lambda ()
-                (run-cmd (conc *exe-path* "/retrieve/" (cadr code-obj) ) (append (list action area ) cmd-args))))))
-
- 
- 
-      ((open)
-         (if (< (length args) 6)
-              (begin
-              (print "sauthorize open cmd takes 6 arguments!! \n Useage: sauthorize open <path> --group <grpname> --code <unique short identifier for an area> --retrieve|--publish") 
-              (exit 1)))
-         (let* ((remargs     (args:get-args args '("--group" "--code" "--additional-grps") '() args:arg-hash 0))
-              (path     (car args))
-	      (group         (or (args:get-arg "--group") ""))
-              (area         (or (args:get-arg "--code") ""))
-              (other-grps          (or (args:get-arg "--additional-grps") ""))     
-              (access-type (get-access-type remargs)))
-                
-              (cond
-                ((equal? path "")
-                  (print "path not found!! Try \"sauthorize help\" for useage ")
-                  (exit 1))   
-                ((equal? area "")
-                  (print "--code not found!! Try \"sauthorize help\" for useage ")
-                  (exit 1)) 
-                ((equal? access-type #f)
-                  (print "Access type not found!! Try \"sauthorize help\" for useage ")
-                  (exit 1)) 
-                ((and (not (equal? access-type "publish")) 
-                  (not (equal? access-type "retrieve")))
-                  (print "Access type can be eiter --retrieve or --publish !! Try \"sauthorize help\" for useage ")
-                  (exit 1)))
-                ; (print other-grps) 
-                (sauthorize:open username path group area access-type other-grps)))
-         ((update)
-            (if (< (length args) 2)
-              (begin
-              (print "sauthorize update cmd takes 2 arguments!! \n Useage: sauthorize update <area-code> --retrieve|--publish") 
-              (exit 1)))
-              (let* ((area (car args))
-                     (code-obj (get-obj-by-code area))
-                    (access-type (get-access-type (cdr args))))
-               (if  (and (not (equal? access-type "publish")) (not (equal? access-type "retrieve")))
-                  (begin 
-                  (print "Access type can be --retrieve|--publish ")
-                  (exit 1)))
-              (if (or (null? code-obj)
-                   (not (exe-exist (cadr code-obj)  access-type)))
-              (begin
-              (print "Area " area " is not open for reading!!")
-              (exit 1))) 
-              (sauthorize:update username (cadr code-obj) area access-type ))) 
-         ((area-admin)
-           (let* ((usr (car args))
-                  (usr-obj (get-user usr))
-                  (user-id (car (get-user username))))
-           
-                (if (is-admin  username)
-                (begin
-                  ; (print usr-obj) 
-                  (if (null? usr-obj)
-                    (begin
-                        (sauthorize:db-do   (lambda (db)
-              ;(print (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'read-admin' )"))
-             (sauthorize:db-qry db (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'read-admin' )")))))
-               (begin
-                ; (print (conc "update users set is_admin = 'no' where id = " (car usr-obj) ))
-                 (sauthorize:db-do   (lambda (db)
-                (sauthorize:db-qry db (conc "update users set is_admin = 'read-admin' where id = " (car usr-obj)))))))
-                (print "User " usr " is updated with area-admin access!"))
-                (print "Admin only function"))
-                (sauthorize:db-do   (lambda (db)
-             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('area-admin " usr " ', " user-id ",0, 'area-admin ')" )))))) 
-          ((mk-admin)
-           (let* ((usr (car args))
-                  (usr-obj (get-user usr))
-                  (user-id (car (get-user username))))
-                (if (not (sauthorize:valid-unix-user usr))
-               (begin  
-                (print "User " usr " is Invalid unix user!!")
-                 (exit 1)))
-
-                (if (member  username  *super-users*)
-                (begin
-                  (if (null? usr-obj)
-                    (begin
-                        (sauthorize:db-do   (lambda (db)
-                           (sauthorize:db-qry db (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'yes' )")))))
-               (begin
-                 (sauthorize:db-do   (lambda (db)
-                (sauthorize:db-qry db (conc "update users set is_admin = 'yes' where id = " (car usr-obj)))))))
-                (print "User " usr " is updated with admin access!"))
-                (print "Super-Admin only function"))
-                (sauthorize:db-do   (lambda (db)
-             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('mk-admin " usr " ', " user-id ",0, 'mk-admin ')" )))))) 
-
-         ((register-log)
-            (if (< (length args) 4)
-                (print "Invalid arguments"))
-             ;(print args)
-             (let* ((cmd-line (car args))
-                     (user-id (cadr args))
-                     (area-id (caddr args))
-                     (user-obj (get-user username))
-                      (cmd (cadddr args)))
-                
-               (if (and (not (null? user-obj)) (equal? user-id (number->string(car user-obj))))
-                (begin 
-                (sauthorize:db-do   (lambda (db)
-             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('" cmd-line"', " user-id "," area-id ", '" cmd "')" )))))
-                (print "You ar not authorised to run this cmd")
-
-)))     
-
-       
-      (else (print 0 "Unrecognised command " action))))
-  
-(define (main)
-  (let* ((args      (argv))
-	 (prog      (car args))
-	 (rema      (cdr args))
-         (username     (current-user-name)))
-    ;; preserve the exe data in the config file
-    (cond
-     ;; one-word commands
-     ((eq? (length rema) 1)
-      (case (string->symbol (car rema))
-	((help -h -help --h --help)
-	 (print sauthorize:help))
-	((list)
-            
-          (sauthorize:db-do  (lambda (db)
-				     (print "My Area accesses: ")
-				     (query (for-each-row
-					     (lambda (row)
-                                               (let* ((exp-date (car row)))
-                                                (if  (is-access-valid  exp-date)     
-					           (apply print (intersperse (cdr row) " | "))))))
-					    (sql db (conc "SELECT permissions.expiration, areas.basepath, areas.code, permissions.access_type  FROM users, areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and users.username = '" username "'"))))))
-         
-	((log)
-	 (sauthorize:db-do  (lambda (db)
-				     (print "Logs : ")
-				     (query (for-each-row
-					     (lambda (row)
-                                                   
-					       (apply print (intersperse row " | "))))
-					    (sql db "SELECT actions.cmd, users.username, actions.action_type, actions.datetime, areas.code  FROM actions, users, areas where actions.user_id = users.id and actions.area_id = areas.id ")))))
-	(else
-	 (print "ERROR: Unrecognised command. Try \"sauthorize help\""))))
-     ;; multi-word commands
-     ((null? rema)(print sauthorize:help))
-     ((>= (length rema) 2)
-      (apply sauthorize:process-action username (car rema)(cdr rema)))
-     (else (debug:print 0 "ERROR: Unrecognised command. Try \"sauthorize help\"")))))
-
-(main)
-
-
-      

Index: server.scm
==================================================================
--- server.scm
+++ server.scm
@@ -31,19 +31,26 @@
 ;; (declare (uses synchash))
 (declare (uses http-transport))
 ;;(declare (uses rpc-transport))
 (declare (uses launch))
 ;; (declare (uses daemon))
+
+(declare (uses commonmod))
+(import commonmod)
+
+(declare (uses dbmod))
+(import dbmod)
+
+(declare (uses configfmod))
+(import configfmod)
+
+(declare (uses servermod))
+(import servermod)
 
 (include "common_records.scm")
 (include "db_records.scm")
 
-(define (server:make-server-url hostport)
-  (if (not hostport)
-      #f
-      (conc "http://" (car hostport) ":" (cadr hostport))))
-
 (define  *server-loop-heart-beat* (current-seconds))
 
 ;;======================================================================
 ;; P K T S   S T U F F 
 ;;======================================================================
@@ -72,49 +79,10 @@
     ((http)(http-transport:launch))
     ;;((nmsg)(nmsg-transport:launch run-id))
     ;;((rpc)  (rpc-transport:launch run-id))
     (else (debug:print-error 0 *default-log-port* "unknown server type " transport-type))))
 
-;;======================================================================
-;; S E R V E R   U T I L I T I E S 
-;;======================================================================
-
-;; Get the transport
-(define (server:get-transport)
-  (if *transport-type*
-      *transport-type*
-      (let ((ttype (string->symbol
-		    (or (args:get-arg "-transport")
-			(configf:lookup *configdat* "server" "transport")
-			"rpc"))))
-	(set! *transport-type* ttype)
-	ttype)))
-	    
-;; Generate a unique signature for this server
-(define (server:mk-signature)
-  (message-digest-string (md5-primitive) 
-			 (with-output-to-string
-			   (lambda ()
-			     (write (list (current-directory)
-                                          (current-process-id)
-					  (argv)))))))
-
-;; When using zmq this would send the message back (two step process)
-;; with spiffy or rpc this simply returns the return data to be returned
-;; 
-(define (server:reply return-addr query-sig success/fail result)
-  (debug:print-info 11 *default-log-port* "server:reply return-addr=" return-addr ", result=" result)
-  ;; (send-message pubsock target send-more: #t)
-  ;; (send-message pubsock 
-  (case (server:get-transport)
-    ((rpc)  (db:obj->string (vector success/fail query-sig result)))
-    ((http) (db:obj->string (vector success/fail query-sig result)))
-    ((fs)   result)
-    (else 
-     (debug:print-error 0 *default-log-port* "unrecognised transport type: " *transport-type*)
-     result)))
-
 ;; Given a run id start a server process    ### NOTE ### > file 2>&1 
 ;; if the run-id is zero and the target-host is set 
 ;; try running on that host
 ;;   incidental: rotate logs in logs/ dir.
 ;;
@@ -163,240 +131,59 @@
     (unsetenv "TARGETHOST_LOGF")
     (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST"))
     (thread-join! log-rotate)
     (pop-directory)))
 
-;; given a path to a server log return: host port startseconds
-;; any changes to number of elements returned by this fuction will dirctly affect server:record->url,server:record->id,server:kill,server:get-num-alive which uses match let 
-
-(define (server:logf-get-start-info logf)
-  (let ((server-rx (regexp "^SERVER STARTED: (\\S+):(\\d+) AT ([\\d\\.]+) server-id: (\\S+)")) ;; SERVER STARTED: host:port AT timesecs server id
-        (dbprep-rx (regexp "^SERVER: dbprep"))
-        (dbprep-found 0)) 
-    (handle-exceptions
-	exn
-      (begin
-	(debug:print-info 0 *default-log-port* "Unable to get server info from " logf ", exn=" exn)
-	(list #f #f #f #f)) ;; no idea what went wrong, call it a bad server
-      (with-input-from-file
-	  logf
-	(lambda ()
-	  (let loop ((inl  (read-line))
-		     (lnum 0))
-	    (if (not (eof-object? inl))
-		(let ((mlst (string-match server-rx inl))
-                      (dbprep (string-match dbprep-rx inl))
-                      )
-                  (if dbprep
-                    (set! dbprep-found 1)
-                  )
-		  (if (not mlst)
-		      (if (< lnum 500) ;; give up if more than 500 lines of server log read
-			  (loop (read-line)(+ lnum 1))
-			  (begin 
-                           (debug:print-info 0 *default-log-port* "Unable to get server info from first 500 lines of " logf )
-                           (list #f #f #f #f)))
-		      (let ((dat  (cdr mlst)))
-			(list (car dat) ;; host
-			      (string->number (cadr dat)) ;; port
-			      (string->number (caddr dat))
-                              (cadr (cddr dat))))))
-                (begin 
-                   (if dbprep-found
-                      (begin
-                         (debug:print-info 0 *default-log-port* "Server is in dbprep at " (current-seconds))
-                         (thread-sleep! 25)
-                      )
-                      (debug:print-info 0 *default-log-port* "Unable to get server info from " logf " at " (current-seconds))
-                   )
-		    (list #f #f #f #f)))))))))
-
-;; get a list of servers with all relevant data
-;; ( mod-time host port start-time pid )
-;;
-(define (server:get-list areapath #!key (limit #f))
-  (let ((fname-rx    (regexp "^(|.*/)server-(\\d+)-(\\S+).log$"))
-	(day-seconds (* 24 60 60)))
-    ;; if the directory exists continue to get the list
-    ;; otherwise attempt to create the logs dir and then
-    ;; continue
-    (if (if (directory-exists? (conc areapath "/logs"))
-	    '()
-	    (if (file-write-access? areapath)
-		(begin
-		  (condition-case
-		   (create-directory (conc areapath "/logs") #t)
-		   (exn (i/o file)(debug:print 0 *default-log-port* "ERROR: Cannot create directory at " (conc areapath "/logs")))
-		   (exn ()(debug:print 0 *default-log-port* "ERROR: Unknown error attemtping to get server list. exn=" exn)))
-		  (directory-exists? (conc areapath "/logs")))
-		'()))
-
-        ;; Get the list of server logs that do not contain "exiting". Ignore logs for servers that have exited.
-	(let* ((server-logs-cmd  (conc "grep -iL exiting " areapath "/logs/server-*-*.log"))
-               (server-logs   (string-split (string-chomp (call-with-input-pipe server-logs-cmd read-all))))
-	       (num-serv-logs (length server-logs)))
-	  (if (or (null? server-logs) (= num-serv-logs 0))
-              (let ()
-                 (debug:print 1  *default-log-port* "There are no servers running")
-	         '()
-              )
-	      (let loop ((hed  (string-chomp (car server-logs)))
-			 (tal  (cdr server-logs))
-			 (res '()))
-		(let* ((mod-time  (handle-exceptions
-				   exn
-				   (begin
-				     (debug:print 0 *default-log-port* "failed to get modification time on " hed ", exn=" exn)
-				     (current-seconds)) ;; 0
-				   (file-modification-time hed))) ;; default to *very* old so log gets ignored if deleted
-		       (down-time (- (current-seconds) mod-time))
-		       (serv-dat  (if (or (< num-serv-logs 10)
-				  	  (< down-time 900)) ;; day-seconds))
-				      (server:logf-get-start-info hed)
-				      '())) ;; don't waste time processing server files not touched in the 15 minutes if there are more than ten servers to look at
-		       (serv-rec (cons mod-time serv-dat))
-		       (fmatch   (string-match fname-rx hed))
-		       (pid      (if fmatch (string->number (list-ref fmatch 2)) #f))
-		       (new-res  (if (null? serv-dat)
-				     res
-				     (cons (append serv-rec (list pid)) res)))) ;; any changes to number of elements in new-res will dirctly affect server:record->url,server:record->id,server:kill,server:get-num-alive which uses match let 
-		  (if (null? tal)
-		      (if (and limit
-			       (> (length new-res) limit))
-			  new-res ;; (take new-res limit)  <= need intelligent sorting before this will work
-			  new-res)
-		      (loop (string-chomp (car tal)) (cdr tal) new-res)))))))))
-
-(define (server:get-num-alive srvlst)
-  (let ((num-alive 0))
-    (for-each
-     (lambda (server)
-        (handle-exceptions
-          exn
-         (begin 
-          (debug:print-info 0 *default-log-port*  "Unable to get server start-time and/or mod-time from " server ", exn=" exn))
-       (match-let (((mod-time host port start-time server-id pid)
-		    server))
-	 (let* ((uptime  (- (current-seconds) mod-time))
-		(runtime (if start-time
-			     (- mod-time start-time)
-			     0)))
-	   (if (< uptime 5)(set! num-alive (+ num-alive 1)))))))
-     srvlst)
-    num-alive))
-
-;; given a list of servers get a list of valid servers, i.e. at least
-;; 10 seconds old, has started and is less than 1 hour old and is
-;; active (i.e. mod-time < 10 seconds
-;;
-;; mod-time host port start-time pid
-;;
-;; sort by start-time descending. I.e. get the oldest first. Young servers will thus drop off
-;; and servers should stick around for about two hours or so.
-;;
-(define (server:get-best srvlst)
-  (let* ((nums (server:get-num-servers))
-	 (now  (current-seconds))
-	 (slst (sort
-		(filter (lambda (rec)
-			  (if (and (list? rec)
-				   (> (length rec) 2))
-			      (let ((start-time (list-ref rec 3))
-				    (mod-time   (list-ref rec 0)))
-				;; (print "start-time: " start-time " mod-time: " mod-time)
-				(and start-time mod-time
-				     (> (- now start-time) 0)    ;; been running at least 0 seconds
-				     (< (- now mod-time)   16)   ;; still alive - file touched in last 16 seconds
-				     (or (not (configf:lookup *configdat* "server" "runtime")) ;; skip if not set
-					 (< (- now start-time)       
-					    (+ (- (string->number (configf:lookup *configdat* "server" "runtime"))
-					       180)
-					    (random 360)))) ;; under one hour running time +/- 180
-				     ))
-			      #f))
-			srvlst)
-		(lambda (a b)
-		  (< (list-ref a 3)
-		     (list-ref b 3))))))
-    (if (> (length slst) nums)
-	(take slst nums)
-	slst)))
-
-(define (server:get-first-best areapath)
-  (let ((srvrs (server:get-best (server:get-list areapath))))
-    (if (and srvrs
-	     (not (null? srvrs)))
-	(car srvrs)
-	#f)))
-
-(define (server:get-rand-best areapath)
-  (let ((srvrs (server:get-best (server:get-list areapath))))
-    (if (and (list? srvrs)
-	     (not (null? srvrs)))
-	(let* ((len (length srvrs))
-	       (idx (random len)))
-	  (list-ref srvrs idx))
-	#f)))
-
-(define (server:record->id servr)
-  (handle-exceptions
-   exn
-   (begin 
-     (debug:print-info 0 *default-log-port*  "Unable to get server id from " servr ", exn=" exn)     
-   #f)
-  (match-let (((mod-time host port start-time server-id pid)
-	       servr))
-    (if server-id
-	server-id
-	#f))))
-
-(define (server:record->url servr)
-  (handle-exceptions
-   exn
-   (begin 
-     (debug:print-info 0 *default-log-port*  "Unable to get server url from " servr ", exn=" exn)     
-   #f)
-  (match-let (((mod-time host port start-time server-id pid)
-	       servr))
-    (if (and host port)
-	(conc host ":" port)
-	#f))))
-
-(define (server:get-client-signature) ;; BB> why is this proc named "get-"?  it returns nothing -- set! has not return value.
-  (if *my-client-signature* *my-client-signature*
-      (let ((sig (server:mk-signature)))
-        (set! *my-client-signature* sig)
-        *my-client-signature*)))
-
-;; wait for server=start-last to be three seconds old
-;;
-(define (server:wait-for-server-start-last-flag areapath)
-  (let* ((start-flag (conc areapath "/logs/server-start-last"))
-	 ;;; THIS INTERACTS WITH [server] timeout. Suggest using 0.1 or above for timeout (6 seconds)
-	 (reftime    (configf:lookup-number *configdat* "server" "idletime" default: 4))
-	 (server-key (conc (get-host-name) "-" (current-process-id))))
-    (if (file-exists? start-flag)
-	(let* ((fmodtime (file-modification-time start-flag))
-	       (delta    (- (current-seconds) fmodtime))
-	       (all-go   (> delta reftime)))
-	  (if (and all-go
-		   (begin
-                     (debug:print-info 0 *default-log-port* "Writing " start-flag)
-		     (with-output-to-file start-flag
-		       (lambda ()
-			 (print server-key)))
-		     (thread-sleep! 0.25)
-		     (let ((res (with-input-from-file start-flag
-				  (lambda ()
-				    (read-line)))))
-		       (equal? server-key res))))
-	      #t ;; (system (conc "touch " start-flag)) ;; lazy but safe
-	      (begin
-		(debug:print-info 0 *default-log-port* "Gating server start, last start: "
-				  fmodtime ", delta: " delta ", reftime: " reftime ", all-go=" all-go)
-		(thread-sleep! reftime)
-		(server:wait-for-server-start-last-flag areapath)))))))
+
+
+
+
+
+
+
+
+
+
+(define (server:ping host-port-in server-id #!key (do-exit #f))
+  (let ((host:port (if (not host-port-in) ;; use read-dotserver to find
+		       #f ;; (server:check-if-running *toppath*)
+		;; (if (number? host-port-in) ;; we were handed a server-id
+		;; 	   (let ((srec (tasks:get-server-by-id (db:delay-if-busy (tasks:open-db)) host-port-in)))
+		;; 	     ;; (print "srec: " srec " host-port-in: " host-port-in)
+		;; 	     (if srec
+		;; 		 (conc (vector-ref srec 3) ":" (vector-ref srec 4))
+		;; 		 (conc "no such server-id " host-port-in)))
+		       host-port-in))) ;; )
+    (let* ((host-port (if host:port
+			  (let ((slst (string-split   host:port ":")))
+			    (if (eq? (length slst) 2)
+				(list (car slst)(string->number (cadr slst)))
+				#f))
+			  #f)))
+;;	   (toppath       (launch:setup)))
+      ;; (print "host-port=" host-port)
+      (if (not host-port)
+	  (begin
+	    (if host-port-in
+		(debug:print 0 *default-log-port*  "ERROR: bad host:port"))
+	    (if do-exit (exit 1))
+	    #f)
+	  (let* ((iface      (car host-port))
+		 (port       (cadr host-port))
+		 (server-dat (http-transport:client-connect iface port server-id))
+		 (login-res  (rmt:login-no-auto-client-setup server-dat)))
+	    (if (and (list? login-res)
+		     (car login-res))
+		(begin
+		  ;; (print "LOGIN_OK")
+		  (if do-exit (exit 0))
+		  #t)
+		(begin
+		  ;; (print "LOGIN_FAILED")
+		  (if do-exit (exit 1))
+		  #f)))))))
+
 
 ;; kind start up of servers, wait 40 seconds before allowing another server for a given
 ;; run-id to be launched
 ;;
 (define (server:kind-run areapath)
@@ -439,16 +226,10 @@
 		(server:kind-run areapath))
 	    (thread-sleep! 5)
 	    (loop (server:check-if-running areapath)
 		  (+ try-num 1)))))))
 
-(define server:try-running server:run) ;; there is no more per-run servers ;; REMOVE ME. BUG.
-
-(define (server:get-num-servers #!key (numservers 2))
-  (let ((ns (string->number
-	     (or (configf:lookup *configdat* "server" "numservers") "notanumber"))))
-    (or ns numservers)))
 
 ;; no longer care if multiple servers are started by accident. older servers will drop off in time.
 ;;
 (define (server:check-if-running areapath) ;;  #!key (numservers "2"))
   (let* ((ns            (server:get-num-servers))
@@ -479,226 +260,26 @@
                        )))
     (if res
         server-url
 	#f)))
 
-(define (server:kill servr)
-  (handle-exceptions
-    exn
-    (begin 
-      (debug:print-info 0 *default-log-port*  "Unable to get host and/or port from " servr ", exn=" exn)     
-    #f)
-  (match-let (((mod-time hostname port start-time server-id pid)
-	       servr))
-    (tasks:kill-server hostname pid))))
-
-;; called in megatest.scm, host-port is string hostname:port
-;;
-;; NOTE: This is NOT called directly from clients as not all transports support a client running
-;;       in the same process as the server.
-;;
-(define (server:ping host-port-in server-id #!key (do-exit #f))
-  (let ((host:port (if (not host-port-in) ;; use read-dotserver to find
-		       #f ;; (server:check-if-running *toppath*)
-		;; (if (number? host-port-in) ;; we were handed a server-id
-		;; 	   (let ((srec (tasks:get-server-by-id (db:delay-if-busy (tasks:open-db)) host-port-in)))
-		;; 	     ;; (print "srec: " srec " host-port-in: " host-port-in)
-		;; 	     (if srec
-		;; 		 (conc (vector-ref srec 3) ":" (vector-ref srec 4))
-		;; 		 (conc "no such server-id " host-port-in)))
-		       host-port-in))) ;; )
-    (let* ((host-port (if host:port
-			  (let ((slst (string-split   host:port ":")))
-			    (if (eq? (length slst) 2)
-				(list (car slst)(string->number (cadr slst)))
-				#f))
-			  #f)))
-;;	   (toppath       (launch:setup)))
-      ;; (print "host-port=" host-port)
-      (if (not host-port)
-	  (begin
-	    (if host-port-in
-		(debug:print 0 *default-log-port*  "ERROR: bad host:port"))
-	    (if do-exit (exit 1))
-	    #f)
-	  (let* ((iface      (car host-port))
-		 (port       (cadr host-port))
-		 (server-dat (http-transport:client-connect iface port server-id))
-		 (login-res  (rmt:login-no-auto-client-setup server-dat)))
-	    (if (and (list? login-res)
-		     (car login-res))
-		(begin
-		  ;; (print "LOGIN_OK")
-		  (if do-exit (exit 0))
-		  #t)
-		(begin
-		  ;; (print "LOGIN_FAILED")
-		  (if do-exit (exit 1))
-		  #f)))))))
-
-;; run ping in separate process, safest way in some cases
-;;
-(define (server:ping-server ifaceport)
-  (with-input-from-pipe 
-   (conc (common:get-megatest-exe) " -ping " ifaceport)
-   (lambda ()
-     (let loop ((inl (read-line))
-		(res "NOREPLY"))
-       (if (eof-object? inl)
-	   (case (string->symbol res)
-	     ((NOREPLY)  #f)
-	     ((LOGIN_OK) #t)
-	     (else       #f))
-	   (loop (read-line) inl))))))
-
-;; NOT USED (well, ok, reference in rpc-transport but otherwise not used).
-;;
-(define (server:login toppath)
-  (lambda (toppath)
-    (set! *db-last-access* (current-seconds)) ;; might not be needed.
-    (if (equal? *toppath* toppath)
-	#t
-	#f)))
-
-;; timeout is hms string: 1h 5m 3s, default is 1 minute
-;;
-(define (server:expiration-timeout)
-  (let ((tmo (configf:lookup *configdat* "server" "timeout")))
-    (if (and (string? tmo)
-	     (common:hms-string->seconds tmo)) ;; BUG: hms-string->seconds is broken, if given "10" returns 0. Also, it doesn't belong in this logic unless the string->number is changed below
-        (* 3600 (string->number tmo))
-	60)))
-
-(define (server:get-best-guess-address hostname)
-  (let ((res #f))
-    (for-each 
-     (lambda (adr)
-       (if (not (eq? (u8vector-ref adr 0) 127))
-	   (set! res adr)))
-     ;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME
-     (vector->list (hostinfo-addresses (hostname->hostinfo hostname))))
-    (string-intersperse 
-     (map number->string
-	  (u8vector->list
-	   (if res res (hostname->ip hostname)))) ".")))
-
-;; (define server:sync-lock-token "SERVER_SYNC_LOCK")
-;; (define (server:release-sync-lock)
-;;   (db:no-sync-del! *no-sync-db* server:sync-lock-token))
-;; (define (server:have-sync-lock?)
-;;   (let* ((have-lock-pair (db:no-sync-get-lock *no-sync-db* server:sync-lock-token))
-;;          (have-lock?     (car have-lock-pair))
-;;          (lock-time      (cdr have-lock-pair))
-;;          (lock-age       (- (current-seconds) lock-time)))
-;;     (cond
-;;      (have-lock? #t)
-;;      ((>lock-age
-;;        (* 3 (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: 180)))
-;;       (server:release-sync-lock)
-;;       (server:have-sync-lock?))
-;;      (else #f))))
-
-;; moving this here as it needs access to db and cannot be in common.
-;;
-
-(define (server:get-bruteforce-syncer dbstruct #!key (fork-to-background #f) (persist-until-sync #f))
-  (let* ((sqlite-exe   (or (get-environment-variable "MT_SQLITE3_EXE"))) ;; defined in cfg.sh
-         (sync-log     (or (args:get-arg "-sync-log") (conc *toppath* "/logs/sync-" (current-process-id) "-" (get-host-name) ".log")))
-	 (tmp-area     (common:get-db-tmp-area))
-	 (tmp-db       (conc tmp-area "/megatest.db"))
-	 (staging-file (conc *toppath* "/.megatest.db"))
-	 (mtdbfile     (conc *toppath* "/megatest.db"))
-	 (lockfile     (common:get-sync-lock-filepath))
-         (sync-cmd-core     (conc sqlite-exe" " tmp-db " .dump | "sqlite-exe" " staging-file "&>"sync-log))
-         (sync-cmd     (if fork-to-background 
-                           (conc "/usr/bin/env NBFAKE_LOG="*toppath*"/logs/last-server-sync-"(current-process-id)".log nbfake \""sync-cmd-core" && /bin/mv -f " staging-file " " mtdbfile" \"")
-                           sync-cmd-core))
-         (default-min-intersync-delay 2)
-	 (min-intersync-delay (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: default-min-intersync-delay))
-         (default-duty-cycle 0.1)
-         (duty-cycle   (configf:lookup-number *configdat* "server" "sync-duty-cycle" default: default-duty-cycle))
-         (last-sync-seconds 10) ;; we will adjust this to a measurement and delay last-sync-seconds * (1 - duty-cycle)
-         (calculate-off-time (lambda (work-duration duty-cycle)
-                                  (* (/ (- 1 duty-cycle) duty-cycle) last-sync-seconds)))
-         (off-time min-intersync-delay) ;; adjusted in closure below.
-         (do-a-sync
-          (lambda ()
-            (BB> "Start do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync)
-            (let* ((finalres
-                    (let retry-loop ((num-tries 0))
-                         (if (common:simple-file-lock lockfile)
-	                     (begin
-                               (cond
-                                ((not (or fork-to-background persist-until-sync))
-                                 (debug:print 0 *default-log-port* "INFO: syncer thread sleeping for max of (server.minimum-intersync-delay="min-intersync-delay
-                                              " , off-time="off-time" seconds ]")
-                                 (thread-sleep! (max off-time min-intersync-delay)))
-                                (else
-                                 (debug:print 0 *default-log-port* "INFO: syncer thread NOT sleeping ; maybe time-to-exit...")))
-
-                               (if (not (configf:lookup *configdat* "server" "disable-db-snapshot"))
-                                   (common:snapshot-file mtdbfile subdir: ".db-snapshot"))
-		               (delete-file* staging-file)
-		               (let* ((start-time (current-milliseconds))
-                                      (res (system sync-cmd))
-                                      (dbbackupfile (conc mtdbfile ".backup"))
-                                      (res2 
-                                       (cond
-                                        ((eq? 0 res )
-                                         (handle-exceptions
-                                            exn
-                                            #f
-                                         (if (file-exists? dbbackupfile)
-		                           (delete-file* dbbackupfile)
-                                         )
-                                         (if (eq? 0 (file-size sync-log))
-                                             (delete-file* sync-log))
-		                         (system (conc "/bin/mv " staging-file " " mtdbfile))
-                                         
-                                         (set! last-sync-seconds (/ (- (current-milliseconds) start-time) 1000))
-                                         (set! off-time (calculate-off-time
-                                                         last-sync-seconds
-                                                         (cond
-                                                          ((and (number? duty-cycle) (> duty-cycle 0) (< duty-cycle 1))
-                                                           duty-cycle)
-                                                          (else
-                                                           (debug:print 0 *default-log-port* "WARNING: ["(common:human-time)"] server.sync-duty-cycle is invalid.  Should be a number between 0 and 1, but "duty-cycle" was specified.  Using default value: "default-duty-cycle)
-                                                           default-duty-cycle))))
-                                         
-                                         (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" SYNC took "last-sync-seconds" sec")
-                                         (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" SYNC took "last-sync-seconds" sec ; with duty-cycle of "duty-cycle" off time is now "off-time)
-                                         'sync-completed))
-                                        (else
-                                         (system (conc "/bin/cp "sync-log" "sync-log".fail"))
-                                         (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Sync failed. See log at "sync-log".fail")
-                                         (if (file-exists? (conc mtdbfile ".backup"))
-                                             (system (conc "/bin/cp "mtdbfile ".backup " mtdbfile)))
-                                         #f))))
-                                 (common:simple-file-release-lock lockfile)
-                                 (BB> "released lockfile: " lockfile)
-                                 (when (common:file-exists? lockfile)
-                                   (BB> "DID NOT ACTUALLY RELEASE LOCKFILE"))
-                                 res2) ;; end let
-                               );; end begin
-                             ;; else
-                             (cond
-                              (persist-until-sync
-                               (thread-sleep! 1)
-                               (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" other SYNC in progress; we're in a fork-to-background so we need to succeed.  Let's wait a jiffy and and try again. num-tries="num-tries" (waiting for lockfile="lockfile" to disappear)")
-                               (retry-loop (add1 num-tries)))
-                              (else
-                               (thread-sleep! (max off-time (+ last-sync-seconds min-intersync-delay)))
-                               (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" other SYNC in progress; not syncing.")
-                               'parallel-sync-in-progress))
-                             ) ;; end if got lockfile
-                         )
-                    ))
-              (BB> "End do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync" and result="finalres)
-              finalres)
-            ) ;; end lambda
-          ))
-    do-a-sync))
+
+(define server:try-running server:run) ;; there is no more per-run servers ;; REMOVE ME. BUG.
+
+
+
+
+
+
+
+
+
+
+
+
+
+
 
 (define (server:writable-watchdog-bruteforce dbstruct)
   (thread-sleep! 1) ;; delay for startup
   (let* ((do-a-sync  (server:get-bruteforce-syncer dbstruct))
          (final-sync (server:get-bruteforce-syncer dbstruct fork-to-background: #t persist-until-sync: #t)))

ADDED   servermod.scm
Index: servermod.scm
==================================================================
--- /dev/null
+++ servermod.scm
@@ -0,0 +1,492 @@
+;;======================================================================
+;; Copyright 2017, Matthew Welland.
+;; 
+;; This file is part of Megatest.
+;; 
+;;     Megatest is free software: you can redistribute it and/or modify
+;;     it under the terms of the GNU General Public License as published by
+;;     the Free Software Foundation, either version 3 of the License, or
+;;     (at your option) any later version.
+;; 
+;;     Megatest is distributed in the hope that it will be useful,
+;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;     GNU General Public License for more details.
+;; 
+;;     You should have received a copy of the GNU General Public License
+;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
+
+;;======================================================================
+
+(declare (unit servermod))
+(declare (uses commonmod))
+(declare (uses configfmod))
+(declare (uses dbmod))
+
+(module servermod
+	*
+	
+(import scheme chicken data-structures extras ports files)
+(import (prefix sqlite3 sqlite3:) posix
+	typed-records srfi-18 srfi-1 srfi-69 srfi-4
+	message-digest hostinfo
+	regex matchable
+	md5)
+
+(import commonmod)
+(import configfmod)
+(import dbmod)
+
+(define (server:make-server-url hostport)
+  (if (not hostport)
+      #f
+      (conc "http://" (car hostport) ":" (cadr hostport))))
+
+;;======================================================================
+;; S E R V E R   U T I L I T I E S 
+;;======================================================================
+
+;; Get the transport
+#;(define (server:get-transport)
+  (if *transport-type*
+      *transport-type*
+      (let ((ttype (string->symbol
+		    (or (args:get-arg "-transport")
+			(configf:lookup *configdat* "server" "transport")
+			"rpc"))))
+	(set! *transport-type* ttype)
+	ttype)))
+	    
+;; Generate a unique signature for this server
+(define (server:mk-signature)
+  (message-digest-string (md5-primitive) 
+			 (with-output-to-string
+			   (lambda ()
+			     (write (list (current-directory)
+                                          (current-process-id)
+					  (argv)))))))
+
+;; When using zmq this would send the message back (two step process)
+;; with spiffy or rpc this simply returns the return data to be returned
+;; 
+(define (server:reply return-addr query-sig success/fail result)
+  (debug:print-info 11 *default-log-port* "server:reply return-addr=" return-addr ", result=" result)
+  ;; (send-message pubsock target send-more: #t)
+  ;; (send-message pubsock
+  (db:obj->string (vector success/fail query-sig result)))
+;;  (case (server:get-transport)
+;;    ((rpc)  (db:obj->string (vector success/fail query-sig result)))
+;;    ((http) (db:obj->string (vector success/fail query-sig result)))
+;;    ((fs)   result)
+;;    (else 
+;;     (debug:print-error 0 *default-log-port* "unrecognised transport type: " *transport-type*)
+;;     result)))
+
+;; given a path to a server log return: host port startseconds
+;; any changes to number of elements returned by this fuction will dirctly affect server:record->url,server:record->id,server:kill,server:get-num-alive which uses match let 
+;;
+(define (server:logf-get-start-info logf)
+  (let ((rx (regexp "^SERVER STARTED: (\\S+):(\\d+) AT ([\\d\\.]+) server-id: (\\S+)"))) ;; SERVER STARTED: host:port AT timesecs server id
+    ;;(handle-exceptions
+    ;; exn
+    ;; (begin
+    ;;   (debug:print-info 0 *default-log-port* "Unable to get server info from " logf ", exn=" exn)
+    ;;   (list #f #f #f #f)) ;; no idea what went wrong, call it a bad server
+    (if (and (file-exists? logf)
+	     (file-read-access? logf))
+	(with-input-from-file
+	    logf
+	  (lambda ()
+	    (let loop ((inl  (read-line))
+		       (lnum 0))
+	      (if (not (eof-object? inl))
+		  (let ((mlst (string-match rx inl)))
+		    (if (not mlst)
+			(if (< lnum 500) ;; give up if more than 500 lines of server log read
+			    (loop (read-line)(+ lnum 1))
+			    (begin 
+			      (debug:print-info 0 *default-log-port* "Unable to get server info from first 500 lines of " logf )
+			      (list #f #f #f #f)))
+			(let ((dat  (cdr mlst)))
+			  (list (car dat) ;; host
+				(string->number (cadr dat)) ;; port
+				(string->number (caddr dat))
+				(cadr (cddr dat))))))
+		  (begin 
+		    (debug:print-info 0 *default-log-port* "Unable to get server info from " logf " at " (current-seconds))
+		    (list #f #f #f #f))))))
+	(begin
+	  (debug:print-info 0 *default-log-port* "Unable to get server info from " logf ", file not found or not readable.")
+	  (list #f #f #f #f)))))
+
+;; get a list of servers with all relevant data
+;; ( mod-time host port start-time pid )
+;;
+(define (server:get-list areapath #!key (limit #f))
+  (let ((fname-rx    (regexp "^(|.*/)server-(\\d+)-(\\S+).log$"))
+	(day-seconds (* 24 60 60)))
+    ;; if the directory exists continue to get the list
+    ;; otherwise attempt to create the logs dir and then
+    ;; continue
+    (if (if (directory-exists? (conc areapath "/logs"))
+	    '()
+	    (if (file-write-access? areapath)
+		(begin
+		  (condition-case
+		   (create-directory (conc areapath "/logs") #t)
+		   (exn (i/o file)(debug:print 0 *default-log-port* "ERROR: Cannot create directory at " (conc areapath "/logs")))
+		   (exn ()(debug:print 0 *default-log-port* "ERROR: Unknown error attemtping to get server list. exn=" exn)))
+		  (directory-exists? (conc areapath "/logs")))
+		'()))
+	(let* ((server-logs   (glob (conc areapath "/logs/server-[0-9]*.log")))
+	       (num-serv-logs (length server-logs)))
+	  (if (null? server-logs)
+	      '()
+	      (let loop ((hed  (car server-logs))
+			 (tal  (cdr server-logs))
+			 (res '()))
+		(let* ((mod-time  (handle-exceptions
+				   exn
+				   (begin
+				     (debug:print 0 *default-log-port* "failed to get modification time on " hed ", exn=" exn)
+				     (current-seconds)) ;; 0
+				   (file-modification-time hed))) ;; default to *very* old so log gets ignored if deleted
+		       (down-time (- (current-seconds) mod-time))
+		       (serv-dat  (if (or (< num-serv-logs 10)
+				  	  (< down-time 900)) ;; day-seconds))
+				      (server:logf-get-start-info hed)
+				      '())) ;; don't waste time processing server files not touched in the 15 minutes if there are more than ten servers to look at
+		       (serv-rec (cons mod-time serv-dat))
+		       (fmatch   (string-match fname-rx hed))
+		       (pid      (if fmatch (string->number (list-ref fmatch 2)) #f))
+		       (new-res  (if (null? serv-dat)
+				     res
+				     (cons (append serv-rec (list pid)) res)))) ;; any changes to number of elements in new-res will dirctly affect server:record->url,server:record->id,server:kill,server:get-num-alive which uses match let 
+		  (if (null? tal)
+		      (if (and limit
+			       (> (length new-res) limit))
+			  new-res ;; (take new-res limit)  <= need intelligent sorting before this will work
+			  new-res)
+		      (loop (car tal)(cdr tal) new-res)))))))))
+
+(define (server:get-num-alive srvlst)
+  (let ((num-alive 0))
+    (for-each
+     (lambda (server)
+        (handle-exceptions
+          exn
+         (begin 
+          (debug:print-info 0 *default-log-port*  "Unable to get server start-time and/or mod-time from " server ", exn=" exn))
+       (match-let (((mod-time host port start-time server-id pid)
+		    server))
+	 (let* ((uptime  (- (current-seconds) mod-time))
+		(runtime (if start-time
+			     (- mod-time start-time)
+			     0)))
+	   (if (< uptime 5)(set! num-alive (+ num-alive 1)))))))
+     srvlst)
+    num-alive))
+
+;; given a list of servers get a list of valid servers, i.e. at least
+;; 10 seconds old, has started and is less than 1 hour old and is
+;; active (i.e. mod-time < 10 seconds
+;;
+;; mod-time host port start-time pid
+;;
+;; sort by start-time descending. I.e. get the oldest first. Young servers will thus drop off
+;; and servers should stick around for about two hours or so.
+;;
+(define (server:get-best srvlst)
+  (let* ((nums (server:get-num-servers))
+	 (now  (current-seconds))
+	 (slst (sort
+		(filter (lambda (rec)
+			  (if (and (list? rec)
+				   (> (length rec) 2))
+			      (let ((start-time (list-ref rec 3))
+				    (mod-time   (list-ref rec 0)))
+				;; (print "start-time: " start-time " mod-time: " mod-time)
+				(and start-time mod-time
+				     (> (- now start-time) 0)    ;; been running at least 0 seconds
+				     (< (- now mod-time)   16)   ;; still alive - file touched in last 16 seconds
+				     (or (not (configf:lookup *configdat* "server" "runtime")) ;; skip if not set
+					 (< (- now start-time)       
+					    (+ (- (string->number (configf:lookup *configdat* "server" "runtime"))
+					       180)
+					    (random 360)))) ;; under one hour running time +/- 180
+				     ))
+			      #f))
+			srvlst)
+		(lambda (a b)
+		  (< (list-ref a 3)
+		     (list-ref b 3))))))
+    (if (> (length slst) nums)
+	(take slst nums)
+	slst)))
+
+(define (server:get-first-best areapath)
+  (let ((srvrs (server:get-best (server:get-list areapath))))
+    (if (and srvrs
+	     (not (null? srvrs)))
+	(car srvrs)
+	#f)))
+
+(define (server:get-rand-best areapath)
+  (let ((srvrs (server:get-best (server:get-list areapath))))
+    (if (and (list? srvrs)
+	     (not (null? srvrs)))
+	(let* ((len (length srvrs))
+	       (idx (random len)))
+	  (list-ref srvrs idx))
+	#f)))
+
+(define (server:record->id servr)
+  (handle-exceptions
+   exn
+   (begin 
+     (debug:print-info 0 *default-log-port*  "Unable to get server id from " servr ", exn=" exn)     
+   #f)
+  (match-let (((mod-time host port start-time server-id pid)
+	       servr))
+    (if server-id
+	server-id
+	#f))))
+
+(define (server:record->url servr)
+  (handle-exceptions
+   exn
+   (begin 
+     (debug:print-info 0 *default-log-port*  "Unable to get server url from " servr ", exn=" exn)     
+   #f)
+  (match-let (((mod-time host port start-time server-id pid)
+	       servr))
+    (if (and host port)
+	(conc host ":" port)
+	#f))))
+
+(define (server:get-client-signature) ;; BB> why is this proc named "get-"?  it returns nothing -- set! has not return value.
+  (if *my-client-signature* *my-client-signature*
+      (let ((sig (server:mk-signature)))
+        (set! *my-client-signature* sig)
+        *my-client-signature*)))
+
+;; wait for server=start-last to be three seconds old
+;;
+(define (server:wait-for-server-start-last-flag areapath)
+  (let* ((start-flag (conc areapath "/logs/server-start-last"))
+	 ;;; THIS INTERACTS WITH [server] timeout. Suggest using 0.1 or above for timeout (6 seconds)
+	 (reftime    (configf:lookup-number *configdat* "server" "idletime" default: 4))
+	 (server-key (conc (get-host-name) "-" (current-process-id))))
+    (if (file-exists? start-flag)
+	(let* ((fmodtime (file-modification-time start-flag))
+	       (delta    (- (current-seconds) fmodtime))
+	       (all-go   (> delta reftime)))
+	  (if (and all-go
+		   (begin
+		     (with-output-to-file start-flag
+		       (lambda ()
+			 (print server-key)))
+		     (thread-sleep! 0.25)
+		     (let ((res (with-input-from-file start-flag
+				  (lambda ()
+				    (read-line)))))
+		       (equal? server-key res))))
+	      #t ;; (system (conc "touch " start-flag)) ;; lazy but safe
+	      (begin
+		(debug:print-info 0 *default-log-port* "Gating server start, last start: "
+				  fmodtime ", delta: " delta ", reftime: " reftime ", all-go=" all-go)
+		(thread-sleep! reftime)
+		(server:wait-for-server-start-last-flag areapath)))))))
+
+(define (server:get-num-servers #!key (numservers 2))
+  (let ((ns (string->number
+	     (or (configf:lookup *configdat* "server" "numservers") "notanumber"))))
+    (or ns numservers)))
+
+(define (server:kill servr)
+  (handle-exceptions
+    exn
+    (begin 
+      (debug:print-info 0 *default-log-port*  "Unable to get host and/or port from " servr ", exn=" exn)     
+    #f)
+  (match-let (((mod-time hostname port start-time server-id pid)
+	       servr))
+    (tasks:kill-server hostname pid))))
+
+;; called in megatest.scm, host-port is string hostname:port
+;;
+;; NOTE: This is NOT called directly from clients as not all transports support a client running
+;;       in the same process as the server.
+;;
+;; run ping in separate process, safest way in some cases
+;;
+(define (server:ping-server ifaceport)
+  (with-input-from-pipe 
+   (conc (common:get-megatest-exe) " -ping " ifaceport)
+   (lambda ()
+     (let loop ((inl (read-line))
+		(res "NOREPLY"))
+       (if (eof-object? inl)
+	   (case (string->symbol res)
+	     ((NOREPLY)  #f)
+	     ((LOGIN_OK) #t)
+	     (else       #f))
+	   (loop (read-line) inl))))))
+
+;; NOT USED (well, ok, reference in rpc-transport but otherwise not used).
+;;
+(define (server:login toppath)
+  (lambda (toppath)
+    (set! *db-last-access* (current-seconds)) ;; might not be needed.
+    (if (equal? *toppath* toppath)
+	#t
+	#f)))
+
+;; timeout is hms string: 1h 5m 3s, default is 1 minute
+;;
+(define (server:expiration-timeout)
+  (let ((tmo (configf:lookup *configdat* "server" "timeout")))
+    (if (and (string? tmo)
+	     (common:hms-string->seconds tmo)) ;; BUG: hms-string->seconds is broken, if given "10" returns 0. Also, it doesn't belong in this logic unless the string->number is changed below
+        (* 3600 (string->number tmo))
+	60)))
+
+(define (server:get-best-guess-address hostname)
+  (let ((res #f))
+    (for-each 
+     (lambda (adr)
+       (if (not (eq? (u8vector-ref adr 0) 127))
+	   (set! res adr)))
+     ;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME
+     (vector->list (hostinfo-addresses (hostname->hostinfo hostname))))
+    (string-intersperse 
+     (map number->string
+	  (u8vector->list
+	   (if res res (hostname->ip hostname)))) ".")))
+
+;; (define server:sync-lock-token "SERVER_SYNC_LOCK")
+;; (define (server:release-sync-lock)
+;;   (db:no-sync-del! *no-sync-db* server:sync-lock-token))
+;; (define (server:have-sync-lock?)
+;;   (let* ((have-lock-pair (db:no-sync-get-lock *no-sync-db* server:sync-lock-token))
+;;          (have-lock?     (car have-lock-pair))
+;;          (lock-time      (cdr have-lock-pair))
+;;          (lock-age       (- (current-seconds) lock-time)))
+;;     (cond
+;;      (have-lock? #t)
+;;      ((>lock-age
+;;        (* 3 (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: 180)))
+;;       (server:release-sync-lock)
+;;       (server:have-sync-lock?))
+;;      (else #f))))
+
+;; moving this here as it needs access to db and cannot be in common.
+;;
+
+(define (server:get-bruteforce-syncer dbstruct #!key (fork-to-background #f) (persist-until-sync #f))
+  (let* ((sqlite-exe   (or (get-environment-variable "MT_SQLITE3_EXE"))) ;; defined in cfg.sh
+         (sync-log     (or ;; (args:get-arg "-sync-log")
+			(conc *toppath* "/logs/sync-" (current-process-id) "-" (get-host-name) ".log")))
+	 (tmp-area     (common:get-db-tmp-area))
+	 (tmp-db       (conc tmp-area "/megatest.db"))
+	 (staging-file (conc *toppath* "/.megatest.db"))
+	 (mtdbfile     (conc *toppath* "/megatest.db"))
+	 (lockfile     (common:get-sync-lock-filepath))
+         (sync-cmd-core     (conc sqlite-exe" " tmp-db " .dump | "sqlite-exe" " staging-file "&>"sync-log))
+         (sync-cmd     (if fork-to-background 
+                           (conc "/usr/bin/env NBFAKE_LOG="*toppath*"/logs/last-server-sync-"(current-process-id)".log nbfake \""sync-cmd-core" && /bin/mv -f " staging-file " " mtdbfile" \"")
+                           sync-cmd-core))
+         (default-min-intersync-delay 2)
+	 (min-intersync-delay (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: default-min-intersync-delay))
+         (default-duty-cycle 0.1)
+         (duty-cycle   (configf:lookup-number *configdat* "server" "sync-duty-cycle" default: default-duty-cycle))
+         (last-sync-seconds 10) ;; we will adjust this to a measurement and delay last-sync-seconds * (1 - duty-cycle)
+         (calculate-off-time (lambda (work-duration duty-cycle)
+                                  (* (/ (- 1 duty-cycle) duty-cycle) last-sync-seconds)))
+         (off-time min-intersync-delay) ;; adjusted in closure below.
+         (do-a-sync
+          (lambda ()
+            ;; (BB> "Start do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync)
+            (let* ((finalres
+                    (let retry-loop ((num-tries 0))
+                         (if (common:simple-file-lock lockfile)
+	                     (begin
+                               (cond
+                                ((not (or fork-to-background persist-until-sync))
+                                 (debug:print 0 *default-log-port* "INFO: syncer thread sleeping for max of (server.minimum-intersync-delay="min-intersync-delay
+                                              " , off-time="off-time" seconds ]")
+                                 (thread-sleep! (max off-time min-intersync-delay)))
+                                (else
+                                 (debug:print 0 *default-log-port* "INFO: syncer thread NOT sleeping ; maybe time-to-exit...")))
+
+                               (if (not (configf:lookup *configdat* "server" "disable-db-snapshot"))
+                                   (common:snapshot-file mtdbfile subdir: ".db-snapshot"))
+		               (delete-file* staging-file)
+		               (let* ((start-time (current-milliseconds))
+                                      (res (system sync-cmd))
+                                      (dbbackupfile (conc mtdbfile ".backup"))
+                                      (res2 
+                                       (cond
+                                        ((eq? 0 res )
+                                         (handle-exceptions
+                                            exn
+                                            #f
+                                         (if (file-exists? dbbackupfile)
+		                           (delete-file* dbbackupfile)
+                                         )
+                                         (if (eq? 0 (file-size sync-log))
+                                             (delete-file* sync-log))
+		                         (system (conc "/bin/mv " staging-file " " mtdbfile))
+                                         
+                                         (set! last-sync-seconds (/ (- (current-milliseconds) start-time) 1000))
+                                         (set! off-time (calculate-off-time
+                                                         last-sync-seconds
+                                                         (cond
+                                                          ((and (number? duty-cycle) (> duty-cycle 0) (< duty-cycle 1))
+                                                           duty-cycle)
+                                                          (else
+                                                           (debug:print 0 *default-log-port* "WARNING: ["(common:human-time)"] server.sync-duty-cycle is invalid.  Should be a number between 0 and 1, but "duty-cycle" was specified.  Using default value: "default-duty-cycle)
+                                                           default-duty-cycle))))
+                                         
+                                         (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" SYNC took "last-sync-seconds" sec")
+                                         (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" SYNC took "last-sync-seconds" sec ; with duty-cycle of "duty-cycle" off time is now "off-time)
+                                         'sync-completed))
+                                        (else
+                                         (system (conc "/bin/cp "sync-log" "sync-log".fail"))
+                                         (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Sync failed. See log at "sync-log".fail")
+                                         (if (file-exists? (conc mtdbfile ".backup"))
+                                             (system (conc "/bin/cp "mtdbfile ".backup " mtdbfile)))
+                                         #f))))
+                                 (common:simple-file-release-lock lockfile)
+                                 ;; (BB> "released lockfile: " lockfile)
+                                 #;(when (common:file-exists? lockfile)
+                                   (BB> "DID NOT ACTUALLY RELEASE LOCKFILE"))
+                                 res2) ;; end let
+                               );; end begin
+                             ;; else
+                             (cond
+                              (persist-until-sync
+                               (thread-sleep! 1)
+                               (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" other SYNC in progress; we're in a fork-to-background so we need to succeed.  Let's wait a jiffy and and try again. num-tries="num-tries" (waiting for lockfile="lockfile" to disappear)")
+                               (retry-loop (add1 num-tries)))
+                              (else
+                               (thread-sleep! (max off-time (+ last-sync-seconds min-intersync-delay)))
+                               (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" other SYNC in progress; not syncing.")
+                               'parallel-sync-in-progress))
+                             ) ;; end if got lockfile
+                         )
+                    ))
+              ;; (BB> "End do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync" and result="finalres)
+              finalres)
+            ) ;; end lambda
+          ))
+    do-a-sync))
+
+;; (define (debug:print . params) #f)
+;; (define (debug:print-info . params) #f)
+;; 
+;; (define (set-functions dbgp dbgpinfo)
+;;   (set! debug:print dbgp)
+;;   (set! debug:print-info dbgpinfo))
+
+)

DELETED sretrieve.scm
Index: sretrieve.scm
==================================================================
--- sretrieve.scm
+++ /dev/null
@@ -1,1112 +0,0 @@
-
-;; Copyright 2006-2013, Matthew Welland.
-;; 
-;; This file is part of Megatest.
-;; 
-;;     Megatest is free software: you can redistribute it and/or modify
-;;     it under the terms of the GNU General Public License as published by
-;;     the Free Software Foundation, either version 3 of the License, or
-;;     (at your option) any later version.
-;; 
-;;     Megatest is distributed in the hope that it will be useful,
-;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;     GNU General Public License for more details.
-;; 
-;;     You should have received a copy of the GNU General Public License
-;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
-;;
-
-(use defstruct)
-(use scsh-process)
-(use srfi-18)
-(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))
-
-(include "megatest-version.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")
-
-(define (toplevel-command . args) #f)
-(use readline)
-
-
-
-
-;;
-;; GLOBALS
-;;
-(define *verbosity* 1)
-(define *logging* #f)
-(define *exe-name* (pathname-file (car (argv))))
-(define *sretrieve:current-tab-number* 0)
-(define *args-hash* (make-hash-table))
-(define sretrieve:help (conc "Usage: " *exe-name* " [action [params ...]]
-
-  ls   <area>                        : list contents of target area
-  get  <area>  <reletive path>       : retrieve path to the data within <area>
-     -m \"message\"       : why retrieved?
-  shell  <area>                   : start a shell-like interface
-
-Part of the Megatest tool suite.
-Learn more at http://www.kiatoa.com/fossils/megatest
-
-Version: " megatest-fossil-hash)) ;; "
-
-;;======================================================================
-;; RECORDS
-;;======================================================================
-
-;;======================================================================
-;; DB
-;;======================================================================
-
-;; replace (strftime('%s','now')), with datetime('now'))
-;(define (sretrieve:initialize-db db)
-;  (for-each
-;   (lambda (qry)
-;     (exec (sql db qry)))
-;   (list 
-;    "CREATE TABLE IF NOT EXISTS actions
-;         (id           INTEGER PRIMARY KEY,
-;          action       TEXT NOT NULL,
-;          retriever    TEXT NOT NULL,
-;          datetime     TIMESTAMP DEFAULT (datetime('now','localtime')),
-;          srcpath      TEXT NOT NULL,
-;          comment      TEXT DEFAULT '' NOT NULL,
-;          state        TEXT DEFAULT 'new');"
-;    "CREATE TABLE IF NOT EXISTS bundles
-;         (id           INTEGER PRIMARY KEY,
-;          bundle       TEXT NOT NULL,
-;          release      TEXT NOT NULL,
-;          status       TEXT NOT NULL,
-;          event_date   TEXT NOT NULL);"
-;    )))
-;
-;(define (sretrieve:register-action db action submitter source-path comment)
-; ; (print "(sretrieve:register-action db " db " action " action " submitter " submitter " source-path " source-path " comment " comment)
-;  (exec (sql db "INSERT INTO actions (action,retriever,srcpath,comment)
-;                 VALUES(?,?,?,?)")
-;	action
-;	submitter
-;	source-path
-;	(or comment "")))
-
-;; (call-with-database
-;;  (lambda (db)
-;;   (set-busy-handler! db (busy-timeout 10000)) ; 10 second timeout
-;;   ...))
-
-;; Create the sqlite db
-;(define (sretrieve:db-do configdat proc) 
-;  (let ((path (configf:lookup configdat "database" "location")))
-;    (if (not path)
-;	(begin
-;	  (debug:print 0 "[database]\nlocation /some/path\n\n Is missing from the config file!")
-;	  (exit 1)))
-;    (if (and path
-;	     (directory? path)
-;	     (file-read-access? path))
-;	(let* ((dbpath    (conc path "/" *exe-name* ".db"))
-;	       (writeable (file-write-access? dbpath))
-;	       (dbexists  (file-exists? dbpath)))
-;	  (handle-exceptions
-;	   exn
-;	   (begin
-;	     (debug:print 2 "ERROR: problem accessing db " dbpath
-;			  ((condition-property-accessor 'exn 'message) exn))
-;	     (exit 1))
-;            ;;(debug:print 0 "calling proc " proc "db path " dbpath )
-;	   (call-with-database
-;            dbpath
-;	    (lambda (db)
-;	       ;;(debug:print 0 "calling proc " proc " on db " db)
-;	      (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout
-;	      (if (not dbexists)(sretrieve:initialize-db db))
-;	      (proc db)))))
-;	(debug:print 0 "ERROR: invalid path for storing database: " path))))
-
-;; copy in directory to dest, validation is done BEFORE calling this
-;;
-;(define (sretrieve:get configdat retriever version comment)
-;  (let* ((base-dir  (configf:lookup configdat "settings" "base-dir"))
-;	 (datadir   (conc base-dir "/" version)))
-;    (if (or (not base-dir)
-;	    (not (file-exists? base-dir)))
-;	(begin
-;	  (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found")
-;	  (exit 1)))
-;    (print datadir)
-;    (if (not (file-exists? datadir))
-;	(begin
-;	  (debug:print 0 "ERROR: Bad version (" version "), no data found at " datadir "." )
-;	  (exit 1)))
-;    
-;    (sretrieve:db-do
-;     configdat
-;     (lambda (db)
-;       (sretrieve:register-action db "get" retriever datadir comment)))
-;      (sretrieve:do-as-calling-user
-;       (lambda ()
-;         (if (directory? datadir)
-;	   (begin
-;  	    (change-directory datadir)
-;	    (let ((files (filter (lambda (x)
-;				(not (member x '("." ".."))))
-;			      (glob "*" ".*"))))
-;	     (print "files: " files)
-;	     (process-execute "/bin/tar" (append (append (list  "chfv" "-") files) (list "--ignore-failed-read")))))
-;             (begin
-;               (let* ((parent-dir (pathname-directory datadir) )
-;                      (filename  (conc(pathname-file datadir) "." (pathname-extension datadir))))
-;                  (change-directory parent-dir)  
-;                  (process-execute "/bin/tar" (list "chfv" "-" filename))
-;             )))
-;))))
-;
-;
-;;; copy in file to dest, validation is done BEFORE calling this
-;;;
-;(define (sretrieve:cp configdat retriever file comment)
-;  (let* ((base-dir  (configf:lookup configdat "settings" "base-dir"))
-;         (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths"))    
-;	 (datadir   (conc base-dir "/" file))
-;         (filename  (conc(pathname-file datadir) "." (pathname-extension datadir))))
-;    (if (or (not base-dir)
-;	    (not (file-exists? base-dir)))
-;	(begin
-;	  (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found")
-;	  (exit 1)))
-;    (print datadir)
-;    (if (not (file-exists? datadir))
-;	(begin
-;	  (debug:print 0 "ERROR: File  (" file "), not found at " base-dir "." )
-;	  (exit 1)))
-;    (if (directory? datadir)
-;	(begin
-;	  (debug:print 0 "ERROR: (" file ") is a dirctory!! cp cmd works only on files ." )
-;	  (exit 1)))
-;    (if(not (string-match (regexp  allowed-sub-paths) file))
-;        (begin
-;	  (debug:print 0 "ERROR: Access denied to file (" file ")!! " )
-;	  (exit 1)))
-;     
-;     (sretrieve:db-do
-;     configdat
-;     (lambda (db)
-;       (sretrieve:register-action db "cp" retriever datadir comment)))
-;      (sretrieve:do-as-calling-user
-;      ;;  (debug:print 0 "ph:  "(pathname-directory datadir)  "!! " )
-;       (change-directory (pathname-directory datadir))  
-;       ;;(debug:print 0 "ph: /bin/tar" (list "chfv" "-" filename) )
-;      (process-execute "/bin/tar" (list "chfv" "-" filename)))
-;      ))
-;
-;;; ls in file to dest, validation is done BEFORE calling this
-;;;
-;(define (sretrieve:ls configdat retriever file comment)
-;  (let* ((base-dir  (configf:lookup configdat "settings" "base-dir"))
-;         (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths"))    
-;	 (datadir   (conc base-dir "/" file))
-;         (filename  (conc(pathname-file datadir) "." (pathname-extension datadir))))
-;    (if (or (not base-dir)
-;	    (not (file-exists? base-dir)))
-;	(begin
-;	  (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found")
-;	  (exit 1)))
-;    (print datadir)
-;    (if (not (file-exists? datadir))
-;	(begin
-;	  (debug:print 0 "ERROR: File  (" file "), not found at " base-dir "." )
-;	  (exit 1)))
-;      (if(not (string-match (regexp  allowed-sub-paths) file))
-;        (begin
-;	  (debug:print 0 "ERROR: Access denied to file (" file ")!! " )
-;	  (exit 1)))
-;   
-;        (sretrieve:do-as-calling-user
-;        (lambda ()
-;	  (process-execute "/bin/ls" (list "-ls"  "-lrt" datadir ))
-; ))))
-
-
-
-(define (sretrieve:validate target-dir targ-mk)
-  (let* ((normal-path (normalize-pathname targ-mk))
-        (targ-path (conc target-dir "/" normal-path)))
-    (if (string-contains   normal-path "..")
-    (begin
-      (debug:print 0 "ERROR: Path  " targ-mk " resolved outside target area "  target-dir )
-      (exit 1)))
-
-    (if (not (string-contains targ-path target-dir))
-    (begin
-      (debug:print 0 "ERROR: You cannot update data outside " target-dir ".")
-      (exit 1)))
-    (debug:print 0 "Path " targ-mk " is valid.")   
- ))
-
-
-;(define (sretrieve:backup-move path)
-;  (let* ((trashdir  (conc (pathname-directory path) "/.trash"))
-;	 (trashfile (conc trashdir "/" (current-seconds) "-" (pathname-file path))))
-;    (create-directory trashdir #t)
-;    (if (directory? path)
-;	(system (conc "mv " path " " trashfile))
-;	(file-move path trash-file))))
-;
-;
-;(define (sretrieve:lst->path pathlst)
-;  (conc "/" (string-intersperse (map conc pathlst) "/")))
-;
-;(define (sretrieve:path->lst path)
-;  (string-split path "/"))
-;
-;(define (sretrieve:pathdat-apply-heuristics configdat path)
-;  (cond
-;   ((file-exists? path) "found")
-;   (else (conc path " not installed"))))
-
-;;======================================================================
-;; MISC
-;;======================================================================
-
-(define (sretrieve:do-as-calling-user proc)
-  (let ((eid (current-effective-user-id))
-        (cid (current-user-id)))
-    (if (not (eq? eid cid)) ;; running suid
-            (set! (current-effective-user-id) cid))
-    ;; (debug:print 0 "running as " (current-effective-user-id))
-    (proc)
-    (if (not (eq? eid cid))
-        (set! (current-effective-user-id) eid))))
-
-(define (sretrieve:find name paths)
-  (if (null? paths)
-      #f
-      (let loop ((hed (car paths))
-		 (tal (cdr paths)))
-	(if (file-exists? (conc hed "/" name))
-	    hed
-	    (if (null? tal)
-		#f
-		(loop (car tal)(cdr tal)))))))
-
-(define (sretrieve:stderr-print . args)
-  (with-output-to-port (current-error-port)
-    (lambda ()
-      (apply print args))))
-
-;;======================================================================
-;; SHELL
-;;======================================================================
-
-;; Create the sqlite db for shell
-;(define (sretrieve:shell-db-do path proc) 
-;    (if (not path)
-;	(begin
-;	  (debug:print 0 "[database]\nlocation /some/path\n\n Is missing from the config file!")
-;	  (exit 1)))
-;    (if (and path
-;	     (directory? path)
-;	     (file-read-access? path))
-;	(let* ((dbpath    (conc path "/" *exe-name* ".db"))
-;	       (writeable (file-write-access? dbpath))
-;	       (dbexists  (file-exists? dbpath)))
-;	  (handle-exceptions
-;	   exn
-;	   (begin
-;	     (debug:print 2 "ERROR: problem accessing db " dbpath
-;			  ((condition-property-accessor 'exn 'message) exn))
-;	     (exit 1))
-;            ;;(debug:print 0 "calling proc " proc "db path " dbpath )
-;	   (call-with-database
-;            dbpath
-;	    (lambda (db)
-;	       ;;(debug:print 0 "calling proc " proc " on db " db)
-;	      (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout
-;	      (if (not dbexists)(sretrieve:initialize-db db))
-;	      (proc db)))))
-;	(debug:print 0 "ERROR: invalid path for storing database: " path)))
-
-
-
-;; function to find sheets to which use has access 
-(define (sretrieve:has-permission  area)
-  (let ((username     (current-user-name)))
-  (cond
-   ((is-admin username)
-     #t)
-   ((is-user "retrieve" username area) 
-     #t)
-    ((is-user "publish" username area) 
-     #t)
-   ((is-user "writer-admin" username area) 
-     #t)
-   ((is-user "read-admin" username area) 
-     #t)
-   ((is-user "area-admin" username area) 
-     #t)
-   (else  
-    #f))))
- 
-
-(define (sretrieve:get-accessable-projects  area)
-   (let* ((projects `()))
-         
-        (if (sretrieve:has-permission area)
-               (set! projects (cons area projects))
-               (begin
-                 (sauth:print-error (conc "User cannot access area " area "!!"))  
-                (exit 1))) 
-   ; (print projects)
-    projects))
-		 
-(define (sauth-common:shell-ls-cmd base-path-list ext-path top-areas base-path tail-cmd-list)
-    (if (and (null? base-path-list) (equal? ext-path "") )
-      (print (string-intersperse top-areas " "))
-  (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas )))
-           ;(print resolved-path)
-           (if (not (equal? resolved-path #f))
-           (if (null? resolved-path) 
-             (print (string-intersperse top-areas " "))
-           (let* ((target-path (sauth-common:get-target-path  base-path-list  ext-path top-areas base-path)))
-                ;(print "Resolved path: " target-path)
-                (if (not (equal? target-path #f))
-                  (begin   
-                (if (symbolic-link? target-path)
-                   (set! target-path (conc target-path "/"))) 
-                (if (not (equal? target-path #f))
-                (begin 
-                (cond
-		  ((null? tail-cmd-list)
-		     (run (pipe
-      	      	      (ls "-lrt" ,target-path))))
-		  ((not (equal? (car tail-cmd-list) "|"))
-                         (print "ls cmd cannot accept "(string-join tail-cmd-list) " as an argument!!"))
-                  (else  
-                    (run (pipe
-      	      	      (ls "-lrt" ,target-path)
-                      (begin (system (string-join (cdr tail-cmd-list))))))
-      ))))))))))))
-
-(define (sretrieve:shell-cat-cmd base-pathlist ext-path top-areas base-path tail-cmd-list)
-  (let* ((resolved-path (sauth-common:resolve-path ext-path base-pathlist top-areas ))
-          (data "") )
-         (if (not (equal? resolved-path #f))
-           (if (null? resolved-path) 
-             (print "Path could not be resolved!!")
-           (let* ((target-path (sauth-common:get-target-path  base-pathlist  ext-path top-areas base-path)))
-             (if (not (equal? target-path #f))
-               (if (or (not (file-exists? target-path)) (directory? target-path))
-               (print "Target path does not exist or is a directory!") 
-               (begin 
-                 (cond
-		  ((null? tail-cmd-list)
-		     (run (pipe
-      	      	      (cat  ,target-path))))
-		  ((not (equal? (car tail-cmd-list) "|"))
-                         (print "cat cmd cannot accept "(string-join tail-cmd-list) " as an argument!!"))
-                  (else  
-                    (run (pipe
-      	      	      (cat ,target-path)
-                      (begin (system (string-join (cdr tail-cmd-list))))))))))
-)))
-             (print "Path could not be resolved!!"))))
-
-(define (get-options cmd-list split-str)
-    (if (null? cmd-list)
-              (list '() '())
-    (let loop ((hed (car cmd-list))
-		 (tal (cdr cmd-list))
-                  (res '()))
-                   (cond
-                   ((equal? hed split-str)
-                      (list res tal))
-                   ((null? tal)
-                      (list (cons hed res) tal)) 
-                   (else 
-		  	(loop (car tal)(cdr tal)(cons hed res)))))))
-
-  
-(define (sretrieve:shell-grep-cmd base-pathlist ext-path top-areas base-path tail-cmd-list)
-  (let* ((resolved-path (sauth-common:resolve-path ext-path base-pathlist top-areas ))
-          (pattern (car tail-cmd-list))
-          (pipe-cmd-list (get-options (cdr tail-cmd-list) "|"))
-          (options (string-join (car pipe-cmd-list)))
-          (pipe-cmd (cadr  pipe-cmd-list))
-          (redirect-split (string-split (string-join  tail-cmd-list) ">"))   )
-         (if(and ( > (length redirect-split) 2 ))
-            (print "sgrep  cmd cannot accept > " (string-join redirect-split) " as an argument!!" )  
-         (if (not (equal? resolved-path #f))
-           (if (null? resolved-path) 
-             (print "Path could not be resolved!!")
-           (let* ((target-path (sauth-common:get-target-path  base-pathlist  ext-path top-areas base-path))
-                  (restrictions (if (equal? target-path #f)
-                                                 ""
-                                               (sretrieve:shell-lookup base-path)))
-                 (rest-str  (string-split (conc " --exclude-dir=" (string-join (string-split restrictions ",") " --exclude-dir=") ))))
-             (if (not (file-exists? target-path))
-               (print "Target path does not exist!") 
-               (begin 
-                 (cond
-	 	  ((and (null? pipe-cmd) (string-null? options))
-	 	     (run (pipe
-      	      	      (grep ,pattern ,target-path ))))
-		  ((and (null? pipe-cmd) (not (string-null? options)))
-		     (run (pipe
-      	      	      (begin (process-execute "/usr/bin/grep" (append (list options pattern target-path) rest-str))))))
-                  ((and (not (null? pipe-cmd)) (string-null? options))
-                        (run (pipe
-      	      	      (grep ,exclude-dir ,pattern ,target-path)
-                      (begin (system (string-join pipe-cmd))))))
-                  (else   
-                      (run (pipe
-      	      	      ;(grep  ,options ,exclude-dir ,pattern ,target-path)
-                       (begin (process-execute "/usr/bin/grep" (append (list options pattern target-path) rest-str)))
-
-                      (begin (system (string-join  pipe-cmd)))))))
-))))
-             (print "Path could not be resolved!!")))))
-
-
-(define (sretrieve:shell-less-cmd base-pathlist ext-path top-areas base-path)
-  (let* ((resolved-path (sauth-common:resolve-path ext-path base-pathlist top-areas )))
-         (if (not (equal? resolved-path #f))
-           (if (null? resolved-path) 
-             (print "Path could not be resolved!!")
-           (let* ((target-path (sauth-common:get-target-path  base-pathlist  ext-path top-areas base-path)))
-               (if (not (equal? target-path #f))
-           	 (if (or (not (file-exists? target-path)) (directory? target-path))
-                   (print "Target path does not exist or is a directory!") 
-                   (begin 
-                     ;(sretrieve:shell-db-do
-         	     ;     db-location
-     		     ;	  (lambda (db)
-       		;		(sretrieve:register-action db "less" (current-user-name) target-path (conc "Executing cmd: less "  target-path))))   
- 
-                     (setenv "LESSSECURE" "1")
-                     (run (pipe
-      	      	     (less ,target-path))))))))
-             (print "Path could not be resolved!!"))))
-
-
-
-(define (sretrieve:shell-lookup base-path)
-  (let* ((usr (current-user-name))
-          (value (get-restrictions base-path usr)))
-                              value))
-             
-
-(define (sretrieve:load-shell-config fname)
-          (if (file-exists? fname)
-	(read-config fname #f #f)
-	))
-
-
-(define (is_directory target-path) 
-  (let* ((retval #f))
-  (sretrieve:do-as-calling-user
-    	(lambda ()
-          ;(print (current-effective-user-id) ) 
-          (if (directory? target-path)
-               (set! retval  #t))))
-             ;(print (current-effective-user-id))
-     retval)) 
-
-(define (make-exclude-pattern  restriction-list  )
-  (if (null? restriction-list)
-     ""
-   (let loop ((hed (car restriction-list))
-		 (tal (cdr restriction-list))
-                  (ret-str ""))
-                   (cond
-                   ((null? tal)
-                      (conc ret-str ".+" hed ".*")) 
-                   (else 
-		  	(loop (car tal)(cdr tal)(conc ret-str ".+" hed ".*|"))))))    )
-
-(define (sretrieve:get-shell-cmd target-path base-path restrictions iport)
-     (if (not (file-exists? target-path))
-        (sauth:print-error "Target path does not exist!")
-    (begin
-    (if (not (equal? target-path #f))
-    (begin     
-        (if (is_directory target-path) 
-        (begin
-           (let* ((tmpfile (conc "/tmp/" (current-user-name) "/my-pipe"))
-                  (parent-dir target-path)
-                  (last-dir-name (if  (pathname-extension target-path)  
-                                      (conc(pathname-file target-path) "." (pathname-extension target-path))
-                                      (pathname-file target-path)))
-                  (curr-dir (current-directory))   
-                  (start-dir (conc (current-directory) "/" last-dir-name))
-                  (execlude (make-exclude-pattern (string-split restrictions ","))))
-                  ; (print tmpfile)
-                    (if  (file-exists? start-dir)
-                    (begin
-                         (print last-dir-name " already exist in your work dir. Do you want to over write it? [y|n]")
-                        (let* ((inl (read-line iport)))
-                            (if (equal? inl "y")
-                              (begin
-                                 (change-directory parent-dir)
-                                  (create-fifo  tmpfile)
-                                  (process-fork 
-    				   (lambda()
-                                       (sleep 1) 
-       					(with-output-to-file tmpfile
-         				(lambda ()
-            				(sretrieve:make_file parent-dir execlude parent-dir)))))
- 
-                                  (run (pipe
-                   		   (tar "chfv" "-" "-T" ,tmpfile )
-                   		   (begin (system (conc "cd " start-dir ";tar  xUf - "   )))))
-                                   (change-directory curr-dir)
-                                    (system (conc "rm " tmpfile)) )
-			      (begin	
-                               (print  "Nothing has been retrieved!!  ")))))
-                     (begin
-                       (sretrieve:do-as-calling-user
-                    (lambda ()
-		      (create-directory start-dir #t)))
-                          (change-directory parent-dir)
-                          ; (print execlude)
-                           (create-fifo tmpfile)
-                            (process-fork 
-    				   (lambda()
-                                       (sleep 1) 
-       					(with-output-to-file tmpfile
-         				(lambda ()
-            				(sretrieve:make_file parent-dir execlude parent-dir)))))
-
-                                  (run (pipe
-                   		   (tar "chfv" "-"  "-T" ,tmpfile)
-                   		   (begin (system (conc "cd " start-dir ";tar  xUf - "    )))))
-                           (change-directory curr-dir)
-                            (system (conc "rm " tmpfile)))))) 
-        (begin
-           (let*((parent-dir (pathname-directory target-path))
-                 (start-dir (current-directory))
-                 (filename (if  (pathname-extension target-path)  
-                                      (conc(pathname-file target-path) "." (pathname-extension target-path))
-                                      (pathname-file target-path)))
-                 (work-dir-file (conc (current-directory) "/" filename)))
-                 (if  (file-exists? work-dir-file)
-                    (begin
-                       (print filename " already exist in your work dir. Do you want to over write it? [y|n]")
-                        (let* ((inl (read-line iport)))
-                            (if (equal? inl "y")
-                              (begin
-                                 (change-directory parent-dir)
-                                  (run (pipe
-                   		   (tar "chfv" "-" ,filename)
-                   		   (begin (system (conc "cd " start-dir ";tar  xUf - "   )))))
-                                     (change-directory start-dir))
-			      (begin	
-                               (print  "Nothing has been retrieved!!  ")))))
-                    (begin
-               (change-directory parent-dir)  
-                 (run (pipe
-                   (tar "chfv" "-" ,filename)
-                   (begin (system (conc "cd " start-dir ";tar xUf -")))))
-                    (change-directory start-dir)))))))))))
-
-(define (sretrieve:get-shell-cmd-line target-path base-path restrictions iport)
-   (handle-exceptions
-	   exn 
-	   (begin
-	     (sauth:print-error (conc "Problem fetching the data. Sauth provieds sudo access to only one unix group. Please ensure you have washed all the remaining groups. System Error: " 
-			  ((condition-property-accessor 'exn 'message) exn)))
-	     (exit 1))
-  
-    (if (not (file-exists? target-path))
-        (sauth:print-error "Error:Target path does not exist!")
-    (begin
-    (if (not (equal? target-path #f))
-    (begin     
-        (if (is_directory target-path) 
-        (begin
-           (let* ((parent-dir target-path)
-                  (last-dir-name (if  (pathname-extension target-path)  
-                                      (conc(pathname-file target-path) "." (pathname-extension target-path))
-                                      (pathname-file target-path)))
-                  (curr-dir (current-directory))   
-                  (start-dir (conc (current-directory) "/" last-dir-name))
-                  (execlude (make-exclude-pattern (string-split restrictions ",")))
-                   (tmpfile (conc "/tmp/my-pipe-" (current-process-id))))
-                    (if  (file-exists? start-dir)
-                    (begin
-                         (sauth:print-error (conclast-dir-name " already exist in your work dir."))
-                         (sauth:print-error  "Nothing has been retrieved!!  "))
-                     (begin
-                   ;    (sretrieve:do-as-calling-user
-                   ; (lambda ()
-                  ; (print tmpfile) 
-                  ;(if (not (file-exists?  (conc "/tmp/" (current-user-name)))) 
-		  ;    (create-directory (conc "/tmp/" (current-user-name)) #t))
-                          (change-directory parent-dir)
-                            (create-fifo  tmpfile)
-                                  (process-fork 
-    				   (lambda()
-                                       (sleep 1) 
-       					(with-output-to-file tmpfile
-         				(lambda ()
-            				(sretrieve:make_file parent-dir execlude parent-dir)))))
-
-                           (process-execute "/bin/tar" (append (list  "chfv" "-"  "-T" tmpfile)  (list "--ignore-failed-read")))    
-                                  ;(run (pipe
-                   		   ;(tar "chfv" "-" "." )
-                   		   ;(begin (system (conc "cd " start-dir ";tar  xUf - "   execlude )))))
-                            (system (conc "rm " tmpfile))    
-                           (change-directory curr-dir))))) 
-        (begin
-           (let*((parent-dir (pathname-directory target-path))
-                 (start-dir (current-directory))
-                 (filename (if  (pathname-extension target-path)  
-                                      (conc(pathname-file target-path) "." (pathname-extension target-path))
-                                      (pathname-file target-path)))
-                 (work-dir-file (conc (current-directory) "/" filename)))
-                 (if  (file-exists? work-dir-file)
-                    (begin
-                       (print filename " already exist in your work dir.")
-                               (print  "Nothing has been retrieved!!  "))
-                    (begin
-               (change-directory parent-dir)
-                (process-execute "/bin/tar" (append (append (list  "chfv" "-") (list filename)) (list "--ignore-failed-read"))) 
-                 ;(run (pipe
-                  ; (tar "chfv" "-" ,filename)
-                  ; (begin (system (conc "cd " start-dir ";tar xUf -")))))
-                    (change-directory start-dir))))))))))))
-
-(define (sretrieve:make_file path exclude base_path)
-   (find-files 
-     path
-     action: (lambda (p res)
-           (cond
-                ((symbolic-link? p)   
-                 (if (directory?(read-symbolic-link p)) 
-                      (sretrieve:make_file p exclude base_path)
-                      (print (string-substitute (conc base_path "/") "" p "-"))))
-                 ((directory? p)              
-                 ;;do nothing for dirs)
-                 ) 
-                (else 
-                                        
-                     (if (not (string-match (regexp exclude)  p ))
-                        (print (string-substitute (conc base_path "/") "" p "-"))))))
-         dotfiles: #t))
-
-(define (sretrieve:shell-help)
-(conc "Usage: " *exe-name* " [action [params ...]]
-
-  ls    [target path]               	  : list contents of target area. The output of the cmd can be piped into other system cmd. eg ls <path> | grep txt
-  cd    <target directory>	     	  : To change the current directory within the sretrive shell. 
-  pwd				     	  : Prints the full pathname of the current directory within the sretrive shell.
-  get   <file or directory path>     	  : download directory/files into the directory where sretrieve shell cmd was invoked   
-  less  <file path>		     	  : Read input file to allows backward movement in the file as well as forward movement 
-  cat   <file path>                  	  : show the contents of a file. The output of the cmd can be piped into other system cmd.
-
-  sgrep <search path> <pattern> [options] : Similar to unix grep cmd But with diffrent parameter ordering. The output of the cmd can be piped into other system cmd. 
-Part of the Megatest tool suite.
-Learn more at http://www.kiatoa.com/fossils/megatest
-
-Version: " megatest-fossil-hash)
-)	
-;(define (toplevel-command . args) #f)
-(define (sretrieve:shell area)
- ; (print area)
-  (use readline)
-  (let* ((path      '())
-	 (prompt    "sretrieve> ")
-	 (args      (argv))
-         (usr (current-user-name) )   
-         (top-areas (sretrieve:get-accessable-projects area))
-         (close-port     #f)
-         (area-obj  (get-obj-by-code area))
-         (user-obj (get-user usr)) 
-         (base-path (if (null? area-obj) 
-                         "" 
-                        (caddr (cdr area-obj))))      
-	 (iport     (make-readline-port prompt)))
-        (if (null? area-obj)
-          (begin 
-             (print "Area " area " does not exist")
-          (exit 1)))
-	(let loop ((inl (read-line iport)))
-          ;(print 1) 
-	  (if (not (or (or (eof-object? inl)
-		       (equal? inl "exit")) (port-closed? iport)))
-	      (let* ((parts (string-split inl))
-		     (cmd   (if (null? parts) #f (car parts))))
-              ;  (print "2")
-		(if (and (not cmd) (not (port-closed? iport)))
-		    (loop (read-line))
-		    (case (string->symbol cmd)
-		      ((cd)
-		       (if (> (length parts) 1) ;; have a parameter
-                           (begin
-                             (let*((arg (cadr parts))
-                                   (resolved-path (sauth-common:resolve-path  arg path top-areas))
-                                   (target-path (sauth-common:get-target-path path  arg top-areas base-path)))
-                                 (if (not (equal? target-path #f))
-                                 (if (or (equal? resolved-path #f) (not (file-exists? target-path)))    
-                                 (print "Invalid argument " arg ".. ")
-                                  (begin      
-			            (set! path resolved-path)
-                                     (sauthorize:do-as-calling-user
-                              (lambda ()
-			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "cd"))))
-                                  )))))  
-   			   (set! path '())))
-                      ((pwd)
-                         (if (null? path)
-                           (print "/")  
-                           (print "/" (string-join path "/")))) 
-		      ((ls)
-		       (let* ((thepath (if (> (length parts) 1) ;; have a parameter
-					   (cdr parts)
-					   `()))
-			      (plen    (length thepath)))
-                         (cond
-			  ((null? thepath)
-                           (sauth-common:shell-ls-cmd path "" top-areas base-path  '())
-                            (sauthorize:do-as-calling-user
-                              (lambda ()
-			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "ls"))))   )
-			  ((< plen 2)
-                  
-                            (sauth-common:shell-ls-cmd path  (car thepath) top-areas base-path '())
-                              (sauthorize:do-as-calling-user
-                              (lambda ()
-			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "ls")))))
-                          (else 
-                            (if (equal? (car thepath) "|")
-                              (sauth-common:shell-ls-cmd path "" top-areas base-path thepath)
-                              (sauth-common:shell-ls-cmd path  (car thepath) top-areas base-path (cdr thepath)))
-                           (sauthorize:do-as-calling-user
-                              (lambda ()
-			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "ls"))))))))
-                       ((cat)
-		       (let* ((thepath (if (> (length parts) 1) ;; have a parameter
-					   (cdr parts)
-					   `()))
-			      (plen    (length thepath)))
-			 (cond
-			  ((null? thepath)
-                          (print "Error: Missing argument to cat"))
-			  ((< plen 2)
-                            (sretrieve:shell-cat-cmd path  (car thepath) top-areas base-path '())
-                              (sauthorize:do-as-calling-user
-                              (lambda ()
-			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "cat")))))
-
-			  (else
-                             (sretrieve:shell-cat-cmd path  (car thepath) top-areas base-path (cdr thepath))
-                             (sauthorize:do-as-calling-user
-                              (lambda ()
-			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "cat"))))
-))))
-                       ((sgrep)
-		       (let* ((thepath (if (> (length parts) 1) ;; have a parameter
-					   (cdr parts)
-					   `()))
-			      (plen    (length thepath)))
-			 (cond
-			  ((null? thepath) 
-                            (print "Error: Missing arguments to grep!! Useage: grep <search path> <pattern> [options] "))
-                          ((< plen  2)
-                          (print "Error: Missing arguments to grep!! Useage: grep <search path> <pattern> [options] "))
-			  (else
-                             (sretrieve:shell-grep-cmd path  (car thepath) top-areas base-path  (cdr thepath))
-				(sauthorize:do-as-calling-user
-                              (lambda ()
-			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "grep"))))))))
-
-                      ((less)
-		       (let* ((thepath (if (> (length parts) 1) ;; have a parameter
-					   (cdr parts)
-					   `()))
-			      (plen    (length thepath)))
-			 (cond
-			  ((null? thepath)
-                          (print "Error: Missing argument to less"))
-			  ((< plen 2)
-                            (sretrieve:shell-less-cmd path  (car thepath) top-areas base-path)
-                             (sauthorize:do-as-calling-user
-                              (lambda ()
-			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "less")))))
-			  (else
-                             (print "less cmd takes only one (<file path>) argument!!")))))
-                      ((get)
-                         (let* ((thepath (if (> (length parts) 1) ;; have a parameter
-					   (cdr parts)
-					   `()))
-			      (plen    (length thepath)))
-			 (cond
-			  ((null? thepath)
-                          (print "Error: Missing argument <path> to get"))
-			  ((< plen 2)
-                           (let* ((target-path (sauth-common:get-target-path path  (car thepath) top-areas base-path))
-				 (restrictions (if (equal? target-path #f)
-                                                 ""
-                                               (sretrieve:shell-lookup base-path))))
-                               (if (not (equal? target-path #f))
-                             (begin  
-                                 (sretrieve:get-shell-cmd target-path base-path restrictions iport)
-                                  (sauthorize:do-as-calling-user
-                              (lambda ()
-			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "get"))))))))
-			  (else
-                            (print "Error: get cmd takes only one argument ")))))
-                      ((exit)
-                          (print "got exit"))  
-                      ((help)
-                          (print (sretrieve:shell-help)))
-		      (else 
-		       (print "Got command: " inl))))
-                 (loop (read-line iport)))))))
-;;))
-    
-
-;;======================================================================
-;; MAIN
-;;======================================================================
-;;(define *default-log-port* (current-error-port))
-
-;(define (sretrieve:load-config exe-dir exe-name)
-;  (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 #f)
-;	(make-hash-table))))
-
-;; package-type is "megatest", "builds", "kits" etc.
-;;
-
-;(define (sretrieve:load-packages configdat exe-dir package-type)
-;  (push-directory exe-dir)
-;  (let* ((packages-metadir  (configf:lookup configdat "settings" "packages-metadir"))
-;	 (conversion-script (configf:lookup configdat "settings" "conversion-script"))
-;	 (upstream-file     (configf:lookup configdat "settings" "upstream-file"))
-;	 (package-config    (conc packages-metadir "/" package-type ".config")))
-;       (if (file-exists? upstream-file)
-;	(if (or (not (file-exists? package-config)) ;; if not created call the updater, otherwise call only if upstream newer
-;		(> (file-modification-time upstream-file)(file-modification-time package-config)))
-;	    (handle-exceptions
-;	     exn
-;	     (debug:print 0 "ERROR: failed to run script " conversion-script " with params " upstream-file " " package-config)
-;	     (let ((pid (process-run conversion-script (list upstream-file package-config))))
-;	       (process-wait pid)))
-;	    (debug:print 0 "Skipping update of " package-config " from " upstream-file))
-;	(debug:print 0 "Skipping update of " package-config " as " upstream-file " not found"))
-;       (let ((res (if (file-exists? package-config)
-;		   (begin
-;		     (debug:print 0 "Reading package config " package-config)
-;		     (read-config package-config #f #t))
-;		   (make-hash-table))))
-;      (pop-directory)
-;      res)))
-
-(define (toplevel-command . args) #f)
-(define (sretrieve:process-action  action . args)
-    ; (print action)
- ;  (use readline)
-    (case (string->symbol action)
-      ((get)
-       (if (< (length args) 2)
-	   (begin 
-	     (sauth:print-error  "Missing arguments; <area> <relative path>" )
-	     (exit 1)))
-       (let* ((remargs     (args:get-args args '("-m" ) '() args:arg-hash 0))
-              (iport (make-readline-port ">"))
-              (area     (car args))
-              (usr (current-user-name))
-              (area-obj  (get-obj-by-code area))
-              (user-obj (get-user usr))
-              (top-areas (sretrieve:get-accessable-projects area)) 
-              (base-path (if (null? area-obj) 
-                                      "" 
-                                     (caddr (cdr area-obj))))
-	      (sub-path       (if (null? remargs) 
-                                       "" 
-                                       (car remargs))))
-
-          (if (null? area-obj)
-          	    (begin 
-             		(sauth:print-error (conc "Area " area " does not exist"))
-          	         (exit 1)))
-              (let* ((target-path (sauth-common:get-target-path '()  (conc area "/" sub-path) top-areas base-path))
-		     (restrictions (if (equal? target-path #f)
-                                        ""
-                                       (sretrieve:shell-lookup base-path))))
-             (if (not (equal? target-path #f))
-                 (begin  
-                   (sauthorize:do-as-calling-user
-                      (lambda ()
-   		        (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "get " area " " sub-path) (number->string (car user-obj))  (number->string (caddr area-obj))  "get"))))
-                        (sretrieve:get-shell-cmd-line target-path base-path restrictions  iport))))))
-         ((cp)
-             (if (< (length args) 2)
-	   (begin 
-	     (sauth:print-error  "Missing arguments; <area> <relative path>" )
-	     (exit 1)))
-       (let* ((remargs     (args:get-args args '("-m" ) '() args:arg-hash 0))
-              (iport (make-readline-port ">"))
-              (area     (car args))
-              (usr (current-user-name))
-              (area-obj  (get-obj-by-code area))
-              (user-obj (get-user usr))
-              (top-areas (sretrieve:get-accessable-projects area)) 
-              (base-path (if (null? area-obj) 
-                                      "" 
-                                     (caddr (cdr area-obj))))
-	      (sub-path       (if (null? remargs) 
-                                       "" 
-                                       (car remargs))))
-         ;  (print args)
-          (if (null? area-obj)
-          	    (begin 
-             		(sauth:print-error (conc "Area " area " does not exist"))
-          	         (exit 1)))
-              (let* ((target-path (sauth-common:get-target-path '()  (conc area "/" sub-path) top-areas base-path))
-				 (restrictions (if (equal? target-path #f)
-                                                 ""
-                                              (sretrieve:shell-lookup base-path))))
-                          ;(print target-path) 
-                          (if (not (equal? target-path #f))
-                             (begin  
-                              (sauthorize:do-as-calling-user
-                              (lambda ()
-			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "get " area " " sub-path) (number->string (car user-obj))  (number->string (caddr area-obj))  "get"))))
-                            (sretrieve:get-shell-cmd-line target-path base-path restrictions  iport))))))
-      ((cat)
-      (if (< (length args) 2)
-	   (begin 
-	     (sauth:print-error  "Missing arguments; <area> <relative path>" )
-	     (exit 1)))
-       (let* ((remargs     (args:get-args args '("-m" ) '() args:arg-hash 0))
-              (area     (car args))
-              (usr (current-user-name))
-              (area-obj  (get-obj-by-code area))
-              (user-obj (get-user usr))
-              (top-areas (sretrieve:get-accessable-projects area)) 
-              (base-path (if (null? area-obj) 
-                                      "" 
-                                     (caddr (cdr area-obj))))
-	            (sub-path       (if (null? remargs) 
-                                       "" 
-                                       (car remargs))))
-
-          (if (null? area-obj)
-          	    (begin 
-             		(sauth:print-error (conc "Area " area " does not exist"))
-          	         (exit 1)))
-              (let* ((target-path (sauth-common:get-target-path '()  (conc area "/" sub-path) top-areas base-path))
-		     (restrictions (if (equal? target-path #f)
-                                        ""
-                                       (sretrieve:shell-lookup base-path))))
-;(sauth-common:shell-ls-cmd base-path-list ext-path top-areas base-path tail-cmd-list)
-
-             (if (not (equal? target-path #f))
-                 (begin  
-                   (sauthorize:do-as-calling-user
-                      (lambda ()
-   		        (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "get " area " " sub-path) (number->string (car user-obj))  (number->string (caddr area-obj))  "get"))))
-               (sretrieve:shell-cat-cmd (list area) sub-path  top-areas base-path '())))))) 
-      ((ls)
-          (cond
-            ((< (length args) 1)
-              (begin 
-	      (print  "ERROR: Missing arguments; <area> ")
-	      (exit 1)))
-              ((equal? (length args) 1)
-                 (let*  ((area     (car args))
-                         (usr (current-user-name))
-                         (area-obj  (get-obj-by-code area))
-                         (user-obj (get-user usr))
-                         (top-areas (sretrieve:get-accessable-projects area)) 
-                         (base-path (if (null? area-obj) 
-                                      "" 
-                                     (caddr (cdr area-obj)))))
-                  (if (null? area-obj)
-          	    (begin 
-             		(print "Area " area " does not exist")
-          	         (exit 1)))
-             
-            ; (sretrieve:shell-cat-cmd base-pathlist ext-path top-areas base-path tail-cmd-list)
-   
-           	 (sauth-common:shell-ls-cmd '() area top-areas base-path  '())
-                 (sauthorize:do-as-calling-user
-                   (lambda ()
-		    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" "ls" (number->string (car user-obj)) (number->string (caddr area-obj)) "ls"))))))
-             ((> (length args) 1)
-               (let*  ((remargs     (args:get-args args '("-m" ) '() args:arg-hash 0))
-                        (usr (current-user-name))
-                        (user-obj (get-user usr))
-                         (area     (car args)))
-                         (let* ((area-obj  (get-obj-by-code area))
-                               (top-areas (sretrieve:get-accessable-projects area)) 
-                               (base-path (if (null? area-obj) 
-                                      "" 
-                                     (caddr (cdr area-obj))))
-                                 
-                               (sub-path (if (null? remargs) 
-                                       area 
-                                      (conc area "/" (car remargs)))))
-                             ;(print "sub path "  sub-path)
-                            (if (null? area-obj)
-          	              (begin 
-             		        (print "Area " area " does not exist")
-          	                 (exit 1)))
-                              (sauth-common:shell-ls-cmd `()  sub-path top-areas base-path '())
-                            (sauthorize:do-as-calling-user
-				(lambda ()
-                       	       (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "ls " sub-path) (number->string (car user-obj)) (number->string (caddr area-obj)) "ls")))))))))
-
-       ((shell)
-          (if (< (length args) 1)
-             (begin 
-	     (print  "ERROR: Missing arguments <area>!!" )
-	     (exit 1))
-             (sretrieve:shell (car args)))) 
-      (else (print 0 "Unrecognised command " action))))
-
-(define (main)
-  (let* ((args      (argv))
-	 (prog      (car args))
-	 (rema      (cdr args))
-	 (exe-name  (pathname-file (car (argv))))
-	 ;(exe-dir   (or (pathname-directory prog)
-	;		(sretrieve:find exe-name (string-split (get-environment-variable "PATH") ":"))))
-	 ;(configdat (sretrieve:load-config exe-dir exe-name))
-)
-    ;; preserve the exe data in the config file
-    ;(hash-table-set! configdat "exe-info" (list (list "exe-name" exe-name)
-					;	(list "exe-dir"  exe-dir)))
-    (cond
-     ;; one-word commands
-     ((eq? (length rema) 1)
-      (case (string->symbol (car rema))
-	((help -h -help --h --help)
-	 (print sretrieve:help))
-	(else
-	 (print "ERROR: Unrecognised command. Try \"sretrieve help\""))))
-     ;; multi-word commands
-     ((null? rema)(print sretrieve:help))
-     ((>= (length rema) 2)
-      
-      (apply sretrieve:process-action  (car rema) (cdr rema)))
-     (else (debug:print 0 "ERROR: Unrecognised command. Try \"sretrieve help\"")))))
-
-(main)
-
-
-      

Index: subrun.scm
==================================================================
--- subrun.scm
+++ subrun.scm
@@ -31,11 +31,20 @@
 ;;(declare (uses server))
 (declare (uses mt))
 ;;(declare (uses archive))
 ;; (declare (uses filedb))
 
-;(include "common_records.scm")
+(declare (uses commonmod))
+(import commonmod)
+
+(declare (uses configfmod))
+(import configfmod)
+
+(declare (uses dbmod))
+(import dbmod)
+
+;;(include "common_records.scm")
 ;;(include "key_records.scm")
 (include "db_records.scm") ;; provides db:test-get-id
 ;;(include "run_records.scm")
 ;;(include "test_records.scm")
 
@@ -43,15 +52,17 @@
   (if (and (common:file-exists? (conc test-run-dir "/subrun-area") )
            (common:file-exists? (conc test-run-dir "/testconfig.subrun") ))
       #t
       #f))
 
-(define (subrun:launch-dashboard test-run-dir)
+(define (subrun:launch-dashboard test-run-dir #!key (target #f)(runname #f))
   (if (subrun:subrun-test-initialized? test-run-dir)
-      (let* ((subarea (subrun:get-runarea test-run-dir)))
+      (let* ((subarea (subrun:get-runarea test-run-dir))
+	     (params  (conc (if target (conc " -target " target) "")
+			    (if runname (conc " -runname " runname) ""))))
         (if (and subarea (common:file-exists? subarea))
-            (system (conc "cd " subarea ";env -i PATH=$PATH DISPLAY=$DISPLAY HOME=$HOME USER=$USER dashboard &"))))))
+            (system (conc "cd " subarea ";env -i PATH=$PATH DISPLAY=$DISPLAY HOME=$HOME USER=$USER nbfake dashboard " params))))))
 
 (define (subrun:subrun-removed? test-run-dir)
   (if (subrun:subrun-test-initialized? test-run-dir)
       (let ((flagfile (conc test-run-dir "/subrun.removed")))
         (if (common:file-exists? flagfile)
@@ -210,10 +221,13 @@
                          (map (lambda (item)
                                 (if (equal? (car item) "-testpatt")
                                     (cons "-testpatt" testpatt)
                                     item))
                                 switch-alist-pre))))
+    (with-output-to-file "subrun-command-parts.sexp"
+      (lambda ()
+	(pp switch-alist)))
     switch-alist))
     ;; note - get precmd from subrun section
     ;;   apply to submegatest commands
 
 (define (subrun:get-log-path test-run-dir log-prefix)

Index: synchash.scm
==================================================================
--- synchash.scm
+++ synchash.scm
@@ -27,10 +27,14 @@
 (import (prefix sqlite3 sqlite3:))
 
 (declare (unit synchash))
 (declare (uses db))
 (declare (uses server))
+
+(declare (uses dbmod))
+(import dbmod)
+
 (include "db_records.scm")
 
 (define (synchash:make)
    (make-hash-table))
 

Index: tasks.scm
==================================================================
--- tasks.scm
+++ tasks.scm
@@ -26,10 +26,19 @@
 (declare (uses rmt))
 (declare (uses common))
 (declare (uses pgdb))
 
 ;; (import pgdb) ;; pgdb is a module
+
+(declare (uses commonmod))
+(import commonmod)
+
+(declare (uses configfmod))
+(import configfmod)
+
+(declare (uses dbmod))
+(import dbmod)
 
 (include "task_records.scm")
 (include "db_records.scm")
 
 ;;======================================================================
@@ -187,32 +196,10 @@
 (define (tasks:hostinfo-get-hostname    vec)    (vector-ref  vec 6))
 
 (define (tasks:need-server run-id)
   (equal? (configf:lookup *configdat* "server" "required") "yes"))
 
-;; no elegance here ...
-;;
-(define (tasks:kill-server hostname pid #!key (kill-switch ""))
-  (debug:print-info 0 *default-log-port* "Attempting to kill server process " pid " on host " hostname)
-  (setenv "TARGETHOST" hostname)
-  (let* ((logdir (if (directory-exists? "logs")
-                    "logs/"
-                    ""))
-         (logfile (if logdir (conc "logs/server-"pid"-"hostname".log") #f))
-         (gzfile  (if logfile (conc logfile ".gz"))))
-    (setenv "TARGETHOST_LOGF" (conc logdir "server-kills.log"))
-
-    (system (conc "nbfake kill "kill-switch" "pid))
-
-    (when logfile
-      (thread-sleep! 0.5)
-      (if (common:file-exists? gzfile) (delete-file gzfile))
-      (system (conc "gzip " logfile))
-      
-      (unsetenv "TARGETHOST_LOGF")
-      (unsetenv "TARGETHOST"))))
-    
  
 ;;======================================================================
 ;; M O N I T O R S
 ;;======================================================================
 
@@ -279,30 +266,30 @@
      "SELECT count(id) FROM monitors WHERE last_update < (strftime('%s','now') - 300) AND username=?;"
      (car (user-information (current-user-id))))
     res))
 
 ;; 
-#;(define (tasks:start-monitor db mdb)
-  (if (> (tasks:get-num-alive-monitors mdb) 2) ;; have two running, no need for more
-      (debug:print-info 1 *default-log-port* "Not starting monitor, already have more than two running")
-      (let* ((megatestdb     (conc *toppath* "/megatest.db"))
-	     (monitordbf     (conc (db:dbfile-path #f) "/monitor.db"))
-	     (last-db-update 0)) ;; (file-modification-time megatestdb)))
-	(task:register-monitor mdb)
-	(let loop ((count      0)
-		   (next-touch 0)) ;; next-touch is the time where we need to update last_update
-	  ;; if the db has been modified we'd best look at the task queue
-	  (let ((modtime (file-modification-time megatestdbpath )))
-	    (if (> modtime last-db-update)
-		(tasks:process-queue db)) ;; BROKEN. mdb last-db-update megatestdb next-touch))
-	    ;; WARNING: Possible race conditon here!!
-	    ;; should this update be immediately after the task-get-action call above?
-	    (if (> (current-seconds) next-touch)
-		(begin
-		  (tasks:monitors-update mdb)
-		  (loop (+ count 1)(+ (current-seconds) 240)))
-		(loop (+ count 1) next-touch)))))))
+;; (define (tasks:start-monitor db mdb)
+;;   (if (> (tasks:get-num-alive-monitors mdb) 2) ;; have two running, no need for more
+;;       (debug:print-info 1 *default-log-port* "Not starting monitor, already have more than two running")
+;;       (let* ((megatestdb     (conc *toppath* "/megatest.db"))
+;; 	     (monitordbf     (conc (db:dbfile-path #f) "/monitor.db"))
+;; 	     (last-db-update 0)) ;; (file-modification-time megatestdb)))
+;; 	(task:register-monitor mdb)
+;; 	(let loop ((count      0)
+;; 		   (next-touch 0)) ;; next-touch is the time where we need to update last_update
+;; 	  ;; if the db has been modified we'd best look at the task queue
+;; 	  (let ((modtime (file-modification-time megatestdbpath )))
+;; 	    (if (> modtime last-db-update)
+;; 		(tasks:process-queue db)) ;; BROKEN. mdb last-db-update megatestdb next-touch))
+;; 	    ;; WARNING: Possible race conditon here!!
+;; 	    ;; should this update be immediately after the task-get-action call above?
+;; 	    (if (> (current-seconds) next-touch)
+;; 		(begin
+;; 		  (tasks:monitors-update mdb)
+;; 		  (loop (+ count 1)(+ (current-seconds) 240)))
+;; 		(loop (+ count 1) next-touch)))))))
       
 ;;======================================================================
 ;; T A S K S   Q U E U E
 ;;
 ;;   NOTE:: These operate on task_queue which is in main.db
@@ -443,23 +430,23 @@
   (db:with-db
    dbstruct #f #t
    (lambda (db)
      (sqlite3:execute db (conc "DELETE FROM tasks_queue WHERE id IN (" task-ids ");")))))
 
-#;(define (tasks:process-queue dbstruct)
-  (let* ((task   (tasks:snag-a-task dbstruct))
-	 (action (if task (tasks:task-get-action task) #f)))
-    (if action (print "tasks:process-queue task: " task))
-    (if action
-	(case (string->symbol action)
-	  ((run)       (tasks:start-run     dbstruct task))
-	  ((remove)    (tasks:remove-runs   dbstruct task))
-	  ((lock)      (tasks:lock-runs     dbstruct task))
-	  ;; ((monitor)   (tasks:start-monitor db task))
-	  #;((rollup)    (tasks:rollup-runs   dbstruct task))
-	  ((updatemeta)(tasks:update-meta   dbstruct task))
-	  #;((kill)      (tasks:kill-monitors dbstruct task))))))
+;; (define (tasks:process-queue dbstruct)
+;;   (let* ((task   (tasks:snag-a-task dbstruct))
+;; 	 (action (if task (tasks:task-get-action task) #f)))
+;;     (if action (print "tasks:process-queue task: " task))
+;;     (if action
+;; 	(case (string->symbol action)
+;; 	  ((run)       (tasks:start-run     dbstruct task))
+;; 	  ((remove)    (tasks:remove-runs   dbstruct task))
+;; 	  ((lock)      (tasks:lock-runs     dbstruct task))
+;; 	  ;; ((monitor)   (tasks:start-monitor db task))
+;; 	  #;((rollup)    (tasks:rollup-runs   dbstruct task))
+;; 	  ((updatemeta)(tasks:update-meta   dbstruct task))
+;; 	  #;((kill)      (tasks:kill-monitors dbstruct task))))))
 
 (define (tasks:tasks->text tasks)
   (let ((fmtstr "~10a~10a~10a~12a~20a~12a~12a~10a"))
     (conc (format #f fmtstr "id" "action" "owner" "state" "target" "runname" "testpatts" "params") "\n"
 	  (string-intersperse 
@@ -518,20 +505,24 @@
 (define (tasks:find-task-queue-records dbstruct target run-name test-patt state-patt action-patt)
   ;; (handle-exceptions
   ;;  exn
   ;;  '()
   ;;  (sqlite3:first-row
-  (let ((db (db:delay-if-busy (db:get-db dbstruct)))
-	(res '()))
-    (sqlite3:for-each-row 
-     (lambda (a . b)
-       (set! res (cons (cons a b) res)))
-     db "SELECT id,action,owner,state,target,name,testpatt,keylock,params FROM tasks_queue 
+  (let (;; (db  (db:get-db dbstruct))
+  	(res '()))
+    (db:with-db
+     dbstruct #f #t
+     (lambda (db)
+       (sqlite3:for-each-row 
+	(lambda (a . b)
+	  (set! res (cons (cons a b) res)))
+	db
+	"SELECT id,action,owner,state,target,name,testpatt,keylock,params FROM tasks_queue 
            WHERE
               target = ? AND name = ? AND state LIKE ? AND action LIKE ? AND testpatt LIKE ?;"
-     target run-name state-patt action-patt test-patt)
-    res)) ;; )
+	target run-name state-patt action-patt test-patt)
+       res)))) ;; )
 
 ;; kill any runner processes (i.e. processes handling -runtests) that match target/runname
 ;; 
 ;; do a remote call to get the task queue info but do the killing as self here.
 ;;

Index: tcmt.scm
==================================================================
--- tcmt.scm
+++ tcmt.scm
@@ -30,10 +30,13 @@
 
 (declare (uses margs))
 (declare (uses rmt))
 (declare (uses common))
 ;; (declare (uses megatest-version))
+
+(declare (uses commonmod))
+(import commonmod)
 
 (include "megatest-version.scm")
 (include "megatest-fossil-hash.scm")
 (include "db_records.scm")
 

Index: tdb.scm
==================================================================
--- tdb.scm
+++ tdb.scm
@@ -27,15 +27,22 @@
 (import (prefix sqlite3 sqlite3:))
 (import (prefix base64 base64:))
 
 (declare (unit tdb))
 (declare (uses common))
-(declare (uses keys))
-(declare (uses ods))
 (declare (uses client))
 (declare (uses mt))
 (declare (uses db))
+
+(declare (uses commonmod))
+(import commonmod)
+
+(declare (uses dbmod))
+(import dbmod)
+
+(declare (uses ods))
+(import ods)
 
 (include "common_records.scm")
 (include "db_records.scm")
 (include "key_records.scm")
 (include "run_records.scm")
@@ -43,10 +50,51 @@
 ;;======================================================================
 ;;
 ;; T E S T   D A T A B A S E S
 ;;
 ;;======================================================================
+;;======================================================================
+;; S T E P S 
+;;======================================================================
+
+;; Run steps
+;; make-vector-record "Run steps" db step id test_id stepname step_complete step_pass event_time    
+(define (make-db:step)(make-vector 9))
+(define (tdb:step-get-id              vec)    (vector-ref  vec 0))
+(define (tdb:step-get-test_id         vec)    (vector-ref  vec 1))
+(define (tdb:step-get-stepname        vec)    (vector-ref  vec 2))
+(define (tdb:step-get-state           vec)    (vector-ref  vec 3))
+(define (tdb:step-get-status          vec)    (vector-ref  vec 4))
+(define (tdb:step-get-event_time      vec)    (vector-ref  vec 5))
+(define (tdb:step-get-logfile         vec)    (vector-ref  vec 6))
+(define (tdb:step-get-comment         vec)    (vector-ref  vec 7))
+(define (tdb:step-get-last_update     vec)    (vector-ref  vec 8))
+(define (tdb:step-set-id!             vec val)(vector-set! vec 0 val))
+(define (tdb:step-set-test_id!        vec val)(vector-set! vec 1 val))
+(define (tdb:step-set-stepname!       vec val)(vector-set! vec 2 val))
+(define (tdb:step-set-state!          vec val)(vector-set! vec 3 val))
+(define (tdb:step-set-status!         vec val)(vector-set! vec 4 val))
+(define (tdb:step-set-event_time!     vec val)(vector-set! vec 5 val))
+(define (tdb:step-set-logfile!        vec val)(vector-set! vec 6 val))
+(define (tdb:step-set-comment!        vec val)(vector-set! vec 7 val))
+
+
+;; The steps table
+(define (make-db:steps-table)(make-vector 5))
+(define (tdb:steps-table-get-stepname   vec)    (vector-ref  vec 0))
+(define (tdb:steps-table-get-start      vec)    (vector-ref  vec 1))
+(define (tdb:steps-table-get-end        vec)    (vector-ref  vec 2))
+(define (tdb:steps-table-get-status     vec)    (vector-ref  vec 3))
+(define (tdb:steps-table-get-runtime    vec)    (vector-ref  vec 4))
+(define (tdb:steps-table-get-log-file   vec)    (vector-ref  vec 5))
+
+(define (tdb:step-stable-set-stepname!  vec val)(vector-set! vec 0 val))
+(define (tdb:step-stable-set-start!     vec val)(vector-set! vec 1 val))
+(define (tdb:step-stable-set-end!       vec val)(vector-set! vec 2 val))
+(define (tdb:step-stable-set-status!    vec val)(vector-set! vec 3 val))
+(define (tdb:step-stable-set-runtime!   vec val)(vector-set! vec 4 val))
+
 
 ;;======================================================================
 ;; T E S T   S P E C I F I C   D B 
 ;;======================================================================
 
@@ -240,14 +288,10 @@
 	  (loop (read-line)))))
   ;; roll up the current results.
   ;; FIXME: Add the status too 
   (rmt:test-data-rollup run-id test-id #f))
 
-(define (tdb:get-prev-tol-for-test tdb test-id category variable)
-  ;; Finish me?
-  (values #f #f #f))
-
 ;;======================================================================
 ;; S T E P S 
 ;;======================================================================
 
 (define (tdb:step-get-time-as-string vec)

Index: tests.scm
==================================================================
--- tests.scm
+++ tests.scm
@@ -25,20 +25,29 @@
 (declare (unit tests))
 (declare (uses lock-queue))
 (declare (uses db))
 (declare (uses tdb))
 (declare (uses common))
-;; (declare (uses dcommon)) ;; needed for the steps processing
 (declare (uses items))
 (declare (uses runconfig))
-;; (declare (uses sdb))
 (declare (uses server))
-;;(declare (uses stml2))
 
 (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils)
 (import (prefix sqlite3 sqlite3:))
 (require-library stml)
+
+(declare (uses commonmod))
+(import commonmod)
+
+(declare (uses dbmod))
+(import dbmod)
+
+(declare (uses configfmod))
+(import configfmod)
+
+(declare (uses servermod))
+(import servermod)
 
 (include "common_records.scm")
 (include "key_records.scm")
 (include "db_records.scm")
 (include "run_records.scm")
@@ -46,10 +55,108 @@
 (include "js-path.scm")
 
 (define (init-java-script-lib)
   (set! *java-script-lib* (conc  (common:get-install-area) "/share/js/jquery-3.1.0.slim.min.js"))
   )
+
+
+;;======================================================================
+;; Stuff from http-transport
+;;======================================================================
+
+;;===============================================
+;; Java script
+;;===============================================
+(define (http-transport:show-jquery)
+  (let* ((data  (tests:readlines *java-script-lib*)))
+(string-join data "\n")))
+
+;;======================================================================
+;; web pages
+;;======================================================================
+
+(define (http-transport:html-test-log $)
+   (let* ((run-id ($ 'runid))
+         (test-item ($ 'testname))
+         (parts (string-split test-item ":"))
+         (test-name (car parts))
+             
+         (item-name (if (equal? (length parts) 1)
+             ""
+             (cadr parts))))
+  ;(print $) 
+(tests:get-test-log run-id test-name item-name)))
+
+
+(define (http-transport:html-dboard $)
+  (let* ((page ($ 'page))
+         (oup       (open-output-string)) 
+         (bdy "--------------------------")
+
+         (ret  (tests:dynamic-dboard page)))
+    (s:output-new  oup  ret)
+   (close-output-port oup)
+
+  (set! bdy   (get-output-string oup))
+     (conc "<h1>Dashboard</h1>" bdy "<br/> <br/> "  )))
+
+(define (http-transport:main-page)
+  (let ((linkpath (root-path)))
+    (conc "<head><h1>" (pathname-strip-directory *toppath*) "</h1></head>"
+	  "<body>"
+	  "Run area: " *toppath*
+	  "<h2>Server Stats</h2>"
+	  (http-transport:stats-table) 
+	  "<hr>"
+	  (http-transport:runs linkpath)
+	  "<hr>"
+	  ;; (http-transport:run-stats)
+	  "</body>"
+	  )))
+
+(define (http-transport:stats-table)
+  (mutex-lock! *heartbeat-mutex*)
+  (let ((res 
+	 (conc "<table>"
+	       ;; "<tr><td>Max cached queries</td>        <td>" *max-cache-size* "</td></tr>"
+	       "<tr><td>Number of cached writes</td>   <td>" *number-of-writes* "</td></tr>"
+	       "<tr><td>Average cached write time</td> <td>" (if (eq? *number-of-writes* 0)
+								 "n/a (no writes)"
+								 (/ *writes-total-delay*
+								    *number-of-writes*))
+	       " ms</td></tr>"
+	       "<tr><td>Number non-cached queries</td> <td>"  *number-non-write-queries* "</td></tr>"
+	       ;; "<tr><td>Average non-cached time</td>   <td>" (if (eq? *number-non-write-queries* 0)
+	       ;; 							 "n/a (no queries)"
+	       ;; 							 (/ *total-non-write-delay* 
+	       ;; 							    *number-non-write-queries*))
+	       " ms</td></tr>"
+	       "<tr><td>Last access</td><td>"              (seconds->time-string *db-last-access*) "</td></tr>"
+	       "</table>")))
+    (mutex-unlock! *heartbeat-mutex*)
+    res))
+
+(define (http-transport:runs linkpath)
+  (conc "<h3>Runs</h3>"
+	(string-intersperse
+	 (let ((files (map pathname-strip-directory (glob (conc linkpath "/*")))))
+	   (map (lambda (p)
+		  (conc "<a href=\"" p "\">" p "</a><br>"))
+		files))
+	 " ")))
+
+#;(define (http-transport:run-stats)
+  (let ((stats (open-run-close db:get-running-stats #f)))
+    (conc "<table>"
+	  (string-intersperse
+	   (map (lambda (stat)
+		  (conc "<tr><td>" (car stat) "</td><td>" (cadr stat) "</td></tr>"))
+		stats)
+	   " ")
+	  "</table>")))
+
+
 
 ;; Call this one to do all the work and get a standardized list of tests
 ;;   gets paths from configs and finds valid tests 
 ;;   returns hash of testname --> fullpath
 ;;
@@ -119,27 +226,10 @@
 		'())
 	    (if itemmap-table
 		itemmap-table
 		'()))))
 
-;; given a list of itemmaps (testname . map), return the first match
-;;
-(define (tests:lookup-itemmap itemmaps testname)
-  (let ((best-matches (filter (lambda (itemmap)
-				(tests:match (car itemmap) testname #f))
-			      itemmaps)))
-    (if (null? best-matches)
-	#f
-	(let ((res (car best-matches)))
-	  ;; (debug:print 0 *default-log-port* "res=" res)
-	  (cond
-	   ((string? res) res) ;;; FIX THE ROOT CAUSE HERE ....
-	   ((null? res)   #f)
-	   ((string? (cdr res)) (cdr res))  ;; it is a pair
-	   ((string? (cadr res))(cadr res)) ;; it is a list
-	   (else cadr res))))))
-
 ;; return items given config
 ;;
 (define (tests:get-items tconfig)
   (let ((items      (hash-table-ref/default tconfig "items" #f)) ;; items 4
 	(itemstable (hash-table-ref/default tconfig "itemstable" #f))) 
@@ -272,84 +362,10 @@
            (new-patts (if (member waiton-test patts)
                           patts
                           (cons waiton-test patts))))
       (string-intersperse (delete-duplicates new-patts) ",")))))
 
-(define *glob-like-match-cache* (make-hash-table))
-(define (tests:cache-regexp str-in flag)
-  (let* ((key (conc str-in flag)))
-    (or (hash-table-ref/default *glob-like-match-cache* key #f)
-	(let* ((newrx (regexp str-in flag)))
-	  (hash-table-set! *glob-like-match-cache* key newrx)
-	  newrx))))
-
-;; tests:glob-like-match 
-(define (tests:glob-like-match patt str) 
-  (let* ((like     (substring-index "%" patt))
-	 (notpatt  (equal? (substring-index "~" patt) 0))
-	 (newpatt  (if notpatt (substring patt 1) patt))
-	 (finpatt  (if like
-		       (string-substitute (regexp "%") ".*" newpatt #f)
-		       (string-substitute (regexp "\\*") ".*" newpatt #f)))
-	 (rx       (tests:cache-regexp finpatt (if like #t #f)))
-	 (res      (string-match rx str)))
-    (if notpatt (not res) res)))
-
-;; if itempath is #f then look only at the testname part
-;;
-(define (tests:match patterns testname itempath #!key (required '()))
-  (if (string? patterns)
-      (let ((patts (append (string-split patterns ",") required)))
-	(if (null? patts) ;;; no pattern(s) means no match
-	    #f
-	    (let loop ((patt (car patts))
-		       (tal  (cdr patts)))
-	      ;; (print "loop: patt: " patt ", tal " tal)
-	      (if (string=? patt "")
-		  #f ;; nothing ever matches empty string - policy
-		  (let* ((patt-parts (string-match (regexp "^([^\\/]*)(\\/(.*)|)$") patt))
-			 (test-patt  (cadr patt-parts))
-			 (item-patt  (cadddr patt-parts)))
-		    ;; special case: test vs. test/
-		    ;;   test  => "test" "%"
-		    ;;   test/ => "test" ""
-		    (if (and (not (substring-index "/" patt)) ;; no slash in the original
-			     (or (not item-patt)
-				 (equal? item-patt "")))      ;; should always be true that item-patt is ""
-			(set! item-patt "%"))
-		    ;; (print "tests:match => patt-parts: " patt-parts ", test-patt: " test-patt ", item-patt: " item-patt)
-		    (if (and (tests:glob-like-match test-patt testname)
-			     (or (not itempath)
-				 (tests:glob-like-match (if item-patt item-patt "") itempath)))
-			#t
-			(if (null? tal)
-			    #f
-			    (loop (car tal)(cdr tal)))))))))))
-
-;; if itempath is #f then look only at the testname part
-;;
-(define (tests:match->sqlqry patterns)
-  (if (string? patterns)
-      (let ((patts (string-split patterns ",")))
-	(if (null? patts) ;;; no pattern(s) means no match, we will do no query
-	    #f
-	    (let loop ((patt (car patts))
-		       (tal  (cdr patts))
-		       (res  '()))
-	      ;; (print "loop: patt: " patt ", tal " tal)
-	      (let* ((patt-parts (string-match (regexp "^([^\\/]*)(\\/(.*)|)$") patt))
-		     (test-patt  (cadr patt-parts))
-		     (item-patt  (cadddr patt-parts))
-		     (test-qry   (db:patt->like "testname" test-patt))
-		     (item-qry   (db:patt->like "item_path" item-patt))
-		     (qry        (conc "(" test-qry " AND " item-qry ")")))
-		;; (print "tests:match => patt-parts: " patt-parts ", test-patt: " test-patt ", item-patt: " item-patt)
-		(if (null? tal)
-		    (string-intersperse (append (reverse res)(list qry)) " OR ")
-		    (loop (car tal)(cdr tal)(cons qry res)))))))
-      #f))
-
 ;; Check for waiver eligibility
 ;;
 (define (tests:check-waiver-eligibility testdat prev-testdat)
   (let* ((test-registry (make-hash-table))
 	 (testconfig  (tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f))
@@ -1712,15 +1728,17 @@
       (format temp-port "  size=4,8\n")
       ;; (format temp-port "   splines=none\n")
       (for-each
        (lambda (testname)
 	 (let* ((testrec (hash-table-ref test-records testname))
-		(waitons (or (tests:testqueue-get-waitons testrec) '())))
+		(waitons (or (tests:testqueue-get-waitons testrec) '()))
+		(my-mt-waitons (tests:get-mt-waitons testname #t)))
+	   ;; (print "my-mt-waitons=" my-mt-waitons)
 	   (for-each
 	    (lambda (waiton)
 	      (format temp-port (conc "   " waiton " -> " testname " [splines=ortho]\n")))
-	    waitons)))
+	    (append waitons my-mt-waitons))))
        all-testnames)
       (format temp-port "}\n")
       (close-output-port temp-port)
       (with-input-from-pipe
        (conc "env -i PATH=$PATH dot -T" outtype " < " temp-path)
@@ -1745,17 +1763,19 @@
 			      (conc " size=\"" (or sizex 11) "," (or sizey 11) "\";")
 			      " ratio=0.95;"
 			      )))
 	  (let* ((testrec (hash-table-ref test-records hed))
 		 (waitons (or (tests:testqueue-get-waitons testrec) '()))
+		 (my-mt-waitons (tests:get-mt-waitons hed #t))
+		 (all-waitons   (delete-duplicates (append waitons my-mt-waitons)))
 		 (newres  (append res
-				  (if (null? waitons)
+				  (if (null? all-waitons)
 				      (list (conc "   \"" hed "\" [shape=box];"))
 				      (map (lambda (waiton)
 					     (conc "   \"" waiton "\" -> \"" hed "\" [shape=box];"))
-					   waitons)
-				      ))))
+					   all-waitons)))))
+	    ;; (debug:print 0 *default-log-port* "For test "hed" got "all-waitons)
 	    (if (null? tal)
 		(append newres (list "}"))
 		(loop (car tal)(cdr tal) newres)
 		))))))
 

Index: tests/unittests/all-api.scm
==================================================================
--- tests/unittests/all-api.scm
+++ tests/unittests/all-api.scm
@@ -52,11 +52,12 @@
 ;;    Delete these API functions after checking that they are not called?
 ;;    Comment them out and give a date to delete. (in the refactor branch?)
 
 ;; 4. get-tests-times:  no such query supported in api.scm, but it is in the list of read-only queries. Remove it? Or implement it if it's in db.scm?
 
-
+(import commonmod)
+(import dbmod)
 (define my-dbstruct (db:setup #t))
 (define toppath (current-directory))
 (define keypatts '(("SYSTEM" "ubuntu")("RELEASE" "v1.234")) )
 (define keys (db:get-keys my-dbstruct))
 
@@ -116,11 +117,11 @@
 (test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'delete-run (list 2))) 0)) ;; delete a non-existant run
 (test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'update-run-stats (list 1 '()))) 0))
 (test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-main-run-stats (list 1 ))) 0))
 (test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'delete-old-deleted-test-records '())) 0))
 (test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-runs (list "%" 10 0 keypatts))) 0))
-(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'simple-get-runs (list "%" 10 0 keypatts))) 0))
+(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'simple-get-runs (list "%" 10 0 keypatts 0))) 0))
 (test #f #(#t (1))(api:execute-requests my-dbstruct (vector 'get-all-run-ids '())))
 (test #f #(#t ()) (api:execute-requests my-dbstruct (vector 'get-prev-run-ids '(1))))
 (test #f #(#t "JUSTFINE") (api:execute-requests my-dbstruct (vector 'get-run-status '(1))))
 (test #f #(#t "NEW") (api:execute-requests my-dbstruct (vector 'get-run-state '(1))))
 (test #f #(#t (("Totals" "UNKNOWN" 1) ("bar" "UNKNOWN" 1))) (api:execute-requests my-dbstruct (vector 'get-run-stats '())))

Index: tests/unittests/all-rmt.scm
==================================================================
--- tests/unittests/all-rmt.scm
+++ tests/unittests/all-rmt.scm
@@ -28,40 +28,67 @@
 ;; Definitions:
 ;;   NTN - no test needed
 ;;   DEP - function is deprecated, no point in testing
 ;;   NED - function nested under others, no test needed.
 ;;   DEF - deferred
+
+(import commonmod)
+(import dbmod)
+(import rmtmod)
+(use matchable)
+
+(use trace)
+(trace
+ rmt:login
+ db:login
+ rmt:send-receive
+ rmt:send-receive-no-auto-client-setup
+ rmtmod:calc-ro-mode
+ create-remote-record
+ rmt:open-qry-close-locally
+ common:force-server?
+ server:check-if-running
+ server:record->id
+ extras-case-11
+ extras-transport-failed
+ extras-transport-succeded
+ http-transport:close-connections
+ http-transport:client-api-send-receive
+ )
 
 (print "start dir: " (current-directory))
        
 (define toppath (current-directory))
 
 (test #f #f (server:check-if-running toppath))           ;; these are used by server:start-and-wait
 (test #f #t (list? (server:get-list toppath)))
 (test #f '() (server:get-best '()))
+(test #f '() (server:get-rand-best toppath))
 (test #f #t (common:simple-file-lock-and-wait "test.lock" expire-time: 15))
 (test #f "test.lock" (common:simple-file-release-lock "test.lock"))
-(test #f #t (server:get-best-guess-address (get-host-name)))
-(test #f #t (string? (common:get-homehost)))
+(test #f #t (string? (server:get-best-guess-address (get-host-name))))
+(test #f #t (string? (car (common:get-homehost))))
 
 ;; clean out any old running servers
 ;;
 (let ((servers (server:get-list toppath)))
   (print "Known servers: "  servers)
   (if (not (null? servers))
       (begin
 	(for-each
 	 (lambda (server)
-	   (let ((pid (list-ref server 4)))
+	   (let ((pid (list-ref server 2)))
 	     (thread-start!
 	      (make-thread
 	       (lambda ()
-		 (print "Attempting to kill server: " server)
-		 (print "Attempting to kill pid " pid)
-		 (system (conc "kill " pid))
-		 (thread-sleep! 2)
-		 (system (conc "kill -9 " pid)))
+		 (if (number? pid)
+		     (begin
+		       (print "Attempting to kill server: " server)
+		       (print "Attempting to kill pid " pid)
+		       (system (conc "kill " pid))
+		       (thread-sleep! 2)
+		       (system (conc "kill -9 " pid)))))
 	       (conc pid)))))
 	 servers)
 	(thread-sleep! 2))))
 ;; let's start up a server the mechanical way
 (system "nbfake megatest -server -")
@@ -68,18 +95,19 @@
 (thread-sleep! 2)
 ;; (test #f #t (string? (server:start-and-wait *toppath*)))
 
 (test "setup for run" #t (begin (launch:setup)
  				(string? (getenv "MT_RUN_AREA_HOME"))))
-(test #f #t (client:setup-http toppath))
+(test #f #t (string? (vector-ref (client:setup-http toppath) 0)))
 (test #f #t (vector? (client:setup toppath)))
 
 (test #f #t (vector? (rmt:get-connection-info toppath))) ;; TODO: push areapath down.
-(test #f #t (string? (server:check-if-running ".")))
+(test #f #t (list? (server:check-if-running toppath)))
 ;; DEF (test #f #f (rmt:send-receive-no-auto-client-setup *runremote* 'get-keys #f '()))
 ;; DEF (rmt:kill-server run-id)
 ;; DEF (rmt:start-server run-id)
+(test #f #t (string? (client:get-signature)))
 (test #f '(#t "successful login")(rmt:login #f))
 ;; DEF (rmt:login-no-auto-client-setup connection-info)
 (test #f #t (pair? (rmt:get-latest-host-load (get-host-name))))
 
 ;; get-latest-host-load does a lookup in the db, it won't return a useful value unless

DELETED trackback.scm
Index: trackback.scm
==================================================================
--- trackback.scm
+++ /dev/null
@@ -1,53 +0,0 @@
-;;  Copyright 2006-2017, Matthew Welland.
-;; 
-;; This file is part of Megatest.
-;; 
-;;     Megatest is free software: you can redistribute it and/or modify
-;;     it under the terms of the GNU General Public License as published by
-;;     the Free Software Foundation, either version 3 of the License, or
-;;     (at your option) any later version.
-;; 
-;;     Megatest is distributed in the hope that it will be useful,
-;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;     GNU General Public License for more details.
-;; 
-;;     You should have received a copy of the GNU General Public License
-;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
-
-(include "codescanlib.scm")
-
-;; show call paths for named procedure
-(define (traceback-proc in-procname)
-  (letrec* ((all-scm-files (glob "*.scm"))
-            (xref (get-xref all-scm-files))
-            (have (alist-ref (string->symbol in-procname) xref eq? #f))
-            (lookup (lambda (path procname depth)
-                      (let* ((upcone-temp (filter (lambda (x)
-                                                    (eq? procname (car x)))
-                                                  xref))
-                             (upcone-temp2 (cond
-                                            ((null? upcone-temp) '())
-                                            (else (cdar upcone-temp))))
-                             (upcone (filter
-                                      (lambda (x) (not (eq? x procname)))
-                                      upcone-temp2))
-                             (uppath (cons procname path))
-                             (updepth (add1 depth)))
-                        (if (null? upcone)
-                            (print  uppath)
-                            (for-each (lambda (x)
-                                        (if (not (member procname path))
-                                            (lookup uppath x updepth) ))
-                                      upcone))))))
-           (if have
-               (lookup '() (string->symbol in-procname) 0)
-               (print "no such func - "in-procname))))
-
-
-(if (eq? 1 (length (command-line-arguments)))
-    (traceback-proc (car (command-line-arguments)))
-    (print "Usage: trackback <procedure name>"))
-
-(exit 0)
-    

Index: tree.scm
==================================================================
--- tree.scm
+++ tree.scm
@@ -33,125 +33,18 @@
 (declare (uses gutils))
 (declare (uses db))
 (declare (uses server))
 ;; (declare (uses synchash))
 (declare (uses dcommon))
+
+(declare (uses commonmod))
+(import commonmod)
+
+(declare (uses dbmod))
+(import dbmod)
+
 
 (include "megatest-version.scm")
 (include "common_records.scm")
 (include "db_records.scm")
 (include "key_records.scm")
 
-;;======================================================================
-;; T R E E   S T U F F 
-;;======================================================================
-
-;; path is a list of nodes, each the child of the previous
-;; this routine returns the id so another node can be added
-;; either as a leaf or as a branch
-;;
-;; BUG: This needs a stop sensor for when a branch is exhausted
-;;
-(define (tree:find-node obj path)
-  ;; start at the base of the tree
-  (if (null? path)
-      #f ;; or 0 ????
-      (let loop ((hed      (car path))
-		 (tal      (cdr path))
-		 (depth    0)
-		 (nodenum  0))
-	;; nodes in iup tree are 100% sequential so iterate over nodenum
-	(if (iup:attribute obj (conc "DEPTH" nodenum)) ;; end when no more nodes
-	    (let ((node-depth (string->number (iup:attribute obj (conc "DEPTH" nodenum))))
-		  (node-title (iup:attribute obj (conc "TITLE" nodenum))))
-	      (if (and (equal? depth node-depth)
-		       (equal? hed   node-title)) ;; yep, this is the one!
-		  (if (null? tal) ;; end of the line
-		      nodenum
-		      (loop (car tal)(cdr tal)(+ depth 1)(+ 1 nodenum)))
-		  ;; this is the case where we found part of the hierarchy but not 
-		  ;; all of it, i.e. the node-depth went from deep to less deep
-		  (if (> depth node-depth) ;; (+ 1 node-depth))
-		      #f
-		      (loop hed tal depth (+ nodenum 1)))))
-	    #f))))
-
-;; top is the top node name zeroeth node VALUE=0
-(define (tree:add-node obj top nodelst #!key (userdata #f))
-  (let ((curr-top (iup:attribute obj "TITLE0")))
-    (if (or (not (string? curr-top))
-	    (string-null? curr-top)
-	    (string-match "^\\s*$" curr-top))
-          (iup:attribute-set! obj "ADDBRANCH0" top))
-
-
-    
-    (cond
-     ((not (equal? top (iup:attribute obj "TITLE0")))
-      (print "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0")))
-     ((null? nodelst))
-     (else
-      (let loop ((hed      (car nodelst))
-		 (tal      (cdr nodelst))
-		 (depth    1)
-		 (pathl    (list top)))
-	;; Because the tree dialog changes node numbers when
-	;; nodes are added or removed we must look up nodes
-	;; each and every time. 0 is the top node so default
-	;; to that.
-	(let* ((newpath    (append pathl (list hed)))
-	       (parentnode (tree:find-node obj pathl))
-	       (nodenum    (tree:find-node obj newpath)))
-	  ;; Add the branch under lastnode if not found
-	  (if (not nodenum)
-	      (begin
-		(iup:attribute-set! obj (conc "ADDBRANCH" parentnode) hed)
-		;; ERROR? ADDING DATA TO PARENT, DONT WE WANT IT ON CREATED NODE?
-		(if userdata
-		    (iup:attribute-set! obj (conc "USERDATA"   parentnode) userdata))
-		(if (null? tal)
-		    #t
-		    ;; reset to top
-		    (loop (car nodelst)(cdr nodelst) 1 (list top)))) 
-	      (if (null? tal) ;; if null here then this path has already been added
-		  #t
-		  (loop (car tal)(cdr tal)(+ depth 1) newpath)))))))))
-
-(define (tree:node->path obj nodenum)
-  (let loop ((currnode 0)
-	     (path     '()))
-    (let* ((node-depth (string->number (iup:attribute obj (conc "DEPTH" currnode))))
-	   (node-title (iup:attribute obj (conc "TITLE" currnode)))
-	   (trimpath   (if (and (not (null? path))
-				(> (length path) node-depth))
-			   (take path node-depth)
-			   path))
-	   (newpath    (append trimpath (list node-title))))
-      (if (>= currnode nodenum)
-	  newpath
-	  (loop (+ currnode 1)
-		newpath)))))
-
-(define (tree:delete-node obj top node-path) ;; node-path is a list of strings
-  (let ((id  (tree:find-node obj (cons top node-path))))
-    (print "Found node to remove " id " for path " top " " node-path)
-    (iup:attribute-set! obj (conc "DELNODE" id) "SELECTED")))
-	
-#|
-
-  (let* ((tb      (iup:treebox
-                   #:value 0
-                   #:name "Runs"
-                   #:expand "YES"
-                   #:addexpanded "NO"
-                   #:selection-cb
-                   (lambda (obj id state)
-                     ;; (print "obj: " obj ", id: " id ", state: " state)
-                     (let* ((run-path (tree:node->path obj id))
-                            (run-id   (tree-path->run-id (cdr run-path))))
-                       (if run-id
-                           (begin
-                             (dboard:data-curr-run-id-set! data run-id)
-                             (dashboard:update-run-summary-tab)))
-                       ;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
-                       ))))
-|#

ADDED   utils/codescanlib.scm
Index: utils/codescanlib.scm
==================================================================
--- /dev/null
+++ utils/codescanlib.scm
@@ -0,0 +1,144 @@
+;;  Copyright 2006-2017, Matthew Welland.
+;; 
+;; This file is part of Megatest.
+;; 
+;;     Megatest is free software: you can redistribute it and/or modify
+;;     it under the terms of the GNU General Public License as published by
+;;     the Free Software Foundation, either version 3 of the License, or
+;;     (at your option) any later version.
+;; 
+;;     Megatest is distributed in the hope that it will be useful,
+;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;     GNU General Public License for more details.
+;; 
+;;     You should have received a copy of the GNU General Public License
+;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
+;;
+
+;; gotta compile with csc, doesn't work with csi -s for whatever reason
+
+(use srfi-69)
+(use matchable)
+(use utils)
+(use ports)
+(use extras)
+(use srfi-1)
+(use posix)
+(use srfi-12)
+
+;; turn scheme file to a list of sexps, sexps of interest will be in the form of (define (<procname> <args>) <body> )
+(define (load-scm-file scm-file)
+  ;;(print "load "scm-file)
+  (handle-exceptions
+   exn
+   '()
+   (with-input-from-string
+       (conc "("
+             (with-input-from-file scm-file read-all)
+             ")" )
+     read)))
+
+;; extract a list of procname, filename, args and body of procedures defined in filename, input from load-scm-file
+;;   -- be advised:
+;;      * this may be fooled by macros, since this code does not take them into account.
+;;      * this code does only checks for form (define (<procname> ... ) <body>)
+;;           so it excludes from reckoning
+;;               - generated functions, as in things like foo-set! from defstructs,
+;;               - define-inline, (
+;;               - define procname (lambda ..
+;;               - etc...
+(define (get-toplevel-procs+file+args+body filename)
+  (let* ((scm-tree (load-scm-file filename))
+         (procs
+          (filter identity
+                  (map
+                   (match-lambda 
+                    [('define ('uses args ...) body ...) #f] ;; filter out (define (uses ...
+                    [('define ('unit args ...) body ...) #f] ;; filter out (define (unit ...
+                    [('define ('prefix args ...) body ...) #f] ;; filter out (define (prefix ...
+                    [('define (defname args ...) body ...) ;; match (define (procname <args>) <body>)
+                     (if (atom? defname) ;; filter out things we dont understand (procname is a list, what??)
+                         (list defname filename args body)
+                         #f)]
+                    [else #f] ) scm-tree))))
+    procs))
+
+
+;; given a sexp, return a flat list of atoms in that sexp
+(define (get-atoms-in-body body)
+  (cond
+   ((null? body) '())
+   ((atom? body) (list body))
+   (else
+    (apply append (map get-atoms-in-body body)))))
+
+;;  given a file, return a list of procname, file, list of atoms in said procname
+(define (get-procs+file+atoms file)
+  (let* ((toplevel-proc-items (get-toplevel-procs+file+args+body file))
+         (res
+          (map
+           (lambda (item)
+             (let* ((proc (car item))
+                    (file (cadr item))
+                    (args (caddr item))
+                    (body (cadddr item))
+                    (atoms (append (get-atoms-in-body args) (get-atoms-in-body body))))
+               (list proc file atoms)))
+           toplevel-proc-items)))
+    res))
+
+;; uniquify a list of atoms 
+(define (unique-atoms lst)
+  (let loop ((lst (flatten lst)) (res '()))
+    (if (null? lst)
+        (reverse res)
+        (let ((c (car lst)))
+          (loop (cdr lst) (if (member c res) res (cons c res)))))))
+
+;; given a list of procname, filename, list of procs called from procname, cross reference and reverse
+;; returning alist mapping procname to procname that calls said procname
+(define (get-callers-alist all-procs+file+calls)
+  (let* ((all-procs (map car all-procs+file+calls))
+         (caller-ht (make-hash-table))) 
+    ;; let's cross reference with a hash table
+    (for-each (lambda (proc) (hash-table-set! caller-ht proc '())) all-procs)
+    (for-each (lambda (item)
+               (let* ((proc (car item))
+                      (file (cadr item))
+                      (calls (caddr item)))
+                 (for-each (lambda (callee)
+                             (hash-table-set! caller-ht callee
+                                              (cons proc
+                                                    (hash-table-ref caller-ht callee))))
+                           calls)))
+              all-procs+file+calls)
+    (map (lambda (x)
+           (let ((k (car x))
+                 (r (unique-atoms (cdr x))))
+             (cons k r)))                    
+         (hash-table->alist caller-ht))))
+
+;; create a handy cross-reference of callees to callers in the form of an alist.
+(define (get-xref all-scm-files)
+  (let* ((all-procs+file+atoms
+          (apply append (map get-procs+file+atoms all-scm-files)))
+         (all-procs (map car all-procs+file+atoms))
+         (all-procs+file+calls  ; proc calls things in calls list
+          (map (lambda (item)
+                 (let* ((proc (car item))
+                        (file (cadr item))
+                        (atoms (caddr item))
+                        (calls
+                         (filter identity
+                                 (map
+                                  (lambda (x)
+                                    (if (and ;; (not (equal? x proc))  ;; uncomment to prevent listing self
+                                         (member x all-procs))
+                                        x
+                                        #f))
+                                  atoms))))
+                   (list proc file calls)))
+               all-procs+file+atoms))
+         (callers (get-callers-alist all-procs+file+calls))) 
+    callers))

ADDED   utils/gendeps.scm
Index: utils/gendeps.scm
==================================================================
--- /dev/null
+++ utils/gendeps.scm
@@ -0,0 +1,107 @@
+;; (require-library iup canvas-draw)
+
+;; It'd be better to use codescan....
+
+(module gendeps
+   *
+	
+(import
+ scheme
+ chicken.base
+ chicken.string
+ chicken.process-context
+ chicken.file
+ chicken.io
+ chicken.port
+ scheme
+ ;;extras
+ regex
+ regex-case
+ matchable
+ srfi-69
+ )
+
+(define (portprint p . args)
+  (with-output-to-port p
+    (lambda ()
+      (apply print args))))
+
+(define (mofiles-adjust->dot-o inf)
+  (regex-case
+   inf
+   ("^.*mod$" _ (conc "mofiles/"inf".o"))
+   ("pgdb"    _ (conc "cgisetup/models/"inf".o"))
+   (else (conc inf".o"))))
+
+(define (compunit targfname files)
+  (let* ((unitdata   (make-hash-table))
+	 (moduledata (make-hash-table))
+	 (filesdata  (make-hash-table))
+	 (unitdec    (regexp "^\\(declare\\s+\\(unit\\s+([^\\s]+)\\)\\)"))
+	 (unituse    (regexp "^\\(declare\\s+\\(uses\\s+([^\\s]+)\\)\\)"))
+	 (moduledec  (regexp "^\\(module\\s+([\\s]+)"))
+	 (importuse  (regexp "^\\(import\\s+(.*)\\)")) ;; captures string of imports (one line)
+	 (dotport    (open-output-file (conc targfname ".dot")))
+	 (incport    (open-output-file (conc targfname ".inc")))
+	 )
+    (portprint dotport "digraph usedeps {")
+    (portprint incport "# To regenerate this file do:
+#   (cd utils/;ck52 csc gendeps.scm) && ./utils/gendeps allunits *scm
+#   cp allunits.inc build.inc
+#
+")
+    (for-each
+     (lambda (fname)
+       (let* ((sname (string-substitute "\\.scm$" "" fname)))
+	 (print "Processing "fname" with core name of "sname)
+	 (hash-table-set! filesdata sname fname) ;; record the existance of the src file
+	 (with-input-from-file fname
+	   (lambda ()
+	     (let loop ((inl (read-line)))
+	       (if (not (eof-object? inl))
+		   (begin
+		     (regex-case
+		      inl
+		      (unitdec   (_ unitname)
+				 (if (equal? sname unitname) ;; good if same
+				     (if (not (hash-table-exists? unitdata unitname))
+					 (hash-table-set! unitdata unitname (make-hash-table)))))
+		      (unituse   (_ usingname)
+				 (portprint dotport "\""usingname"\" -> \""sname"\"")
+				 (portprint incport
+					    (if (or (string-search ".import$" sname)
+						    (string-search ".import$" usingname))
+						"# "
+						"")
+					    (mofiles-adjust->dot-o sname)" : "
+					    (mofiles-adjust->dot-o usingname)))
+		      ;; (moduledec (_ modname)    (print "Module:   " modname))
+		      ;; (importuse (_ importname) (print "Imports: " importname))
+		      (else #f))
+		     (loop (read-line)))))))))
+     files)
+    (portprint dotport "}")
+    (close-output-port dotport)
+    (close-output-port incport)))
+
+;; seen is hash of seen functions
+
+(define usage "Usage: gendeps targfile files...
+")
+
+(define (main)
+  (match
+   (command-line-arguments)
+   (("help")(print usage))
+   ((targfile . files)
+    (compunit targfile files))
+   (else
+    (print "ERROR: Arguments not recognised.")
+    (print usage))))
+)
+
+(import
+ ;; (only iup show main-loop)
+ gendeps)
+
+(main)

ADDED   utils/trackback.scm
Index: utils/trackback.scm
==================================================================
--- /dev/null
+++ utils/trackback.scm
@@ -0,0 +1,53 @@
+;;  Copyright 2006-2017, Matthew Welland.
+;; 
+;; This file is part of Megatest.
+;; 
+;;     Megatest is free software: you can redistribute it and/or modify
+;;     it under the terms of the GNU General Public License as published by
+;;     the Free Software Foundation, either version 3 of the License, or
+;;     (at your option) any later version.
+;; 
+;;     Megatest is distributed in the hope that it will be useful,
+;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;     GNU General Public License for more details.
+;; 
+;;     You should have received a copy of the GNU General Public License
+;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
+
+(include "codescanlib.scm")
+
+;; show call paths for named procedure
+(define (traceback-proc in-procname)
+  (letrec* ((all-scm-files (glob "*.scm"))
+            (xref (get-xref all-scm-files))
+            (have (alist-ref (string->symbol in-procname) xref eq? #f))
+            (lookup (lambda (path procname depth)
+                      (let* ((upcone-temp (filter (lambda (x)
+                                                    (eq? procname (car x)))
+                                                  xref))
+                             (upcone-temp2 (cond
+                                            ((null? upcone-temp) '())
+                                            (else (cdar upcone-temp))))
+                             (upcone (filter
+                                      (lambda (x) (not (eq? x procname)))
+                                      upcone-temp2))
+                             (uppath (cons procname path))
+                             (updepth (add1 depth)))
+                        (if (null? upcone)
+                            (print  uppath)
+                            (for-each (lambda (x)
+                                        (if (not (member procname path))
+                                            (lookup uppath x updepth) ))
+                                      upcone))))))
+           (if have
+               (lookup '() (string->symbol in-procname) 0)
+               (print "no such func - "in-procname))))
+
+
+(if (eq? 1 (length (command-line-arguments)))
+    (traceback-proc (car (command-line-arguments)))
+    (print "Usage: trackback <procedure name>"))
+
+(exit 0)
+