Megatest

SHELL=/bin/bash
PREFIX=$(PWD)
CSCOPTS=
INSTALL=install
SRCFILES =

# all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut ndboard
all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtserve
# add dboard mtut and tcmt back later

# Configuration stuff
transport-flavor :
	@echo Creating transport-flavor with full as flavor. Options include: full, simple
	echo full > transport-flavor

ulex.scm dbmgrmod.scm : ulex.scm.template dbmgrmod.scm.template transport-flavor ulex-*/*scm
	./configure

# module source files
MSRCFILES = autoload.scm dbi.scm ducttape-lib.scm pkts.scm stml2.scm	\
            cookie.scm mutils.scm mtargs.scm apimod.scm	ulex.scm	\
            configfmod.scm commonmod.scm dbmod.scm rmtmod.scm		\
            debugprint.scm mtver.scm csv-xml.scm servermod.scm		\
            adjutant.scm processmod.scm testsmod.scm	\
            itemsmod.scm keysmod.scm mtmod.scm rmtmod.scm		\
            tasksmod.scm pgdb.scm launchmod.scm runsmod.scm		\
            portloggermod.scm archivemod.scm ezstepsmod.scm		\
            subrunmod.scm bigmod.scm testsmod.scm dbmgrmod.scm



GUIMODFILES = tree.scm dashboard-tests.scm  vgmod.scm \
              dashboard-context-menu.scm dcommon.scm 



mofiles/dashboard-context-menu.o : mofiles/dcommon.o
mofiles/dashboard-tests.o : mofiles/dcommon.o


OFILES   = $(SRCFILES:%.scm=%.o)


MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o))
GMOFILES = $(addprefix mofiles/,$(GUIMODFILES:%.scm=%.o))

# compiled import files
MOIMPFILES = $(MSRCFILES:%.scm=%.import.o)
GMOIMPFILES = $(GUIMODFILES:%.scm=%.import.o)

mofiles/bigmod.o : mofiles/configfmod.o
mofiles/bigmod.o : mofiles/dbmod.o
mofiles/bigmod.o : mofiles/rmtmod.o
# mofiles/clientmod.o : mofiles/servermod.oibpq-dev
mofiles/commonmod.o : megatest-fossil-hash.scm
mofiles/commonmod.o : mofiles/configfmod.o
mofiles/commonmod.o : mofiles/debugprint.o

mofiles/commonmod.o : mofiles/keysmod.o
mofiles/commonmod.o : mofiles/mtargs.o
mofiles/commonmod.o : mofiles/mtver.o
mofiles/commonmod.o : mofiles/processmod.o
mofiles/configfmod.o : mofiles/keysmod.o
mofiles/dbimod.o : mofiles/autoload.o
mofiles/dbmod.o : mofiles/commonmod.o

mofiles/launchmod.o : mofiles/bigmod.o
mofiles/launchmod.o : mofiles/ezstepsmod.o
mofiles/launchmod.o : mofiles/rmtmod.o mofiles/servermod.o
mofiles/mtmod.o : mofiles/debugprint.o
mofiles/portloggermod.o : mofiles/tasksmod.o
mofiles/rmtmod.o : mofiles/apimod.o
mofiles/rmtmod.o : mofiles/commonmod.o mofiles/portloggermod.o
mofiles/rmtmod.o : mofiles/itemsmod.o mofiles/ulex.o
mofiles/rmtmod.o : mofiles/dbmgrmod.o
mofiles/runsmod.o : mofiles/rmtmod.o mofiles/archivemod.o
mofiles/servermod.o : mofiles/commonmod.o
mofiles/stml2.o : mofiles/cookie.o mofiles/dbi.o
mofiles/tasksmod.o : mofiles/pgdb.o mofiles/dbmod.o
mofiles/testsmod.o : mofiles/commonmod.o
mofiles/testsmod.o : mofiles/itemsmod.o mofiles/rmtmod.o mofiles/tasksmod.o

# split modules. Note: we can switch between ulex and ulex simple.
mofiles/ulex.o : ulex/ulex.scm ulex-simple/ulex.scm

dashboard.o megatest.o : db_records.scm megatest-fossil-hash.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}')

ifeq ($(MTESTHASH),)

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)

mtest: megatest.scm $(MOFILES) megatest-fossil-hash.scm
	csc $(CSCOPTS) $(MOFILES) megatest.scm -o mtest

mtserve: mtserve.scm $(MOFILES) megatest-fossil-hash.scm
	csc $(CSCOPTS) $(MOFILES) mtserve.scm -o mtserve

#  $(MOIMPFILES) removed

showmtesthash:
	@echo $(MTESTHASH)

dboard : dashboard.scm $(MOFILES) $(GMOFILES) megatest-fossil-hash.scm

	csc $(CSCOPTS) -c $< $(MOFILES)

$(PREFIX)/bin/.$(ARCHSTR)/mtest : mtest utils/mk_wrapper
	@echo Installing to PREFIX=$(PREFIX)
	$(INSTALL) mtest $(PREFIX)/bin/.$(ARCHSTR)/mtest
	utils/mk_wrapper $(PREFIX) mtest $(PREFIX)/bin/megatest
	chmod a+x $(PREFIX)/bin/megatest

$(PREFIX)/bin/.$(ARCHSTR)/mtserve : mtserve utils/mk_wrapper
	@echo Installing to PREFIX=$(PREFIX)
	$(INSTALL) mtserve $(PREFIX)/bin/.$(ARCHSTR)/mtserve
	utils/mk_wrapper $(PREFIX) mtserve $(PREFIX)/bin/mtserver
	chmod a+x $(PREFIX)/bin/mtserver

$(PREFIX)/bin/.$(ARCHSTR)/ndboard : ndboard
	$(INSTALL) ndboard $(PREFIX)/bin/.$(ARCHSTR)/ndboard

$(PREFIX)/bin/newdashboard : $(PREFIX)/bin/.$(ARCHSTR)/ndboard utils/mk_wrapper
	utils/mk_wrapper $(PREFIX) ndboard $(PREFIX)/bin/newdashboard
	chmod a+x $(PREFIX)/bin/newdashboard

#          $(PREFIX)/bin/.$(ARCHSTR)/mtexec $(PREFIX)/bin/mtexec $(PREFIX)/bin/serialize-env \
#  $(PREFIX)/bin/viewscreen  $(PREFIX)/bin/mtutil \
#          $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so \
#          $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so.0 \
#          $(PREFIX)/bin/.$(ARCHSTR)/lib/libxcb-xlib.so.0
#  $(PREFIX)/bin/tcmt

$(PREFIX)/bin/megatest : $(PREFIX)/bin/.$(ARCHSTR)/mtest
$(PREFIX)/bin/mtserver : $(PREFIX)/bin/.$(ARCHSTR)/mtserve

install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest \
	  $(PREFIX)/bin/megatest $(PREFIX)/bin/mtserver \
          $(HELPERS) $(PREFIX)/bin/nbfake \
	  $(PREFIX)/bin/serialize-env \
	  $(PREFIX)/bin/nbfind $(PREFIX)/bin/mtrunner $(PREFIX)/bin/mt_xterm \
	  $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun \
	  $(PREFIX)/share/db/mt-pg.sql \
          $(PREFIX)/share/js/jquery-3.1.0.slim.min.js \
	  $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard \

#     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

TODO
====

Loose ends
----------

15:09:29 error in calling find-and-mark-incomplete for run-id 5, exn=#<condition: (exn type)>
         might be related to initial conditions in the db. (no run entry in runs table?).

. -list-servers not correct
. move *remotedat* into bigdata
. add back server stats on exit (look in rmt:run in rmtmod.scm)


WW15

(module apimod
  (
api:run-server-process
api:start-server
api:dispatch-cmd
api:execute-requests
;; api:process-request
)
	
(import scheme
	chicken.base
	chicken.process-context.posix
	chicken.string
	chicken.time

	 (logd        (conc apath "/logs")) 
	 (logf        (conc logd "/server-launch-";;(current-process-id)
			    (seconds->year-work-week/day-time-fname (current-seconds))
			    "-"cleandbname".log"))
	 (logf2       (conc logd "/server-"
			    (seconds->year-work-week/day-time-fname (current-seconds))
			    "-"cleandbname"-"))
	 (cmd  (conc "nbfake mtserver -server - -area "apath" -db "dbname)
		     ;; " -autolog "logf2 ;; the side log did not help. Ended up with two logs and the pid in the name was not that useful.
		     ))
    (if (not (directory-exists? logd))
	(create-directory logd #t))
    (system (conc "NBFAKE_LOG="logf" "cmd))))

;; special function to get server
;; look up in db
;; if found -> return it

    ((have-incompletes?)            (apply db:have-incompletes? dbstruct params))
    ((login)                        (apply db:login dbstruct params))
    ((general-call)                 (let ((stmtname   (car params))
					  (run-id     (cadr params))
					  (realparams (cddr params)))
				      (db:general-call dbstruct stmtname run-id realparams)))
    ((sdb-qry)                      (apply sdb:qry params))
    ((ping)                         `(#t ,(current-process-id) ,(cadr params))) ;; (current-process-id))
    ((get-changed-record-ids)       (apply db:get-changed-record-ids dbstruct params))
    ((get-run-record-ids) 	   (apply db:get-run-record-ids dbstruct params))	
    ;; TESTMETA
    ((testmeta-get-record)       (apply db:testmeta-get-record dbstruct params))

    ;; TASKS 
    ((find-task-queue-records)   (apply tasks:find-task-queue-records dbstruct params))

;; http-server  send-response
;;                 api:process-request
;;                    db:*
;;
;; NB// Runs on the server as part of the server loop
;;
#;(define (api:process-request dbstruct indat) ;; the $ is the request vars proc
  (let* ((cmd-in  (alist-ref 'cmd indat)) ;; ($ 'cmd))
	 (cmd     (if (string? cmd-in)(string->symbol cmd-in) cmd-in))
	 (params  (alist-ref 'params indat))
         (key     (alist-ref 'key indat))    ;; TODO - add this back
	 ;; (doprint (apply common:low-noise-print 10 params))
	 )
    ;; (if doprint (debug:print 0 *default-log-port* "cmd: " cmd " with params: " params ", key: " key))

#!/bin/bash

#  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/>.

# Configure the build

if [[ "$1"x == "x" ]];then
    PREFIX=$PWD
else
    PREFIX=$1
fi


#======================================================================
# Configure stuff needed for eggs
#======================================================================

function configure_dependencies () {

    #======================================================================
    # libnanomsg
    #======================================================================

    if [[ ! $(ls /usr/lib/*/libnanomsg*) ]];then
	echo "libnanomsg build needed."
	echo "BUILD_NANOMSG=yes" >> makefile.inc
    fi

    #======================================================================
    # postgresql libraries
    #======================================================================

    if [[ ! $(ls /usr/lib/*/libpq.*) ]];then
	echo "Postgresql build needed."
	echo "BUILD_POSTGRES=yes" >> makefile.inc
    fi

    if [[ ! $(ls /usr/lib/*/libsqlite3.*) ]];then
    echo "Sqlite3 build needed."
	echo "BUILD_SQLITE3=yes" >> makefile.inc
    fi

}

#======================================================================
# Initialize makefile.inc
#======================================================================

echo "" > makefile.inc

#======================================================================
# Do we need Chicken?
#======================================================================

if [[ -e /usr/bin/sw_vers ]]; then
    ARCHSTR=$(/usr/bin/sw_vers -productVersion)
else
    ARCHSTR=$(lsb_release -sr)
fi

echo "CHICKEN_PREFIX=$PREFIX/.$ARCHSTR" >> makefile.inc
CHICKEN_PREFIX=$PREFIX/bin/.$ARCHSTR

if [[ ! $(type csi) ]];then
    echo "Chicken build needed."
    echo "BUILD_CHICKEN=yes" >> makefile.inc
    configure_dependencies
    echo "include chicken.makefile" >> makefile.inc
else
    echo "CSIPATH=$(which csi)" >> makefile.inc
    CSIPATH=$(which csi)
    echo "CKPATH=$(dirname $(dirname $CSIPATH))" >> makefile.inc
fi

# Make setup scripts
echo "#!/bin/bash" > setup.sh
echo "export PATH=$CHICKEN_PREFIX/bin:\$PATH" >> setup.sh
echo "export LD_LIBRARY_PATH=$CHICKEN_PREFIX/lib" >> setup.sh
echo 'exec "$@"' >> setup.sh
chmod a+x setup.sh

echo "setenv PATH $CHICKEN_PREFIX/bin:\$PATH" > setup.csh
echo "setenv LD_LIBRARY_PATH $CHICKEN_PREFIX/lib" >> setup.csh

echo "All done creating makefile.inc, feel free to edit it!"
echo "run \"setup.sh bash\" or source setup.csh to get PATH and LD_LIBRARY_PATH adjusted"

README for IUP





  IUP is a portable toolkit for building graphical user interfaces. It offers a configuration API in three basic languages: C, Lua and LED. IUP's purpose is to allow a program to be executed in different systems without any modification, therefore it is highly portable. Its main advantages are:

    * high performance, due to the fact that it uses native interface elements.

    * fast learning by the user, due to the simplicity of its API.



  Build instructions and usage are available in the IUP documentation.



  For complete information, visit IUP's web site at http://www.tecgraf.puc-rio.br/iup

  or access its documentation in the HTML folder.




(end of README)

csm
address-info
ansi-escape-sequences
apropos
base64
breadline
crypt
csv-abnf
directory-utils
dot-locking
filepath
fmt
format
http-client
itemsmod
json
linenoise
mailbox
md5
message-digest
nanomsg
postgresql
queues
regex
regex-case
rfc3339
s11n
sha1
simple-exceptions
slice
sparse-vectors
spiffy
spiffy-directory-listing
spiffy-request-vars
sql-de-lite
sqlite3
sql-null
srfi-1
srfi-13
srfi-19
sxml-modifications
sxml-serializer
sxml-transforms
system-information
tcp6
test
typed-records
uri-common
z3

echo " rsync -av include/ $PREFIX/include/"
echo " or (depending on versions and what you see in the iup tars - they seem to vary"
echo "     cp *.a *.so $PREFIX/lib"
echo "     cp include/*.h $PREFIX/include"
echo "  4. run the chicken-install like this:"

echo "If you use a wrapper (e.g. ck5) to create the chicken environment:"
echo "CSC_OPTIONS=\"-I$PREFIX/include -I$PREFIX/include/im -I$PREFIX/include/cd -I$PREFIX/include/iup -L$PREFIX/lib -C -std=gnu99\" ck5 chicken-install iup canvas-draw -feature disable-iup-matrixex"
echo "else:"
echo "CSC_OPTIONS=\"-I$PREFIX/include -I$PREFIX/include/im -I$PREFIX/include/cd -I$PREFIX/include/iup -L$PREFIX/lib -C -std=gnu99\" chicken-install iup canvas-draw"


# (export PREFIX=/home/matt/data/buildall/ck5.2;CSC_OPTIONS="-I/home/matt/data/buildall/ck5.2/include -I/home/matt/data/buildall/ck5.2/include/im -I/home/matt/data/buildall/ck5.2/include/cd -I/home/matt/data/buildall/ck5.2/include/iup -L/home/matt/data/buildall/ck5.2/lib -C -std=gnu99" ck5 chicken-install iup -feature disable-iup-matrixex)
 

(declare (uses mtver))
(declare (uses debugprint))
(declare (uses stml2))
(declare (uses pkts))
(declare (uses processmod))
(declare (uses mtargs))
(declare (uses configfmod))
;; (declare (uses hostinfo))
(declare (uses keysmod))

;; odd but it works?
;; (declare (uses itemsmod))

(module commonmod
	   (

test:get-item-path
test:test-get-fullname
make-and-init-bigdata
call-with-environment-variables
common:simple-file-lock
common:simple-file-lock-and-wait
common:simple-file-release-lock
common:with-simple-file-lock
common:fail-safe
get-file-descriptor-count
common:get-this-exe-fullpath
common:get-sync-lock-filepath
common:find-local-megatest
common:logpro-exit-code->status-sym
common:worse-status-sym

*task-db*
*db-access-allowed*
*db-access-mutex*
*db-transaction-mutex*
*db-cache-path*
*db-with-db-mutex*
*db-api-call-time*
*didsomething*
*no-sync-db*
*my-signature*
*transport-type*
*logged-in-clients*

*server-run*
*run-id*
*server-kind-run*
*home-host*
*heartbeat-mutex*
*api-process-request-count*
*max-api-process-requests*

runs:gendat-inc-results-last-update-set!
runs:gendat-inc-results-fmt-set!
runs:gendat-run-info-set!
runs:gendat-runname-set!
runs:gendat-target-set!

megatest-fossil-hash

rmt:mk-signature
rmt:get-signature

)

	
(import scheme
	chicken.base
	chicken.condition
	chicken.file

	chicken.io
	chicken.string
	chicken.sort
	chicken.time.posix
	
	(prefix base64 base64:)
	(prefix sqlite3 sqlite3:)

	address-info
	directory-utils
	matchable
	md5
	message-digest
	regex
	regex-case
	sparse-vectors

	stml2
	pkts
	processmod
	(prefix mtargs args:)
	configfmod
	keysmod
	;; itemsmod
	;; hostinfo
	)

;;======================================================================
;; CONTENTS
;;
;;  config file utils
;;  misc conversion, data manipulation functions

;; (define *watchdog* #f)
;; 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 *didsomething* #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 ==> moved to configfmod
(define *configstatus* #f)   ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done
(define *toppath*      #f)

(define *my-signature* #f)
(define *transport-type*    'http)             ;; override with [server] transport http|rpc|nmsg
;; replaced by *rmt:remote*
;; (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-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 db:dbfile-path common:get-db-tmp-area)
(define *global-db-store* (make-hash-table))


;;======================================================================
;; end globals
;;======================================================================

;; Generate a unique signature for this process, used at both client and
;; server side
(define (rmt:mk-signature)
  (message-digest-string (md5-primitive) 
			 (with-output-to-string
			   (lambda ()
			     (write (list (current-directory)
                                          (current-process-id)
					  (argv)))))))

(define (rmt:get-signature) 
  (if *my-signature* *my-signature*
      (let ((sig (rmt:mk-signature)))
        (set! *my-signature* sig)
        *my-signature*)))


;;                       0           1              2              3
(defstruct launch:einf (pid #t)(exit-status #t)(exit-code #t)(rollup-status 0))

;; copied from egg call-with-environment-variables
;;
(define (call-with-environment-variables variables thunk)

	      #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)))

(define (common:with-simple-file-lock fname proc)
  (let* ((lkfname (conc fname ".lock")))
    (common:simple-file-lock-and-wait lkfname)
    (let ((res (proc)))
      (common:simple-file-release-lock lkfname)
      res)))

;;======================================================================
;; PUlled below from common.scm
;;======================================================================

;; execute thunk, return value.  If exception thrown, trap exception, return #f, and emit nonfatal condition note to *default-log-port* .
;; arguments - thunk, message

		      (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 (launch:is-test-alive host pid)
  (let* ((same-host (equal? host (get-host-name)))
	 (cmd (conc 
	       (if same-host "" (conc "ssh "host" "))
	       "pstree -A "pid)))
    (if (and host pid
	     (not (equal? host "n/a")))
	(let* ((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))) ;; assuming bad query is about a live test is likely not the right thing to do?

(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 (pseudo-random-integer 3600)))
			    (let* ((proc   (lambda ()

		  d
		  (begin
		    ;; (if (common:low-noise-print 60 "tests:get-tests-search-path" d)
		    ;;	(debug:print 0 *default-log-port* "WARNING: problem with directory " d ", dropping it from tests path"))
		    #f)))
	    (append paths (list (conc *toppath* "/tests"))))))

;;======================================================================
;; network utilities
;;======================================================================

#;(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)))) ".")))

;; NOTE: Look at address-info egg as alternative to some of this

(define (rate-ip ipaddr)
  (regex-case ipaddr
    ( "^127\\..*" _ 0 )
    ( "^(10\\.0|192\\.168)\\..*" _ 1 )
    ( else 2 ) ))

;; Change this to bias for addresses with a reasonable broadcast value?
;;
(define (ip-pref-less? a b)
  (> (rate-ip a) (rate-ip b)))

(define (server:get-best-guess-address hostname)
  (let ((all-addresses (get-all-ips hostname)))
    (cond
     ((null? all-addresses)
      hostname #;(get-host-name))                                          ;; no interfaces?
     ((eq? (length all-addresses) 1)
      (car all-addresses))                      ;; only one to choose from, just go with it
     (else
      (car (sort all-addresses ip-pref-less?))))))

(define (get-all-ips-sorted)
  (sort (get-all-ips) ip-pref-less?))

(define (get-all-ips hostname)
  (map address-info-host
       (filter (lambda (x)
		 (equal? (address-info-type x) 'tcp))
	       (address-infos hostname))))

(define (tests:readlines filename)
  (call-with-input-file filename
    (lambda (p)
      (let loop ((line (read-line p))
                 (result '()))
        (if (eof-object? line)

;;     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 mtargs))
(declare (uses commonmod))
(declare (uses rmtmod))
(declare (uses debugprint))
(declare (uses keysmod))

(module configfmod
	(
	 common:get-fields
	 common:nice-path

	 configf:set-section-var
	 configf:var-is?
	 configf:write-alist
	 configf:write-config
	 find-config
	 getenv
	 mytarget
	 my-with-lock
	 nice-path
	 process:cmd-run->list
	 runconfig:read
	 runconfigs-get
	 safe-setenv
	 setenv
	 configf:eval-string-in-environment

	(prefix dbi dbi:)
	(prefix sqlite3 sqlite3:)
	(srfi 18)
	directory-utils
	dot-locking
	format
	matchable
	mtargs
	md5
	message-digest
	regex
	regex-case
	sparse-vectors
	srfi-1
	srfi-13

;;======================================================================
;; parameters
;;======================================================================

;; while targets are Megatest specific they are a useful concept
(define mytarget (make-parameter #f))

;; fake locker
(define (fake-locker fname proc)(proc))

;; locking is optional, many environments don't care (e.g. running on one machine)
;; NOTE: the locker must follow the same syntax as with-dot-lock*
;;       with-dot-lock* has problems if /tmp and the file being
;;       locked are not on the same filesystem
;;
(define my-with-lock (make-parameter fake-locker)) ;; with-dot-lock*))

;;======================================================================
;; move debug stuff to separate module then put these back where they belong
;;======================================================================
;;======================================================================
;; lookup routines - replicated from configf
;;======================================================================

      (let (;; (env-to-use (if env-to-use env-to-use (module-environment 'configfmod)))
	    (inp        (if (string? path)
			    (open-input-file path)
			      path)) ;; we can be handed a port
	    (res        (let ((ht-in (if (not ht)
					 (make-hash-table)
					 ht)))
			  (if (not (configf:lookup ht-in "toppath" "toppath"))
			        (configf:set-section-var ht-in "toppath" "toppath" (pathname-directory path)))
			  ht-in))
	    (metapath   (if (or (debug:debug-mode 9)
				keep-filenames)
			    path #f))
            (process-wildcards  (lambda (res curr-section-name)
                                  (if (and apply-wildcards
                                           (or (string-contains curr-section-name "%")   ;; wildcard
                                               (string-match "/.*/" curr-section-name))) ;; regex
                                      (begin
                                        (configf: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 env-to-use)) ;; (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))

	  (if (eof-object? inl) 
	      (begin
                ;; process last section for wildcards
                (process-wildcards res curr-section-name)
		(if (string? path) ;; 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 env-to-use)
                                                            curr-section-name #f #f))

		      (print var " " val)))
		  section-dat))))) ;;       (print "section-dat: " section-dat))
   (hash-table->alist data)))

(define (runconfig:read fname target environ-patt)
  (let ((ht (make-hash-table)))
    (if target (hash-table-set! ht target '()))
    (configf:read-config fname ht #t environ-patt: environ-patt sections: (if target (list "toppath" "default" target) #f))))

;;======================================================================
;; Config file handling
;;======================================================================

;; convert to param?
(define configf:std-imports "(import scheme big-chicken system-information simple-exceptions big-chicken configfmod commonmod rmtmod testsmod srfi-69 chicken.process-context.posix)(import (prefix mtargs args:))(define getenv get-environment-variable)")

(define (configf:process-one matchdat l ht allow-system env-to-use linenum)
  (let* ((prestr  (list-ref matchdat 1))
	 (cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv
	 (cmd     (list-ref matchdat 3))
	 (quotedcmd (conc "\""cmd"\""))
	 (poststr (list-ref matchdat 4))
	 (result  #f)
	 (start-time (current-seconds))
	 (cmdsym  (string->symbol cmdtype))
	 (fullcmd
	  (if (member cmdsym '(scheme scm))
	      `(eval-needed
		,(conc  "(lambda (ht)"
			configf:std-imports
			;; "(set! *toppath* \""(configf:lookup ht "toppath" "toppath")"\")"
			cmd ")"))
	      (case cmdsym
		((system)     `(noeval-needed  ,(conc (configf:system ht cmd))))
		;; ((shell sh)   `(noeval-needed  ,(conc (string-translate (shell quotedcmd) "\n" " "))))
		((shell sh)   `(noeval-needed  ,(conc (string-translate (shell cmd) "\n" " "))))
		((realpath rp)`(noeval-needed  ,(conc (common:nice-path quotedcmd))))
		((getenv gv)  `(noeval-needed  ,(conc (get-environment-variable cmd))))
		((mtrah)      `(noeval-needed  ,(configf:lookup ht "toppath" "toppath")))
		((get g)   
		 (match
		  (string-split cmd)
		  ((sect var) `(noeval-needed ,(configf:lookup ht sect var)))
		  (else
		   (debug:print-error 0 *default-log-port* "#{get ...} used with only one parameter, \"" cmd "\", two needed.")
		   '(bad-param ,(conc "#{get ...} used with only one parameter, \"" cmd "\", two needed.")))))
		;;((runconfigs-get rget) `(noeval-needed ,(runconfigs-get ht quotedcmd))) ;; (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
		((runconfigs-get rget) `(noeval-needed ,(runconfigs-get ht cmd))) ;; (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
		(else `(#f ,(conc "cmd: " cmd " not recognised")))))))
     
     (match
     fullcmd
     (('eval-needed newres)
	 (if (or allow-system
		 (not (member cmdtype '("system" "shell" "sh"))))
	     (begin
	       ;; (debug:print 0 *default-log-port* "eval: "newres)
	       (with-input-from-string newres
		 (lambda ()
		   (set! result
			 (handle-exceptions
	       		  exn
	       		  (begin
	       		    (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\", eval-needed, newres="newres", exn="(condition->list exn))
	       		    (debug:print 0 *default-log-port* " message1: " ((condition-property-accessor 'exn 'message) exn))

	       		    (set! result (conc "#{( " cmdtype ") " cmd "}, full expansion: " newres)))




			  (if env-to-use
			      ;; ((eval (read) env-to-use) ht) disable until we fix this. 2/10/22 Martin
			      ((eval (read)) ht)
			      ((eval (read)) ht)
			      ))))))
	     (set! result (conc "#{(" cmdtype ") "  cmd "}"))
           )
     )
     (('noeval-needed newres)
        (set! result newres))
     (else ;; (#f errres)
       (debug:print 0 *default-log-port* "WARNING: failed to process config input \""l"\", fullcmd="fullcmd".")))

    ;; we process as a result
    (let ((delta (- (current-seconds) start-time)))
      (debug:print-info (if (> delta 2) 0 9) *default-log-port* "for line \"" l "\"\n command:  " cmd " took " delta " seconds to run with output:\n   " result))
    (conc prestr result poststr)))
	      
(define (configf:process-line l ht allow-system env-to-use #!key (linenum #f))
  (let loop ((res l))
    (if (string? res)
	(let ((matchdat (string-search configf:var-expand-regex res)))
	  (if matchdat
	      (let ((result (configf:process-one matchdat l ht allow-system env-to-use linenum)))
		(loop result))
	      res))
	  res)))

#;(define (configf:process-line-old l ht allow-system env-to-use #!key (linenum #f))
  (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-seconds))
		     (cmdsym  (string->symbol cmdtype))
		     (fullcmd
		      (conc  configf:std-imports

			     ;;"(define setenv set-environment-variable)"
			     (case cmdsym
			       ((scheme scm) (conc "(lambda (ht)" cmd ")"))
			       ((system)     (conc "(lambda (ht)(configf:system ht \"" cmd "\"))"))
			       ((shell sh)   (conc "(lambda (ht)(string-translate (shell \""  cmd "\") \"\n\" \" \"))"))
			       ((realpath rp)(conc "(lambda (ht)(common:nice-path \"" cmd "\"))"))
			       ((getenv gv)  (conc "(lambda (ht)(get-environment-variable \"" cmd "\"))"))
			       ((mtrah)      (conc "(lambda (ht)"

			       ;; ((rget)           (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
			       (else "(lambda (ht)(print \"ERROR\") \"ERROR\")")))))
		;; (print "fullcmd=" fullcmd)
		(handle-exceptions
		 exn
		 (begin
		   (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\", exn=" exn)
		   (debug:print 0 *default-log-port* " message2: " ((condition-property-accessor 'exn 'message) exn))
		   ;; (print "exn=" (condition->list exn))
		   (set! result (conc "#{( " cmdtype ") " cmd "}, full expansion: " fullcmd)))
		 (if (or allow-system
			 (not (member cmdtype '("system" "shell" "sh"))))
		     (with-input-from-string fullcmd
		       (lambda ()
			 (set! result (if env-to-use

    (configf:alist->config
     (with-input-from-file fname read))))

;;======================================================================
;; DO THE LOCKING AROUND THE CALL
;;======================================================================
;;
(define (configf:write-alist cdat fname #!optional (check-written #f))
  ;; (if (not (common:faux-lock fname))
  ;; (debug:print 0 *default-log-port* "INFO: NEED LOCKING ADDED HERE " fname)
  ((my-with-lock)
   fname
   (lambda ()
     (let* ((dat  (configf:config->alist cdat))
            (res
             (begin
               (with-output-to-file fname ;; first write out the file
		 (lambda ()
                   (pp dat)))
               ;; I don't like this. It makes write-alist complicated
	       ;; move to something like write-and-verify-alist. -mrw-
               (if check-written
		   (if (file-exists? fname)   ;; now verify it is readable
		       (if (configf:read-alist fname)
			   'data-good ;; data is good.

			   (handle-exceptions
			       exn
			       (begin
				 (debug:print 0 *default-log-port* "deleting " fname " failed, exn=" exn)

				 'data-bad)
			     (debug:print 0 *default-log-port* "WARNING: content " dat " for cache " fname " is not readable. Deleting generated file.")
			     (delete-file fname)))

		       'data-not-there)
		   'data-not-checked))))
       res))))
  
(define (common:get-fields cfgdat)
  (let ((fields (hash-table-ref/default cfgdat "fields" '())))
    (map car fields)))

)

#     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/>.


# Flavors include: simple, full and none






# look at build.config (not a version controlled file and



# create ulex.scm and dbmgr.scm





if [[ -e transport-flavor ]];then




    FLAVOR=$(cat transport-flavor)




























else


    FLAVOR=simple












fi







sed -e "s/FLAVOR/$FLAVOR/" ulex.scm.template > ulex.scm


sed -e "s/FLAVOR/$FLAVOR/" dbmgrmod.scm.template > dbmgrmod.scm

	srfi-1
	regex regex-case srfi-69
	typed-records
	sparse-vectors
	format
	srfi-4
	srfi-14
	srfi-18
	)

;; (include "common_records.scm")
;; (include "db_records.scm")
;; (include "run_records.scm")
;; (include "task_records.scm")
;; (include "megatest-version.scm")

			(exit 1))))
		'("MT_RUN_AREA_HOME" "MT_MEGATEST" "MT_CMDINFO" "MT_TEST_RUN_DIR" "MT_LINKTREE" "MT_TESTSUITENAME"))
      (print ". Done. All ok.")))

(if (not (null? remargs))
    (begin
      (print "Unrecognised arguments: " (string-intersperse remargs " "))
      ))

(if (args:get-arg "-h")
    (begin
      (print help)
      (exit)))

(if (args:get-arg "-start-dir")

		      (> elapsed-time 2)) ;; stop loading data after 5 seconds, on the next call more data *should* be loaded since get-tests-for-run uses last update
		  (begin
		    (when (> elapsed-time 2)   
                      (debug:print 0 *default-log-port* "NOTE: updates are taking a long time, " elapsed-time "s elapsed.")
                      (let* ((old-val (iup:attribute *tim* "TIME"))
                             (new-val (number->string (inexact->exact (floor (* 2  (string->number old-val)))))))
                        (if (< (string->number new-val) 5000)
                            (begin
			      (debug:print 0 *default-log-port* "NOTE: increasing poll interval from "old-val" to "new-val)
                              (iup:attribute-set! *tim* "TIME" new-val)))))



		    (dboard:tabdat-allruns-set! tabdat new-res)
		    maxtests)
		  (if (> (dboard:rundat-run-data-offset run-struct) 0)
		      (loop run tal new-res newmaxtests) ;; not done getting data for this run
		      (loop (car tal)(cdr tal) new-res newmaxtests)))))))
    (dboard:tabdat-filters-changed-set! tabdat #f)
    (dboard:update-tree tabdat runs-hash header tb)))

	  val
	  (if (not (null? values))
	      (let ((newval (car values)))
		(iup:attribute-set! lb "VALUE" newval)
		newval))))))

(define (dashboard:update-target-selector tabdat #!key (action-proc #f))
  (let* ((runconf-targs (common:get-runconfig-targets *runconfigdat*))
	 (key-lbs       (dboard:tabdat-key-listboxes tabdat))
	 (db-target-dat (rmt:get-targets))
	 (header        (vector-ref db-target-dat 0))
	 (db-targets    (vector-ref db-target-dat 1))
	 (munge-target  (lambda (x)            ;; create a target vector from a string. Pad with na if needed.
			  (list->vector
			   (take (append (string-split x "/")

	(dboard:tabdat-run-name-set! tabdat curr-runname))
    (dashboard:update-run-command tabdat)))

;; used by run-controls
;;
(define (dashboard:update-tree-selector tabdat #!key (action-proc #f))
  (let* ((tb            (dboard:tabdat-runs-tree tabdat))
	 (runconf-targs (common:get-runconfig-targets *runconfigdat*))
	 (db-target-dat (rmt:get-targets))
         (runs-tree-ht  (dboard:tabdat-runs-tree-ht tabdat))
	 (header        (vector-ref db-target-dat 0))
	 (db-targets    (vector-ref db-target-dat 1))
	 (munge-target  (lambda (x)            ;; create a target vector from a string. Pad with na if needed.
			  (take (append (string-split x "/")
					(make-list (length header) "na"))

			 (zeroth-point   (conc "SELECT " timef "," varfn "," valfn " FROM " tablen " WHERE " varfn "='" fieldname "' AND " timef " < " tstart " LIMIT 1")))
		     (hash-table-set! res-ht fieldname ;; (fetch-rows (sql db qrystr)))))
				      (reverse
				       (sqlite3:fold-row
					(lambda (res t var val)
					  (cons (vector t var val) res))
					'() db all-dat-qrystr)))
		     (let ((zeropt (condition-case 


				       (sqlite3:first-row db all-dat-qrystr)
				     (exn (busy)(db:generic-error-printout exn "ERROR: database " dbdef
                                     " is locked. Try copying to another location, remove original and copy back.")))))
		       (if zeropt ;; NOTE: Add zeropt to the beginning of the list as the list was reversed above.
			   (hash-table-set! res-ht
					    fieldname
					    (cons
					     (apply vector tstart (cdr zeropt))						    
					     (hash-table-ref/default res-ht fieldname '())))))))
		 fields)

				      (begin
					(if (dboard:tabdat-layout-update-ok tabdat)
					    (runloop (car runtal)(cdr runtal) (+ run-num 1) newdoneruns)
					    (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat)
					    ))))))))) ;;  new-run-start-row
		)))
	(debug:print 2 *default-log-port* "no tabdat for run-times-tab-updater"))))

(define (dashboard:calc-key-patterns tabdat)
  ;; generate key patterns from the target stored in tabdat
  (let* ((dbkeys  (dboard:tabdat-dbkeys tabdat)))
    (let ((fres   (if (dboard:tabdat-target tabdat)
		      (let ((ptparts (append (dboard:tabdat-target tabdat)(make-list (length dbkeys) "%"))))
			(map (lambda (k v)(list k v)) dbkeys ptparts))
		      (let ((res '()))
			(for-each (lambda (key)
				    (if (not (equal? key "runname"))
					(let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f)))
					  (if val (set! res (cons (list key val) res))))))
				  dbkeys)
			res))))
      fres)))


;; handy trick for printing a record
;;
;;   (pp (dboard:tabdat->alist tabdat))
;; 
;;  removing the tabdat-values proc 
;;
;; (define (tabdat-values tabdat)

;; runs update-rundat using the various filters from the gui
;;
(define (dashboard:do-update-rundat tabdat)


  (let* ((runnamepatt (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%"))
	 (numruns     (dboard:tabdat-numruns tabdat))
	 (testnamepatt (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%"))
	 (keypatts     (dashboard:calc-key-patterns tabdat)))
    (dboard:update-rundat
     tabdat




     runnamepatt



     numruns
     testnamepatt
     keypatts)))

(define (dashboard:runs-tab-updater commondat tab-num)
  (debug:catch-and-dump 
   (lambda ()
     (let* ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))
	    (dbkeys (dboard:tabdat-dbkeys tabdat)))
       (dashboard:do-update-rundat tabdat)

(import dashboard)

;; ease debugging by loading ~/.dashboardrc
(let ((debugcontrolf (get-debugcontrolf)))
  (if debugcontrolf
      (load debugcontrolf)))

(import srfi-18)

(thread-join!
 (thread-start!
  (make-thread main "main")))

;;======================================================================
;; Copyright 2022, 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 "ulex-FLAVOR/dbmgr.scm")

;; open or create the disk db file
;; create and fill the inmemory db
;; assemble into dbr:dbdat struct and return
;; 
(define (db:open-dbdat apath dbfile dbinit-proc)
  (let* ((db       (db:open-run-db dbfile dbinit-proc))
	 (inmem    (db:open-inmem-db dbinit-proc))
	 (dbdat    (make-dbr:dbdat
		    db:     db
		    inmem:  inmem
		    ;; run-id: run-id  ;; no can do, there are many run-id values that point to single db
		    fname:  dbfile)))
    (assert (and (sqlite3:database? db)(sqlite3:database? inmem))
	    "FATAL: should have both inmem and on-disk db at this time.")
    ;; now sync the disk file data into the inmemory db
    (db:sync-tables (db:sync-all-tables-list) '("last_update" . 0) db inmem)
    ;; (sqlite3:finalize! db) ;; open and close every sync
    dbdat))













;; open the disk database file
;; NOTE: May need to add locking to file create process here
;; returns an sqlite3 database handle
;;
(define (db:open-run-db dbfile dbinit-proc)
  (let* ((parent-dir (pathname-directory dbfile)))

;; called in http-transport and replicated in rmt.scm for *local* access. 
;;
(define (db:setup db-file) ;; run-id)
  (assert *toppath* "FATAL: db:setup called before toppath is available.")
  (let* ((dbstruct (or *dbstruct-db* (make-dbr:dbstruct))))
    (db:get-dbdat dbstruct *toppath* db-file)
    (if (not *dbstruct-db*)(set! *dbstruct-db* dbstruct))
    (assert (db:check-setup dbstruct *toppath* db-file) "FATAL: db:setup did NOT complete properly")
    dbstruct))

(define (db:check-setup dbstruct apath dbfile)
  (let* ((dbdat       (db:get-dbdat dbstruct apath dbfile))
	 (dbfullname  (conc apath "/" dbfile))
	 (db          (dbr:dbdat-db dbdat)) ;; (db:open-run-db dbfullname db:initialize-db)) ;; 
	 (inmem       (dbr:dbdat-inmem dbdat)))
    (and (sqlite3:database? db)
	 (sqlite3:database? inmem))))

;;======================================================================
;; setting/getting a lock on the db for only one server per db
;;
;;  NOTE:
;;       These operate directly on the disk file, NOT on the inmemory db
;;       The lockname is the filename (can have many to one, run-id to fname 

;; ;;     (mutex-unlock! *db-multi-sync-mutex*)
;; ;;     (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb)))

;; NOTE: touched logic is disabled/not done
;; sync run to disk if touched
;;
(define (db:sync-inmem->disk dbstruct apath dbfile #!key (force-sync #f))

  (let* ((dbdat       (db:get-dbdat dbstruct apath dbfile))
	 (dbfullname  (conc apath "/" dbfile))
	 (db          (dbr:dbdat-db dbdat)) ;; (db:open-run-db dbfullname db:initialize-db)) ;; 
	 (inmem       (dbr:dbdat-inmem dbdat))
	 (start-t     (current-seconds))
	 (last-update (dbr:dbdat-last-write dbdat))
	 (last-sync   (dbr:dbdat-last-sync dbdat)))
    (if (and (sqlite3:database? db)
	     (sqlite3:database? inmem))
	(begin
	  (debug:print-info 0 *default-log-port* "Syncing for dbfile: "dbfile", last-update: "last-update", last-sync: "last-sync)
	  (mutex-lock! *db-multi-sync-mutex*)
	  (let* ((update_info (cons "last_update" (if force-sync 0 last-update))) ;;  "last_update"))
   		 (need-sync   (or force-sync (>= last-update last-sync))))
	    (if need-sync
		(begin
		  (db:sync-tables (db:sync-all-tables-list) update_info inmem db)
		  (dbr:dbdat-last-sync-set! dbdat start-t))
		(debug:print 0 *default-log-port* "Skipping sync as nothing touched.")))
	  ;; (sqlite3:finalize! db)
	  (mutex-unlock! *db-multi-sync-mutex*))
	(debug:print-info 0 *default-log-port* "Skipping sync due to databases not being open."))))
    
;; TODO: Add final sync to this
;;
(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)
  (assert (dbr:dbstruct? dbstruct) "FATAL: db:close-all called with dbstruct not set up.")
  (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.

	(all-stmts   '())              ;; ( ( stmt1 value1 ) ( stml2 value2 ))
	(numrecs     (make-hash-table))
	(start-time  (current-milliseconds))
	(tot-count   0))

    (for-each ;; table
     (lambda (tabledat)
       (condition-case
	   (db:sync-one-table fromdb todb tabledat last-update numrecs)
	 ;; if db is busy, take a break and try one more time
	 (exn (busy)(thread-sleep! 0.5)
	      (db:sync-one-table fromdb todb tabledat last-update numrecs))))
     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 

                              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);")))
    (debug:print 0 *default-log-port* "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

       (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"))
	 (found  (file-exists? infile)))
    ;; first verify we are able to write the output file
    (cond
     ((not found) #f)
     ((and (file-exists? infile)
	   (not (file-readable? infile)))

      (debug:print 0 *default-log-port* "ERROR: cannot read " infile)
      (debug:print 0 *default-log-port* "ERROR: run-dir is " run-dir)
      #f)

     (else
      (let ((res (condition-case
		  (with-input-from-file infile read-lines)
		  (exn (i/o file) #f))))
	(cond
	 ((equal? res "#!eof") #f)
	 ((eof-object? res)    #f)
	 (else res)))))))
     
;;  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'));

(define (db:find-and-mark-incomplete dbstruct run-id ovr-deadtime)
  (let* ((incompleted '())

;; 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);;(condition-case (vector-ref #(1 2 3) 3)(exn (bounds)(print "out of bounds")))
            (condition-case
		(vector-ref row n)
	      (exn (bounds)

		   (debug:print 0 *default-log-port* "WARNING: attempt to read non-existant field, row="
				row " header=" header " field=" field ", exn=" exn)
		   #f))

	    (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))

;; 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       (make-vector 11 #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)
    

         (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 

      ;; "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) 


  (let* ((qry  "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)
	 (sqlite3:first-result db qry 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

	 (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 run-id (list test-id)))

    (db:with-db
     dbstruct run-id #f
     (lambda (db)
       (mutex-lock! *db-transaction-mutex*)
       (let ((tr-res
              (sqlite3:with-transaction
               db
               (lambda ()
                 ;; NB// Pass the db so it is part fo the transaction
		  ;; this call sets the item state/status
                 (db:db-test-set-state-status db run-id test-id state status comment)

                     (conc
		      (with-output-to-string (lambda () (pp (dbr:counts->alist x)))) " | "))
		       state-status-counts))); end debug:print
		       
                       (if tl-test-id
			   (db: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)))
    ;; this was moved out of test-set-state-status
    (mt:process-triggers dbstruct run-id test-id state status)))

			  "\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)

  (db:with-db
   dbstruct #f #f
   (lambda (db)
     (mutex-lock! *db-transaction-mutex*)
     (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 (or (not (eq? newstate curr-state)) (not (eq?  newstatus curr-status)))
		     (begin
		       (db:set-run-state-status dbstruct run-id newstate newstatus)
		       #t) ;; changes made
		     #f) ;; no changes
		 )))))
       (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)

			    (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)))))))

;; run this one in a transaction where first check if host:port is taken
(define (db:register-server dbstruct host port servkey pid ipaddr apath dbname)
  (db:with-db
   dbstruct
   #f #f
   (lambda (db)
     (mutex-lock! *db-transaction-mutex*)
     (sqlite3:with-transaction
      db
      (lambda ()
	(let* ((sinfo      (db:get-server-info dbstruct apath dbname))
	       (res 	   (if sinfo
			       (begin
				 (debug:print-info 0 *default-log-port* "Server already running at "sinfo ", while trying to register server " host":"port)
				 #f) ;; server already registered
			       (begin
				 (sqlite3:execute db "INSERT INTO servers (host,port,servkey,pid,ipaddr,apath,dbname) VALUES (?,?,?,?,?,?,?);"
						  host port servkey pid ipaddr apath dbname)
				 (db:get-server-info dbstruct apath dbname)))))
	  (mutex-unlock! *db-transaction-mutex*)
	  res))))))
  
;; run this one in a transaction where first check if host:port is taken
(define (db:deregister-server dbstruct host port servkey pid ipaddr apath dbname)
  (db:with-db
   dbstruct
   #f #f
   (lambda (db)
     (mutex-lock! *db-transaction-mutex*)
     (let ((res (sqlite3:with-transaction
		 db
		 (lambda ()
		   (let* ((sinfo      (db:get-server-info dbstruct apath dbname)))
		     (if (not sinfo)
			 (begin
			   (debug:print-info 0 *default-log-port* "Server already removed for "apath", "dbname) ;; at "sinfo ", while trying to register server " host":"port)
			   #f) ;; server already deregistered
			 (begin
			   (sqlite3:execute db "DELETE FROM servers WHERE apath=? AND dbname=?;" ;; (host,port,servkey,pid,ipaddr,apath,dbname) VALUES (?,?,?,?,?,?,?);"
					    ;; host port servkey pid ipaddr
					    apath dbname)
			   #;(db:get-server-info dbstruct apath dbname)
			   'done)))))))
       (mutex-unlock! *db-transaction-mutex*)
       res))))

(define (db:get-server-info dbstruct apath dbname)
  (db:with-db
   dbstruct
   #f #f
   (lambda (db)
     (sqlite3:fold-row

(declare (uses mtver))
(declare (uses debugprint))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses rmtmod))
(declare (uses mtargs))
(declare (uses testsmod))
(declare (uses dbmgrmod))

(module dcommon
	*

 (import scheme
	 chicken.base
	 chicken.condition

	 srfi-69
	 sparse-vectors
	 srfi-1
	 )

(import mtver
	dbmod
	dbmgrmod
	commonmod
	debugprint
	configfmod
	rmtmod
	;; gutils
	(prefix mtargs args:)
	testsmod)

(declare (unit debugprint))
(declare (uses mtargs))

(module debugprint
	*
	
;;(import scheme chicken data-structures extras files ports)
(import scheme
	chicken.base
	chicken.string
	chicken.time
	chicken.time.posix
	chicken.port
	chicken.process-context
	chicken.process-context.posix
	
	(prefix mtargs args:)
	srfi-1
	system-information
	)

;;======================================================================
;; debug stuff
;;======================================================================

(define verbosity (make-parameter '()))
(define *default-log-port*  (current-error-port))
(define debug:print-logger (make-parameter #f)) ;; set to a proc to call on every logging print
	 
(define (debug:setup)
  (let ((debugstr (or (args:get-arg "-debug")
      		      (args:get-arg "-debug-noprop")
      		      (get-environment-variable "MT_DEBUG_MODE"))))
    (verbosity (debug:calc-verbosity debugstr 'q))
    (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))(verbosity 1))
    (if (and (not (args:get-arg "-debug-noprop"))
      	     (or (args:get-arg "-debug")
      		 (not (get-environment-variable "MT_DEBUG_MODE"))))
      	(set-environment-variable! "MT_DEBUG_MODE" (if (list? (verbosity))
      				    (string-intersperse (map conc (verbosity)) ",")
      				    (conc (verbosity)))))))

(define (debug:handle-remote-logging params)
  (if (debug:print-logger) ;; NOTE: turn params into string to keep things simple for now
      ((debug:print-logger)(conc "REMOTE ("(get-host-name)", pid="(current-process-id)") "
				 (string-intersperse (map conc params) " ") "; "
				 (string-intersperse (command-line-arguments) " ")))))

(define debug:enable-timestamp (make-parameter #t))

(define (debug:timestamp)
  (if (debug:enable-timestamp)
      (conc (time->string 
	     (seconds->local-time (current-seconds)) "%H:%M:%S") " ")
      ""))

  (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 (debug:timestamp) params)
	  ;; (debug:handle-remote-logging params)
	  )))
  #t ;; only here to make remote stuff happy. It'd be nice to fix that ...
  )

(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: " (debug:timestamp) params)
	  ;; (debug:handle-remote-logging (cons "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: " (debug:timestamp) 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 ") "(debug:timestamp) params) ;; res)
	  ;; (debug:handle-remote-logging (cons "INFO: " params))
	  ))))

(define (debug:print-warn n e . params)
  (if (debug:debug-mode n)
      (with-output-to-port (if (port? e) e (current-error-port))
	(lambda ()
	  (apply print "WARN: (" n ") " (debug:timestamp) params) ;; res)
	  ;; (debug:handle-remote-logging (cons "WARN: " params))
	  ))))
)

	  ;; (db:test-remove-steps db run-id testname itemdat)
	  ;; now is also a good time to write the .testconfig file
	  (let* ((tconfig-fname   (conc work-area "/.testconfig"))
		 (tconfig-tmpfile (conc tconfig-fname ".tmp"))
		 (tconfig         (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t)) ;; 'return-procs)))
		 (scripts (configf:get-section tconfig "scripts")))
	    ;; create .testconfig file
	    (configf:write-alist tconfig tconfig-tmpfile #t) ;; the #t forces a check of the written data
	    (assert (file-exists? tconfig-tmpfile) "FATAL: We just wrote the dang file, how can it not exist?")
	    (move-file tconfig-tmpfile tconfig-fname #t)
	    (delete-file* ".final-status")

	    ;; extract scripts from testconfig and write them to files in test run dir
	    (for-each
	     (lambda (scriptdat)
	       (match scriptdat

					(list 'target    mt_target)
					(list 'contour   contour)
					(list 'runtlim   (if run-time-limit (common:hms-string->seconds run-time-limit) #f))
					(list 'env-ovrd  (hash-table-ref/default *configdat* "env-override" '())) 
					(list 'set-vars  (if params (hash-table-ref/default params "-setvars" #f)))
					(list 'runname   runname)
					(list 'mt-bindir-path mt-bindir-path))))))))

      (setenv "MT_CMDINFO" cmdparms)  ;; setting this for use in nblauncher
      
      ;; clean out step records from previous run if they exist
      ;; (rmt:delete-test-step-records run-id test-id)
      ;; if the dir does not exist we may have a itempath where individual variables are a path, launch anyway
      (if (common:file-exists? work-area)
	  (change-directory work-area)) ;; so that log files from the launch process don't clutter the test dir
      (cond

;; > 3 RUNNING with not test_dead do nothing (run should already be RUNNING/ na
;; > 0 RUNNING and test_dead then send KILLREQ ==> COMPLETED
;; 0 RUNNING ==> this is actually the first condition, should not get here

(define (runs:end-of-run-check run-id )
  (let* ((not-completed-cnt (rmt:get-not-completed-cnt run-id))  
	 (running-cnt (rmt:get-count-tests-running-for-run-id run-id))
	 (all-test-launched (rmt:get-var run-id (conc "launch-complete-" run-id)))
	 (current-state (rmt:get-run-state run-id))
	 (current-status (rmt:get-run-status run-id)))
    ;;get-vars run-id to query metadata table to check if all completed. if all-test-launched = yes then only not-completed-cnt = 0 means everyting is completed if no entry found in the table do nothing 
    (debug:print 0 *default-log-port* "Running test cnt :" running-cnt)                      
    (rmt:set-state-status-and-roll-up-run  run-id current-state current-status)
    (runs:update-junit-test-reporter-xml run-id) 
    (cond 
     ((and all-test-launched (eq? not-completed-cnt 0) (equal? all-test-launched "yes" ))
      (if (and (equal? (rmt:get-var run-id (conc "end-of-run-" run-id)) "no") (common:simple-lock (conc "endOfRun" run-id)))
	  (begin
	    (debug:print 4 *default-log-port* "look for  post hook. currseconds: " (current-seconds) " EOR " (rmt:get-var run-id (conc "end-of-run-" run-id)))
	    (debug:print 0 *default-log-port* "End of Run Detected.")
	    (rmt:set-var run-id (conc "end-of-run-" run-id) "yes")
					;(thread-sleep! 10)
	    (runs:run-post-hook run-id)
	    (debug:print 4 *default-log-port* "currseconds: " (current-seconds)" eor: " (rmt:get-var run-id (conc "end-of-run-" run-id)))
	    (common:simple-unlock (conc "endOfRun" run-id)))
	  (debug:print 0 *default-log-port* "End of Run Detected but not running post hook. This should happen when eor is set to yes. This will happen only when 2 tests exit at same time. eor= " (rmt:get-var run-id (conc "end-of-run-" run-id)))))
     ((> running-cnt 3) 
      (debug:print 0 *default-log-port* "There are " running-cnt " tests running." ))
     ((> running-cnt 0)
      (debug:print 0 *default-log-port* "running cnt > 0 but <= 3 kill-running-tests-if-dead" )
      (let ((kill-cnt (launch:kill-tests-if-dead run-id)))
	(if (and all-test-launched  (equal? all-test-launched "yes") (eq? kill-cnt running-cnt))
	    (runs:end-of-run-check run-id)))) ;;todo

		      (if (not (null? tal))
			  (loop (car tal) (cdr tal)))))))))))

(define (runs:find-and-mark-incomplete-and-check-end-of-run run-id ovr-deadtime)
  (rmt:find-and-mark-incomplete run-id ovr-deadtime)
  (runs:end-of-run-check run-id))

;; only called if there are more than zero running tests

(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))
      (let* ((test-name  (vector-ref running-test 2))
             (item-path  (vector-ref running-test 11))
	     (test-id    (vector-ref running-test 0))
             (host       (vector-ref running-test 6))
             (pid        (rmt:test-get-top-process-pid run-id test-id))   
             (event-time (vector-ref running-test 5))
             (duration   (vector-ref running-test 12))
             (flag       0)   
             (curr-time  (current-seconds)))
	(if (and (< (+ event-time duration 600) curr-time)
		 (not (launch:is-test-alive host pid))) ;;test has not updated duration in last 10 min then likely its not running but confirm before marking it as killed
            (begin    
	      (debug:print 0 *default-log-port* "test " test-name "/" item-path " needs to be killed")
              (set! flag 1) 
              (rmt:set-state-status-and-roll-up-items run-id test-name item-path "KILLREQ" "n/a" #f)))
        (if (not (null? tal))
	    (loop (car tal) (cdr tal) (+ kill-cnt flag))
            (+ kill-cnt flag))))))


(define (runs:run-post-hook run-id)
    (let* ((run-post-hook   (configf:lookup *configdat* "runs" "post-hook"))
           (existing-tests (if run-post-hook
                               (rmt:get-tests-for-run run-id "%" '() '() ;; run-id testpatt states statuses
                                                      #f #f ;; offset limit

;;

(declare (uses dbi))
(declare (uses pkts))
(declare (uses stml2))
(declare (uses cookie))
(declare (uses csv-xml))
;; (declare (uses hostinfo))

(declare (uses adjutant))
(declare (uses archivemod))
(declare (uses apimod))
(declare (uses autoload))
(declare (uses bigmod))
(declare (uses commonmod))

(declare (uses mtver))
(declare (uses mutils))
(declare (uses processmod))
(declare (uses rmtmod))
(declare (uses runsmod))
(declare (uses servermod))
(declare (uses testsmod))
(declare (uses dbmgrmod))

;; needed for configf scripts, scheme etc.
;; (declare (uses apimod.import))
;; (declare (uses debugprint.import))
;; (declare (uses mtargs.import))
;; (declare (uses commonmod.import))
;; (declare (uses configfmod.import))
;; (declare (uses bigmod.import))
;; (declare (uses dbmod.import))
;; (declare (uses rmtmod.import))
;; (declare (uses servermod.import))
;; (declare (uses launchmod.import))

;; (include "call-with-environment-variables/call-with-environment-variables.scm")

(module megatest
	*

  (import scheme
	  chicken.base
	  chicken.bitwise
	  chicken.condition
	  ;; chicken.csi

	  srfi-98
	  srfi-69

	  ;; local modules
	  autoload
	  adjutant
	  csv-xml
	  ;; hostinfo
	  mtver
	  mutils
	  cookie
	  csv-xml
	  ducttape-lib
	  (prefix mtargs args:)
	  pkts

	  launchmod
	  processmod
	  rmtmod
	  runsmod
	  servermod
	  tasksmod
	  testsmod
	  dbmgrmod
	  
	  ulex
	  )

;;   ;; ulex parameters
;;   (work-method 'direct)
;;   (return-method 'direct)
  
  ;; ulex parameters
  ;; (work-method   'mailbox)
  ;; (return-method 'mailbox)

(my-with-lock common:with-simple-file-lock)
  
;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)
(define *didsomething* #f)  
(define *db* #f) ;; this is only for the repl, do not use in general!!!!

;; (include "common_records.scm")
;; (include "key_records.scm")
;; (include "db_records.scm")
(include "run_records.scm")
;; (include "test_records.scm")

;; (include "common.scm")
(include "db.scm")
;; (include "server.scm")
(include "tests.scm")
(include "genexample.scm")
(include "tdb.scm")
(include "env.scm")
(include "diff-report.scm")
(include "ods.scm")

(define *usage-log-file* #f)    ;; put path to file for logging usage in this var in the ~/.megatestrc file
(define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file

(set! *toppath* (get-environment-variable "PWD"))

;;======================================================================
;; Test commands (i.e. for use inside tests)
;;======================================================================

(define (megatest:step step state status logfile msg)
  (if (not (get-environment-variable "MT_CMDINFO"))

     			 status: #f
     			 new-state-status: "NOT_STARTED,n/a")))
  (let* ((config-reruns      (let ((x (configf:lookup *configdat* "setup" "reruns")))
     			       (if x (string->number x) #f)))
     	 (rerun-cnt (if config-reruns
     			config-reruns
     			1)))
    (debug:print 0 *default-log-port* "handle-run-requests *toppath* = " *toppath*) 
    (runs:run-tests target
     		    runname
     		    #f ;; (common:args-get-testpatt #f)
     		    ;; (or (args:get-arg "-testpatt")
     		    ;;     "%")
     		    (bdat-user *bdat*)
     		    args:arg-hash

     			 newlogf)
     		       logpath-in)))
     (if (not (directory-exists? log-dir))
	 (system (conc "mkdir -p " log-dir)))
     (open-output-file logpath))
   (exn ()
	(debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath-in)
	(set! *didsomething* #t)
	(exit 1))))

;; Disabled help items
;;  -rollup                 : (currently disabled) fill run (set by :runname)  with latest test(s)
;;                            from prior runs with same keys
;;  -daemonize              : fork into background and disconnect from stdin/out

Called as " (string-intersperse (argv) " ") "
Version " megatest-version ", built from " megatest-fossil-hash ))
     
(define (main)
  (make-and-init-bigdata)









;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file
;;
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc")))
  (if (common:file-exists? debugcontrolf)
      (load debugcontrolf)))

;; usage logging, careful with this, it is not designed to deal with all real world challenges!

     
     ;; before doing anything else change to the start-dir if provided
     ;;
     (if (args:get-arg "-start-dir")
         (if (common:file-exists? (args:get-arg "-start-dir"))
             (let ((fullpath (common:real-path (args:get-arg "-start-dir"))))
               (set-environment-variable! "PWD" fullpath)
               (change-directory fullpath)
               (set! *toppath* fullpath))
     	(begin
     	  (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.")
     	  (exit 1))))
    
     (set! *toppath* (get-environment-variable "PWD"))
     


     ;; immediately set MT_TARGET if -reqtarg or -target are available
     ;;
     (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target"))))
       (if targ 
        (begin
          (set-environment-variable! "MT_TARGET" targ)
          (mytarget targ)
        )
        )
       )
     
     ;; The watchdog is to keep an eye on things like db sync etc.
     ;;
;; (init-watchdog)
  
;;      (define (debug:debug-mode n)
;;        (cond

           (exit)))
     
     (if (args:get-arg "-version")
         (begin
           (print (common:version-signature)) ;; (print megatest-version)
           (exit)))
     


     ;; Overall exit handling setup immediately
     ;;
     (if (or (args:get-arg "-process-reap"))
             ;; (args:get-arg "-runtests")
     	;; (args:get-arg "-execute")
     	;; (args:get-arg "-remove-runs")
     	;; (args:get-arg "-runstep"))

     				       sheetname sectionname varname val)))
     		   (sqlite3:finalize! db)))
     		(else
     		 (pp data))))))
           (if out-file (close-output-port out-port))
           (exit) ;; yes, bending the rules here - need to exit since this is a utility
           ))

  ;; disabled for now
  
     #;(if (args:get-arg "-ping")
         (let* ((server-id     (string->number (args:get-arg "-ping"))) ;; extract run-id (i.e. no ":"
     	   (host:port     (args:get-arg "-ping")))
           (server-ready? (or server-id host:port) #f do-exit: #t)))
     
     ;;======================================================================
     ;; Capture, save and manipulate environments
     ;;======================================================================
     
     ;; NOTE: Keep these above the section where the server or client code is setup
     

         (bdat-time-to-exit-set! *bdat* #t)
         )
     ;;(debug:print-info 13 *default-log-port* "thread-join! watchdog")
     
     ;; join the watchdog thread if it has been thread-start!ed  (it may not have been started in the case of a server that never enters running state)
     ;;   (symbols returned by thread-state: created ready running blocked suspended sleeping terminated dead)
     ;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
     #;(let* ((watchdog (bdat-watchdog *bdat*)))
       (if (thread? watchdog)
	   (case (thread-state watchdog)
	     ((ready running blocked sleeping terminated dead)
	      (thread-join! watchdog)))))
     
     (bdat-time-to-exit-set! *bdat* #t)
     
     (if (not (eq? *globalexitstatus* 0))
         (if (or (args:get-arg "-run")(args:get-arg "-runtests")(args:get-arg "-runall"))
             (begin
	       (debug:print 0 *default-log-port* "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*)
	       (exit 0))
             (case *globalexitstatus*
	       ((0)(exit 0))
	       ((1)(exit 1))
	       ((2)(exit 2))
	       (else (exit 3)))))
     )

;; (import megatest-main commonmod)
;; (import srfi-18)

(thread-join!
 (thread-start!
  (make-thread main)))




)

;; 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 dbi))
(declare (uses pkts))
;; (declare (uses stml2))
;; (declare (uses cookie))
;; (declare (uses csv-xml))
;; (declare (uses hostinfo))

(declare (uses adjutant))
;; (declare (uses archivemod))
(declare (uses apimod))
;; (declare (uses autoload))
;; (declare (uses bigmod))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses dbmod))
(declare (uses debugprint))
;; (declare (uses ducttape-lib))
;; (declare (uses ezstepsmod))
(declare (uses launchmod))
(declare (uses mtargs))
(declare (uses mtver))
;; (declare (uses mutils))
(declare (uses processmod))
(declare (uses rmtmod))
;; (declare (uses runsmod))
;; (declare (uses servermod))
;; (declare (uses testsmod))
(declare (uses dbmgrmod))

;; needed for configf scripts, scheme etc.
;; (declare (uses apimod.import))
;; (declare (uses debugprint.import))
;; (declare (uses mtargs.import))
;; (declare (uses commonmod.import))
;; (declare (uses configfmod.import))
;; (declare (uses bigmod.import))
;; (declare (uses dbmod.import))
;; (declare (uses rmtmod.import))
;; (declare (uses servermod.import))
;; (declare (uses launchmod.import))

;; (include "call-with-environment-variables/call-with-environment-variables.scm")

(module mtserve
	*

  (import scheme

	  chicken.base
;;	  chicken.bitwise
;;	  chicken.condition
;;	  ;; chicken.csi
;;	  chicken.eval
;;	  chicken.file
;;	  chicken.file.posix
;;	  chicken.format
;;	  chicken.io
;;	  chicken.irregex
;;	  chicken.pathname
;;	  chicken.port
;;	  chicken.pretty-print
;;	  chicken.process
	  chicken.process-context
;;	  chicken.process-context.posix
;;	  chicken.process.signal
;;	  chicken.random
;;	  chicken.repl
;;	  chicken.sort
	  chicken.string
;;	  chicken.tcp
;;	  chicken.time
;;	  chicken.time.posix
;;	  
;;	  (prefix base64 base64:)
;;	  (prefix sqlite3 sqlite3:)
;;	  (prefix sxml-modifications sxml-)
;;	  address-info
;;	  csv-abnf
;;	  directory-utils
;;	  fmt
;;	  format
;;	  http-client
;;	  intarweb
;;	  json
;;	  linenoise
;;	  matchable
;;	  md5
;;	  message-digest
;;	  queues
;;	  regex
;;	  regex-case
;;	  s11n
;;	  sparse-vectors
;;	  spiffy
;;	  spiffy-directory-listing
;;	  spiffy-request-vars
;;	  sql-de-lite
;;	  stack
;;	  sxml-modifications
;;	  sxml-serializer
;;	  sxml-transforms
;;	  system-information
;;	  typed-records
;;	  uri-common
;;	  z3
;;	  
;;	  srfi-1
;;	  srfi-4
	  srfi-18
;;	  srfi-13
;;	  srfi-98
;;	  srfi-69
;;
;;	  ;; local modules
;;	  autoload
;;	  adjutant
;;	  csv-xml
;;	  ;; hostinfo
;;	  mtver
;;	  mutils
;;	  cookie
;;	  csv-xml
;;	  ducttape-lib
	  (prefix mtargs args:)
;;	  pkts
;;	  stml2
;;	  (prefix dbi dbi:)
;;
;;	  apimod
;;	  archivemod
;;	  bigmod
	  commonmod
;;	  configfmod
;;	  dbmod
	  debugprint
;;	  ezstepsmod
	  launchmod
;;	  processmod
;;	  rmtmod
;;	  runsmod
;;	  servermod
;;	  tasksmod
;;	  testsmod
	  dbmgrmod
;;	  
;;	  ulex
	  )

;;   ;; ulex parameters
;;   (work-method 'direct)
;;   (return-method 'direct)
  
  ;; ulex parameters
  ;; (work-method   'mailbox)
  ;; (return-method 'mailbox)

;; (my-with-lock common:with-simple-file-lock)
;;   
;; ;; fake out readline usage of toplevel-command
;; (define (toplevel-command . a) #f)
;; (define *didsomething* #f)  
;; (define *db* #f) ;; this is only for the repl, do not use in general!!!!
;; 
;; ;; (include "common_records.scm")
;; ;; (include "key_records.scm")
;; ;; (include "db_records.scm")
;; (include "run_records.scm")
;; ;; (include "test_records.scm")
;; 
;; ;; (include "common.scm")
;; (include "db.scm")
;; ;; (include "server.scm")
;; (include "tests.scm")
;; (include "genexample.scm")
;; (include "tdb.scm")
;; (include "env.scm")
;; (include "diff-report.scm")
;; (include "ods.scm")
;; 

  ;; process args
  (define remargs (args:get-args 
      		   (argv)
      		   (list  ;; "-runtests"  ;; run a specific test
      			  ;; "-config"    ;; override the config file name
      			  ;; "-append-config"
      			  ;; "-execute"   ;; run the command encoded in the base64 parameter
      			  ;; "-step"
      			  ;; "-target"
      			  ;; "-reqtarg"
      			  ;; ":runname"
      			  ;; "-runname"
      			  ;; ":state"  
      			  ;; "-state"
      			  ;; ":status"
      			  ;; "-status"
      			  ;; "-list-runs"
 			  ;; "-testdata-csv"
      			  ;; "-testpatt"
 			  ;; "--modepatt"
 			  ;; "-modepatt"
 			  ;; "-tagexpr"
      			  ;; "-itempatt"
      			  ;; "-setlog"
      			  ;; "-set-toplog"
      			  ;; "-runstep"
      			  ;; "-logpro"
      			  ;; "-m"
      			  ;; "-rerun"
			  ;; 
      			  ;; "-days"
      			  ;; "-rename-run"
      			  ;; "-to"
      			  ;; "-dest"
 			  ;; "-source" 
 			  ;; "-time-stamp" 
      			  ;; ;; values and messages
      			  ;; ":category"
      			  ;; ":variable"
      			  ;; ":value"
      			  ;; ":expected"
      			  ;; ":tol"
      			  ;; ":units"
			  ;; 
      			  ;; ;; misc
      			  ;; "-start-dir"
 			  ;; "-run-patt"
 			  ;; "-target-patt"   
      			  ;; "-contour"
 			  ;; "-area-tag"  
 			  ;; "-area"  
      			  ;; "-run-tag"
      			  "-server"
 			  "-db"            ;; file name for setting up a server
      			  ;; "-adjutant"
      			  ;; "-transport"
      			  ;; "-port"
      			  ;; "-extract-ods"
      			  ;; "-pathmod"
      			  ;; "-env2file"
      			  ;; "-envcap"
      			  ;; "-envdelta"
      			  ;; "-setvars"
      			  ;; "-set-state-status"
 			  ;; 
 			  ;; ;; move runs stuff here
 			  ;; "-remove-keep"           
      			  ;; "-set-run-status"
      			  ;; "-age"
			  ;; 
      			  ;; ;; archive 
      			  ;; "-archive"
      			  ;; "-actions"
      			  ;; "-precmd"
      			  ;; "-include"
      			  ;; "-exclude-rx"
      			  ;; "-exclude-rx-from"
      			  ;; 
      			  "-debug" ;; for *verbosity* > 2
      			  ;; "-debug-noprop"
      			  ;; "-create-test"
      			  ;; "-override-timeout"
      			  ;; "-test-files"  ;; -test-paths is for listing all
      			  ;; "-load"        ;; load and exectute a scheme file
      			  ;; "-section"
      			  ;; "-var"
      			  ;; "-dumpmode"
      			  ;; "-run-id"
      			  ;; "-ping"
      			  ;; "-refdb2dat"
      			  ;; "-o"
      			  ;; "-log"
 			  ;; "-autolog"
 			  ;; "-sync-log"
      			  ;; "-since"
      			  ;; "-fields"
      			  ;; "-recover-test" ;; run-id,test-id - used internally to recover a test stuck in RUNNING state
      			  ;; "-sort"
      			  ;; "-target-db"
      			  ;; "-source-db"
      			  ;; "-prefix-target"
			  ;; 
 			  ;; "-src-target"
 			  ;; "-src-runname"
 			  ;; "-diff-email"
      			  ;; "-sync-to"			
      			  ;; "-pgsync"
      			  ;; "-kill-wait"    ;; wait this long before removing test (default is 10 sec)
 			  ;; "-diff-html"
			  ;; 
      			  ;; ;; wizards, area capture, setup new ...
      			  ;; "-extract-skeleton"
      			  )
       		   (list  "-h" "-help" "--help"
      			  ;; "-manual"
      			  "-version"
      		          ;; "-force"
      		          ;; "-xterm"
      		          ;; "-showkeys"
      		          ;; "-show-keys"
      		          ;; "-test-status"
      			  ;; "-set-values"
      			  ;; "-load-test-data"
      			  ;; "-summarize-items"
      		          ;; "-gui"
      			  ;; "-daemonize"
      			  ;; "-preclean"
      			  ;; "-rerun-clean"
      			  ;; "-rerun-all"
      			  ;; "-clean-cache"
      			  ;; "-no-cache"
      			  ;; "-cache-db"
      			  ;; "-cp-eventtime-to-publishtime"
                          ;; "-use-db-cache"
                          ;; "-prepend-contour"
			  ;; 
			  ;; 
      			  ;; ;; misc
      			  ;; "-repl"
      			  ;; "-lock"
      			  ;; "-unlock"
      			  ;; "-list-servers"
      			  ;; "-kill-servers"
 			  ;; "-run-wait"      ;; wait on a run to complete (i.e. no RUNNING)
      			  ;; "-one-pass"      ;;
      			  ;; "-local"         ;; run some commands using local db access
      			  ;; "-generate-html"
      			  ;; "-generate-html-structure" 
      			  ;; "-list-run-time"
                          ;; "-list-test-time"
      			  ;; 
      			  ;; ;; misc queries
      			  ;; "-list-disks"
      			  ;; "-list-targets"
      			  ;; "-list-db-targets"
      			  ;; "-show-runconfig"
      			  ;; "-show-config"
      			  ;; "-show-cmdinfo"
      			  ;; "-get-run-status"
      			  ;; "-list-waivers"
			  ;; 
      			  ;; ;; queries
      			  ;; "-test-paths" ;; get path(s) to a test, ordered by youngest first
			  ;; 
      			  ;; "-runall"    ;; run all tests, respects -testpatt, defaults to %
      			  ;; "-run"       ;; alias for -runall
      			  ;; "-remove-runs"
                          ;; "-kill-runs"
                          ;; "-kill-rerun"
                          ;; "-keep-records" ;; use with -remove-runs to remove only the run data
      			  ;; "-rebuild-db"
      			  ;; "-cleanup-db"
      			  ;; "-rollup"
      			  ;; "-update-meta"
      			  ;; "-create-megatest-area"
      			  ;; "-mark-incompletes"
			  ;; 
      			  ;; "-convert-to-norm"
      			  ;; "-convert-to-old"
      			  ;; "-import-megatest.db"
      			  ;; "-sync-to-megatest.db"
 			  ;; "-sync-brute-force"
      			  ;; "-logging"
      			  ;; "-v" ;; verbose 2, more than normal (normal is 1)
      			  ;; "-q" ;; quiet 0, errors/warnings only
			  ;; 
                          ;; "-diff-rep"
			  ;; 
      			  ;; "-syscheck"
      			  ;; "-obfuscate"
      			  ;; junk placeholder
      			  ;; "-:p"
      			  
                          )
      		   args:arg-hash
      		   0))
  
  ;; Add args that use remargs here
  ;;
  (if (not (null? remargs))
      (debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv))  " ")))
  
  ;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file
  ;;
  (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.mtserverc")))
    (if (common:file-exists? debugcontrolf)
	(load debugcontrolf)))
  
  ;; before doing anything else change to the start-dir if provided
  ;;
  (if (args:get-arg "-start-dir")
      (if (common:file-exists? (args:get-arg "-start-dir"))
          (let ((fullpath (common:real-path (args:get-arg "-start-dir"))))
            (set-environment-variable! "PWD" fullpath)
            (change-directory fullpath))
      	  (begin
      	    (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.")
      	    (exit 1))))
  

  (define (main)
    (debug:setup)
    (make-and-init-bigdata) 
    (let ((tl        (launch:setup))
 	  (dbname    (args:get-arg "-db")))
      (if dbname
	  (rmt:server-launch dbname)
	  (debug:print 0 *default-log-port* "Usage: mtserve -db <dbpath/file>.db"))))
  #;(set! *didsomething* #t)
  
  
  (thread-join!
   (thread-start!
    (make-thread main)))

)

;; (define *usage-log-file* #f)    ;; put path to file for logging usage in this var in the ~/.megatestrc file
;; (define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file
;; 
;; ;;======================================================================
;; ;; Test commands (i.e. for use inside tests)
;; ;;======================================================================
;; 
;; (define (megatest:step step state status logfile msg)
;;   (if (not (get-environment-variable "MT_CMDINFO"))
;;       (begin
;;      	(debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!")
;;      	(exit 5))
;;       (let* ((cmdinfo   (common:read-encoded-string (get-environment-variable "MT_CMDINFO")))
;;      	     (transport (assoc/default 'transport cmdinfo))
;;      	     (testpath  (assoc/default 'testpath  cmdinfo))
;;      	     (test-name (assoc/default 'test-name cmdinfo))
;;      	     (runscript (assoc/default 'runscript cmdinfo))
;;      	     (db-host   (assoc/default 'db-host   cmdinfo))
;;      	     (run-id    (assoc/default 'run-id    cmdinfo))
;;      	     (test-id   (assoc/default 'test-id   cmdinfo))
;;      	     (itemdat   (assoc/default 'itemdat   cmdinfo))
;;      	     (work-area (assoc/default 'work-area cmdinfo))
;;      	     (db        #f))
;;      	(change-directory testpath)
;;      	(if (not (launch:setup))
;;      	    (begin
;;      	      (debug:print 0 *default-log-port* "Failed to setup, exiting")
;;      	      (exit 1)))
;;      	(if (and state status)
;;      	    (let ((comment (launch:load-logpro-dat run-id test-id step)))
;;      	      ;; (rmt:test-set-log! run-id test-id (conc stepname ".html"))))
;;      	      (rmt:teststep-set-status! run-id test-id step state status (or comment msg) logfile))
;;      	    (begin
;;      	      (debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -step")
;;      	      (exit 6))))))
;; 
;; ;;======================================================================
;; ;; full run
;; ;;======================================================================
;; 
;; (define (handle-run-requests target runname keys keyvals need-clean)	 
;;   (if (or (args:get-arg "-kill-rerun") (args:get-arg "-rerun-clean")) ;; first set states/statuses correct
;;       ;; For rerun-clean do we or do we not support the testpatt?
;;       (let ((states   (or (configf:lookup *configdat* "validvalues" "cleanrerun-states")
;;      			  "KILLREQ,KILLED,UNKNOWN,INCOMPLETE,STUCK,NOT_STARTED"))
;;      	    (statuses (or (configf:lookup *configdat* "validvalues" "cleanrerun-statuses")
;;      			  "FAIL,INCOMPLETE,ABORT,CHECK,DEAD,PREQ_FAIL,PREQ_DISCARDED")))
;;      	(hash-table-set! args:arg-hash "-preclean" #t)
;;      	(runs:operate-on 'set-state-status
;;      			 target
;;      			 (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
;;      			 ;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
;;      			 (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
;;      			 state:  states
;;      			 ;; status: statuses
;;      			 new-state-status: "NOT_STARTED,n/a")
;;      	(runs:clean-cache target runname *toppath*)
;;      	(runs:operate-on 'set-state-status
;;      			 target
;;      			 (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
;;      			 ;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
;;      			 (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
;;      			 ;; state:  states
;;      			 status: statuses
;;      			 new-state-status: "NOT_STARTED,n/a")))
;;   ;; RERUN ALL
;;   (if (args:get-arg "-rerun-all") ;; first set states/statuses correct
;;       (let* ((rconfig (full-runconfigs-read)))
;;      	(hash-table-set! args:arg-hash "-preclean" #t)
;;      	(runs:operate-on 'set-state-status
;;      			 target
;;      			 (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
;;      			 (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt")
;;      			 state:  #f
;;      			 ;; status: statuses
;;      			 new-state-status: "NOT_STARTED,n/a")
;;      	(runs:clean-cache target runname *toppath*)
;;      	(runs:operate-on 'set-state-status
;;      			 target
;;      			 (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
;;      			 (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt")
;;      			 ;; state:  states
;;      			 status: #f
;;      			 new-state-status: "NOT_STARTED,n/a")))
;;   (let* ((config-reruns      (let ((x (configf:lookup *configdat* "setup" "reruns")))
;;      			       (if x (string->number x) #f)))
;;      	 (rerun-cnt (if config-reruns
;;      			config-reruns
;;      			1)))
;;     
;;     (runs:run-tests target
;;      		    runname
;;      		    #f ;; (common:args-get-testpatt #f)
;;      		    ;; (or (args:get-arg "-testpatt")
;;      		    ;;     "%")
;;      		    (bdat-user *bdat*)
;;      		    args:arg-hash
;;      		    run-count: rerun-cnt)))
;; 
;; ;; csv processing record
;; (define (make-refdb:csv)
;;   (vector 
;;    (make-sparse-array)
;;    (make-hash-table)
;;    (make-hash-table)
;;    0
;;    0))
;; (define-inline (refdb:csv-get-svec     vec)    (vector-ref  vec 0))
;; (define-inline (refdb:csv-get-rows     vec)    (vector-ref  vec 1))
;; (define-inline (refdb:csv-get-cols     vec)    (vector-ref  vec 2))
;; (define-inline (refdb:csv-get-maxrow   vec)    (vector-ref  vec 3))
;; (define-inline (refdb:csv-get-maxcol   vec)    (vector-ref  vec 4))
;; (define-inline (refdb:csv-set-svec!    vec val)(vector-set! vec 0 val))
;; (define-inline (refdb:csv-set-rows!    vec val)(vector-set! vec 1 val))
;; (define-inline (refdb:csv-set-cols!    vec val)(vector-set! vec 2 val))
;; (define-inline (refdb:csv-set-maxrow!  vec val)(vector-set! vec 3 val))
;; (define-inline (refdb:csv-set-maxcol!  vec val)(vector-set! vec 4 val))
;; 
;; (define (get-dat results sheetname)
;;   (or (hash-table-ref/default results sheetname #f)
;;       (let ((tmp-vec  (make-refdb:csv)))
;;      	(hash-table-set! results sheetname tmp-vec)
;;      	tmp-vec)))
;; 
;; ;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions
;; (define (open-logfile logpath-in)
;;   (condition-case
;;    (let* ((log-dir (or (pathname-directory logpath-in) "."))
;;      	  (fname   (pathname-strip-directory logpath-in))
;;      	  (logpath (if (> (string-length fname) 250)
;;      		       (let ((newlogf (conc log-dir "/" (common:get-signature fname) ".log")))
;;      			 (debug:print 0 *default-log-port* "WARNING: log file " logpath-in " path too long, converted to " newlogf)
;;      			 newlogf)
;;      		       logpath-in)))
;;      (if (not (directory-exists? log-dir))
;; 	 (system (conc "mkdir -p " log-dir)))
;;      (open-output-file logpath))
;;    (exn ()
;; 	(debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath-in)
;; 	(set! *didsomething* #t)
;; 	(exit 1))))
;; 
;; ;; Disabled help items
;; ;;  -rollup                 : (currently disabled) fill run (set by :runname)  with latest test(s)
;; ;;                            from prior runs with same keys
;; ;;  -daemonize              : fork into background and disconnect from stdin/out
;; 
;; (define help (conc "
;; Megatest, documentation at http://www.kiatoa.com/fossils/megatest
;;   version " megatest-version "
;;   license GPL, Copyright Matt Welland 2006-2017
;;  
;; Usage: megatest [options]
;;   -h                      : this help
;;   -manual                 : show the Megatest user manual
;;   -version                : print megatest version (currently " megatest-version ")
;; 
;; Launching and managing runs
;;   -run                    : run all tests or as specified by -testpatt
;;   -remove-runs            : remove the data for a run, requires -runname and -testpatt
;;                             Optionally use :state and :status, use -keep-records to remove only
;;                             the run data. Use -kill-wait to override the 10 second
;;                             per test wait after kill delay (e.g. -kill-wait 0). 
;;   -kill-runs              : kill existing run(s) (all incomplete tests killed)
;;   -kill-rerun             : kill an existing run (all incomplete tests killed and run is rerun)
;;   -set-state-status X,Y   : set state to X and status to Y, requires controls per -remove-runs
;;   -rerun FAIL,WARN...     : force re-run for tests with specificed status(s)
;;   -rerun-clean            : set all tests not COMPLETED+PASS,WARN,WAIVED to NOT_STARTED,n/a
;;                             and then run the specified testpatt with -preclean
;;   -rerun-all              : set all tests to NOT_STARTED,n/a and run with -preclean
;;   -lock                   : lock run specified by target and runname
;;   -unlock                 : unlock run specified by target and runname
;;   -set-run-status status  : sets status for run to status, requires -target and -runname
;;   -get-run-status         : gets status for run specified by target and runname
;;   -run-wait               : wait on run specified by target and runname
;;   -preclean               : remove the existing test directory before running the test
;;   -clean-cache            : remove the cached megatest.config and runconfigs.config files
;;   -no-cache               : do not use the cached config files. 
;;   -one-pass               : launch as many tests as you can but do not wait for more to be ready
;;   -remove-keep N          : remove all but N most recent runs per target; use '-actions, -age, -precmd'
;;   -age <age>              : 120d,3h,20m to apply only to runs older than the 
;;                                  specified age. NB// M=month, m=minute
;;   -actions <action>[,...] : actions to take; print,remove-runs,archive,kill-runs
;;   -precmd                 : insert a wrapper command in front of the commands run
;; 
;; Selectors (e.g. use for -runtests, -remove-runs, -set-state-status, -list-runs etc.)
;;   -target key1/key2/...   : run for key1, key2, etc.
;;   -reqtarg key1/key2/...  : run for key1, key2, etc. but key1/key2 must be in runconfigs
;;   -testpatt patt1/patt2,patt3/...  : % is wildcard
;;   -runname                : required, name for this particular test run
;;   -state                  : Applies to runs, tests or steps depending on context
;;   -status                 : Applies to runs, tests or steps depending on context
;;   -modepatt key           : load testpatt from <key> in runconfigs instead of default TESTPATT if -testpatt and -tagexpr are not specified
;;   -tagexpr tag1,tag2%,..  : select tests with tags matching expression
;;   
;; 
;; Test helpers (for use inside tests)
;;   -step stepname
;;   -test-status            : set the state and status of a test (use :state and :status)
;;   -setlog logfname        : set the path/filename to the final log relative to the test
;;                             directory. may be used with -test-status
;;   -set-toplog logfname    : set the overall log for a suite of sub-tests
;;   -summarize-items        : for an itemized test create a summary html 
;;   -m comment              : insert a comment for this test
;; 
;; Test data capture
;;   -set-values             : update or set values in the testdata table
;;   :category               : set the category field (optional)
;;   :variable               : set the variable name (optional)
;;   :value                  : value measured (required)
;;   :expected               : value expected (required)
;;   :tol                    : |value-expect| <= tol (required, can be <, >, >=, <= or number)
;;   :units                  : name of the units for value, expected_value etc. (optional)
;;   -load-test-data         : read test specific data for storage in the test_data table
;;                             from standard in. Each line is comma delimited with four
;;                             fields category,variable,value,comment
;; 
;; Queries
;;   -list-runs patt         : list runs matching pattern \"patt\", % is the wildcard
;;   -show-keys              : show the keys used in this megatest setup
;;   -test-files targpatt    : get the most recent test path/file matching targpatt e.g. %/% or '*.log'
;;                             returns list sorted by age ascending, see examples below
;;   -test-paths             : get the test paths matching target, runname, item and test
;;                             patterns.
;;   -list-disks             : list the disks available for storing runs
;;   -list-targets           : list the targets in runconfigs.config
;;   -list-db-targets        : list the target combinations used in the db
;;   -show-config            : dump the internal representation of the megatest.config file
;;   -show-runconfig         : dump the internal representation of the runconfigs.config file
;;   -dumpmode MODE          : dump in MODE format instead of sexpr, MODE=json,ini,sexp etc. (add -debug 0,9 to see which file contributes each line)
;;   -show-cmdinfo           : dump the command info for a test (run in test environment)
;;   -section sectionName
;;   -var varName            : for config and runconfig lookup value for sectionName varName
;;   -since N                : get list of runs changed since time N (Unix seconds)
;;   -fields fieldspec       : fields to include in json dump; runs:id,runame+tests:testname+steps
;;   -sort fieldname         : in -list-runs sort tests by this field
;;   -testdata-csv [categorypatt/]varpatt  : dump testdata for given category
;; 
;; Misc 
;;   -start-dir path         : switch to this directory before running megatest
;;   -contour cname          : add a level of hierarcy to the linktree and run paths
;;   -area-tag tagname       : add a tag to an area while syncing to pgdb
;;   -run-tag tagname        : add a tag to a run while syncing to pgdb
;;   -rebuild-db             : bring the database schema up to date
;;   -cleanup-db             : remove any orphan records, vacuum the db
;;   -import-megatest.db     : push data from megatest.db to cache db files in /tmp/$USER
;;   -sync-to-megatest.db    : pull data from cache files in /tmp/$USER to megatest.db
;;   -sync-to dest           : sync to new postgresql central style database
;;   -update-meta            : update the tests metadata for all tests
;;   -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are
;;                                  overwritten by values set in config files.
;;   -server -|hostname      : start the server (reduces contention on megatest.db), use
;;                             - to automatically figure out hostname
;;   -adjutant C,M           : start the server/adjutant with allocated cores C and Mem M (Gig), 
;;                             use 0,0 to auto use full machine
;;   -transport http|rpc     : use http or rpc for transport (default is http) 
;;   -log logfile            : send stdout and stderr to logfile
;;   -autolog logfilebase    : appends pid and host to logfilebase for logfile
;;   -list-servers           : list the servers 
;;   -kill-servers           : kill all servers
;;   -repl                   : start a repl (useful for extending megatest)
;;   -load file.scm          : load and run file.scm
;;   -mark-incompletes       : find and mark incomplete tests
;;   -ping run-id|host:port  : ping server, exit with 0 if found
;;   -debug N|N,M,O...       : enable debug 0-N or N and M and O ...
;;   -debug-noprop N|M,M,O...: enable debug but do not propagate to subprocesses via MT_DEBUG
;;   -config fname           : override the megatest.config file with fname
;;   -append-config fname    : append fname to the megatest.config file
;; 
;; Utilities
;;   -env2file fname         : write the environment to fname.csh and fname.sh
;;   -envcap a               : save current variables labeled as context 'a' in file envdat.db
;;   -envdelta a-b           : output enviroment delta from context a to context b to -o fname
;;                             set the output mode with -dumpmode csh, bash or ini
;;                             note: ini format will use calls to use curr and minimize path
;;   -refdb2dat refdb        : convert refdb to sexp or to format specified by s-dumpmode
;;                             formats: perl, ruby, sqlite3, csv (for csv the -o param
;;                             will substitute %s for the sheet name in generating 
;;                             multiple sheets)
;;   -o                      : output file for refdb2dat (defaults to stdout)
;;   -archive cmd            : archive runs specified by selectors to one of disks specified
;;                             in the [archive-disks] section.
;;                             cmd: keep-html, restore, save, save-remove, get, replicate-db (use 
;;                             -dest to set destination), -include path1,path2... to get or save specific files
;;   -generate-html          : create a simple html dashboard for browsing your runs
;;   -generate-html-structure  : create a top level html veiw to list targets/runs and a Run view within each run directory.  
;;   -list-run-time          : list time requered to complete runs. It supports following switches
;;                             -run-patt <patt> -target-patt <patt> -dumpmode <csv,json,plain-text>
;;   -list-test-time	  : list time requered to complete each test in a run. It following following arguments
;;                             -runname <patt> -target <patt> -dumpmode <csv,json,plain-text>
;;   -syscheck               : do some very basic checks; write access and space in tmp, home, runs, links and 
;;                             is $DISPLAY valid 
;;   -list-waivers           : dump waivers for specified target, runname, testpatt to stdout
;; 
;; Diff report
;;   -diff-rep               : generate diff report (must include -src-target, -src-runname, -target, -runname
;;                                                   and either -diff-email or -diff-html)
;;   -src-target <target>
;;   -src-runname <target>
;;   -diff-email <emails>    : comma separated list of email addresses to send diff report
;;   -diff-html  <rep.html>  : path to html file to generate
;; 
;; Spreadsheet generation
;;   -extract-ods fname.ods  : extract an open document spreadsheet from the database
;;   -pathmod path           : insert path, i.e. path/runame/itempath/logfile.html
;;                             will clear the field if no rundir/testname/itempath/logfile
;;                             if it contains forward slashes the path will be converted
;;                             to windows style
;; Getting started
;;   -create-megatest-area   : create a skeleton megatest area. You will be prompted for paths
;;   -create-test testname   : create a skeleton megatest test. You will be prompted for info
;; 
;; Examples
;; 
;; # Get test path, use '.' to get a single path or a specific path/file pattern
;; megatest -test-files 'logs/*.log' -target ubuntu/n%/no% -runname w49% -testpatt test_mt%
;; 
;; Called as " (string-intersperse (argv) " ") "
;; Version " megatest-version ", built from " megatest-fossil-hash ))
;;      
;; (define (main)
;;   (make-and-init-bigdata)
;; 
;; ;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file
;; ;;
;; (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc")))
;;   (if (common:file-exists? debugcontrolf)
;;       (load debugcontrolf)))
;; 
;; ;; usage logging, careful with this, it is not designed to deal with all real world challenges!
;; ;;
;; (if (and *usage-log-file*
;; 	 (file-writable? *usage-log-file*))
;;     (with-output-to-file
;; 	*usage-log-file*
;;       (lambda ()
;; 	(print
;; 	 (if *usage-use-seconds*
;; 	     (current-seconds)
;; 	     (time->string
;; 	      (seconds->local-time (current-seconds))
;; 	      "%Yww%V.%w %H:%M:%S"))
;; 	 " "
;; 	 (current-user-name) " "
;; 	 (current-directory) " "
;; 	 "\"" (string-intersperse (argv) " ") "\""))
;;       #:append))
;; 
;;      ;;  -gui                    : start a gui interface
;;      ;;  -config fname           : override the runconfigs file with fname
;;      
;;      ;; process args
;;      (define remargs (args:get-args 
;;      		 (argv)
;;      		 (list  "-runtests"  ;; run a specific test
;;      			"-config"    ;; override the config file name
;;      			"-append-config"
;;      			"-execute"   ;; run the command encoded in the base64 parameter
;;      			"-step"
;;      			"-target"
;;      			"-reqtarg"
;;      			":runname"
;;      			"-runname"
;;      			":state"  
;;      			"-state"
;;      			":status"
;;      			"-status"
;;      			"-list-runs"
;; 			"-testdata-csv"
;;      			"-testpatt"
;; 			"--modepatt"
;; 			"-modepatt"
;; 			"-tagexpr"
;;      			"-itempatt"
;;      			"-setlog"
;;      			"-set-toplog"
;;      			"-runstep"
;;      			"-logpro"
;;      			"-m"
;;      			"-rerun"
;;      
;;      			"-days"
;;      			"-rename-run"
;;      			"-to"
;;      			"-dest"
;; 			"-source" 
;; 			"-time-stamp" 
;;      			;; values and messages
;;      			":category"
;;      			":variable"
;;      			":value"
;;      			":expected"
;;      			":tol"
;;      			":units"
;;      
;;      			;; misc
;;      			"-start-dir"
;; 			"-run-patt"
;; 			"-target-patt"   
;;      			"-contour"
;; 			"-area-tag"  
;; 			"-area"  
;;      			"-run-tag"
;;      			"-server"
;; 			"-db"            ;; file name for setting up a server
;;      			"-adjutant"
;;      			"-transport"
;;      			"-port"
;;      			"-extract-ods"
;;      			"-pathmod"
;;      			"-env2file"
;;      			"-envcap"
;;      			"-envdelta"
;;      			"-setvars"
;;      			"-set-state-status"
;; 			
;; 			;; move runs stuff here
;; 			"-remove-keep"           
;;      			"-set-run-status"
;;      			"-age"
;;      
;;      			;; archive 
;;      			"-archive"
;;      			"-actions"
;;      			"-precmd"
;;      			"-include"
;;      			"-exclude-rx"
;;      			"-exclude-rx-from"
;;      			
;;      			"-debug" ;; for *verbosity* > 2
;;      			"-debug-noprop"
;;      			"-create-test"
;;      			"-override-timeout"
;;      			"-test-files"  ;; -test-paths is for listing all
;;      			"-load"        ;; load and exectute a scheme file
;;      			"-section"
;;      			"-var"
;;      			"-dumpmode"
;;      			"-run-id"
;;      			"-ping"
;;      			"-refdb2dat"
;;      			"-o"
;;      			"-log"
;; 			"-autolog"
;; 			"-sync-log"
;;      			"-since"
;;      			"-fields"
;;      			"-recover-test" ;; run-id,test-id - used internally to recover a test stuck in RUNNING state
;;      			"-sort"
;;      			"-target-db"
;;      			"-source-db"
;;      			"-prefix-target"
;;      
;; 			"-src-target"
;; 			"-src-runname"
;; 			"-diff-email"
;;      			"-sync-to"			
;;      			"-pgsync"
;;      			"-kill-wait"    ;; wait this long before removing test (default is 10 sec)
;; 			"-diff-html"
;;      
;;      			;; wizards, area capture, setup new ...
;;      			"-extract-skeleton"
;;      			)
;;       		 (list  "-h" "-help" "--help"
;;      			"-manual"
;;      			"-version"
;;      		        "-force"
;;      		        "-xterm"
;;      		        "-showkeys"
;;      		        "-show-keys"
;;      		        "-test-status"
;;      			"-set-values"
;;      			"-load-test-data"
;;      			"-summarize-items"
;;      		        "-gui"
;;      			"-daemonize"
;;      			"-preclean"
;;      			"-rerun-clean"
;;      			"-rerun-all"
;;      			"-clean-cache"
;;      			"-no-cache"
;;      			"-cache-db"
;;      			"-cp-eventtime-to-publishtime"
;;                              "-use-db-cache"
;;                              "-prepend-contour"
;;      
;;      
;;      			;; misc
;;      			"-repl"
;;      			"-lock"
;;      			"-unlock"
;;      			"-list-servers"
;;      			"-kill-servers"
;; 			"-run-wait"      ;; wait on a run to complete (i.e. no RUNNING)
;;      			"-one-pass"      ;;
;;      			"-local"         ;; run some commands using local db access
;;      			"-generate-html"
;;      			"-generate-html-structure" 
;;      			"-list-run-time"
;;                              "-list-test-time"
;;      			
;;      			;; misc queries
;;      			"-list-disks"
;;      			"-list-targets"
;;      			"-list-db-targets"
;;      			"-show-runconfig"
;;      			"-show-config"
;;      			"-show-cmdinfo"
;;      			"-get-run-status"
;;      			"-list-waivers"
;;      
;;      			;; queries
;;      			"-test-paths" ;; get path(s) to a test, ordered by youngest first
;;      
;;      			"-runall"    ;; run all tests, respects -testpatt, defaults to %
;;      			"-run"       ;; alias for -runall
;;      			"-remove-runs"
;;                              "-kill-runs"
;;                              "-kill-rerun"
;;                              "-keep-records" ;; use with -remove-runs to remove only the run data
;;      			"-rebuild-db"
;;      			"-cleanup-db"
;;      			"-rollup"
;;      			"-update-meta"
;;      			"-create-megatest-area"
;;      			"-mark-incompletes"
;;      
;;      			"-convert-to-norm"
;;      			"-convert-to-old"
;;      			"-import-megatest.db"
;;      			"-sync-to-megatest.db"
;; 			"-sync-brute-force"
;;      			"-logging"
;;      			"-v" ;; verbose 2, more than normal (normal is 1)
;;      			"-q" ;; quiet 0, errors/warnings only
;;      
;;                              "-diff-rep"
;;      
;;      			"-syscheck"
;;      			"-obfuscate"
;;      			;; junk placeholder
;;      			;; "-:p"
;;      			
;;                              )
;;      		 args:arg-hash
;;      		 0))
;;      
;;      ;; Add args that use remargs here
;;      ;;
;;      (if (and (not (null? remargs))
;;      	 (not (or
;;      	       (args:get-arg "-runstep")
;;      	       (args:get-arg "-envcap")
;;      	       (args:get-arg "-envdelta")
;;      	       )
;;      	      ))
;;          (debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv))  " ")))
;;      
;;      ;; before doing anything else change to the start-dir if provided
;;      ;;
;;      (if (args:get-arg "-start-dir")
;;          (if (common:file-exists? (args:get-arg "-start-dir"))
;;              (let ((fullpath (common:real-path (args:get-arg "-start-dir"))))
;;                (set-environment-variable! "PWD" fullpath)
;;                (change-directory fullpath))
;;      	(begin
;;      	  (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.")
;;      	  (exit 1))))
;;      
;;      ;; immediately set MT_TARGET if -reqtarg or -target are available
;;      ;;
;;      (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target"))))
;;        (if targ (set-environment-variable! "MT_TARGET" targ)))
;;      
;;      ;; The watchdog is to keep an eye on things like db sync etc.
;;      ;;
;; ;; (init-watchdog)
;;   
;; ;;      (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))))
;; 
;;      ;; this segment will run launch:setup only if -log is not set. This is fairly safe as servers are not
;;      ;; manually started and thus should never be started in a non-megatest area. Thus no need to handle situation
;;      ;; where (launch:setup) returns #f?
;;      ;;
;;      (if (or (args:get-arg "-log") ;;(args:get-arg "-server") ;; redirect the log always when a server
;; 	     (args:get-arg "-autolog"))
;;          (handle-exceptions
;;      	exn
;;      	(begin
;;      	  (print "ERROR: Failed to switch to log output. " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
;;      	  )
;;         (let* ((tl   (or (args:get-arg "-log")
;; 			 (args:get-arg "-autolog") ;; autolog provides the basename .../logs/something- for the logfile
;; 			 (launch:setup)))   ;; run launch:setup if -server, ensure we do NOT run launch:setup if -log specified
;;      	       (logf (or (args:get-arg "-log") ;; use -log unless we are a server, then craft a logfile name
;; 			 (conc tl (current-process-id)"-"(get-host-name)".log")
;;      			 (conc tl "/logs/server-" (current-process-id) "-" (get-host-name) ".log")))
;;      	       (oup  (open-logfile logf)))
;;      	(if (not (args:get-arg "-log"))
;;      	    (hash-table-set! args:arg-hash "-log" logf)) ;; fake out future queries of -log
;;      	(debug:print-info 0 *default-log-port* "Sending log output to " logf)
;;      	(set! *default-log-port* oup))))
;;      
;;      (if (or (args:get-arg "-h")
;;      	(args:get-arg "-help")
;;      	(args:get-arg "--help"))
;;          (begin
;;            (print help)
;;            (exit)))
;;      
;;      (if (args:get-arg "-manual")
;;          (let* ((htmlviewercmd (or (configf:lookup *configdat* "setup" "htmlviewercmd")
;;      			      (common:which '("firefox" "arora"))))
;;      	   (install-home  (common:get-install-area))
;;      	   (manual-html   (conc install-home "/share/docs/megatest_manual.html")))
;;            (if (and install-home
;;      	       (common:file-exists? manual-html))
;;      	  (system (conc "(" htmlviewercmd " " manual-html " ) &"))
;;      	  (system (conc "(" htmlviewercmd " http://www.kiatoa.com/cgi-bin/fossils/megatest/doc/tip/docs/manual/megatest_manual.html ) &")))
;;            (exit)))
;;      
;;      (if (args:get-arg "-version")
;;          (begin
;;            (print (common:version-signature)) ;; (print megatest-version)
;;            (exit)))
;;      
;;      ;; Overall exit handling setup immediately
;;      ;;
;;      (if (or (args:get-arg "-process-reap"))
;;              ;; (args:get-arg "-runtests")
;;      	;; (args:get-arg "-execute")
;;      	;; (args:get-arg "-remove-runs")
;;      	;; (args:get-arg "-runstep"))
;;          (let ((original-exit (exit-handler)))
;;            (exit-handler (lambda (#!optional (exit-code 0))
;;      		      (printf "Preparing to exit with exit code ~A ...\n" exit-code)
;;      		      (for-each
;;      		       
;;      		       (lambda (pid)
;;      			 (handle-exceptions
;;      			     exn
;;      			   (begin
;;      			     (printf "process reap failed. exn=~A\n" exn)
;;      			     #t)
;;      			  (let-values (((pid-val exit-status exit-code) (process-wait pid #t)))
;;      				      (if (or (eq? pid-val pid)
;;      					      (eq? pid-val 0))
;;      					  (begin
;;      					    (printf "Sending signal/term to ~A\n" pid)
;;      					    (process-signal pid signal/term))))))
;;      		       (process:children #f))
;;      		      (original-exit exit-code)))))
;;      
;;      ;; for some switches always print the command to stderr
;;      ;;
;;      (if (args:any-defined? "-run" "-runall" "-remove-runs" "-set-state-status" "-kill-runs" "-kill-rerun")
;;          (debug:print 0 *default-log-port* (string-intersperse (argv) " ")))
;;      
;;      ;; some switches imply homehost. Exit here if not on homehost
;;      ;;
;;      #;(let ((homehost-required  (list "-cleanup-db" "-server")))
;;        (if (apply args:any-defined? homehost-required)
;;            (if (not (common:on-homehost?))
;;      	  (for-each
;;      	   (lambda (switch)
;;      	     (if (args:get-arg switch)
;;      		 (begin
;;      		   (debug:print 0 *default-log-port* "ERROR: you must be on the homehost to run with " switch
;;      				", you can move homehost by removing the .homehost file but this will disrupt any runs in progress.")
;;      		   (exit 1))))
;;      	   homehost-required))))
;;      
;;      ;;======================================================================
;;      ;; Misc setup stuff
;;      ;;======================================================================
;;      
;;      (debug:setup)
;;      
;;      (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")
;;          (let ((newval (conc (args:get-arg "-testpatt") "/" (args:get-arg "-itempatt"))))
;;            (debug:print 0 *default-log-port* "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval)
;;            (hash-table-set! args:arg-hash "-testpatt" newval)
;;            (hash-table-delete! args:arg-hash "-itempatt")))
;;      
;;      (if (args:get-arg "-runtests")
;;          (debug:print 0 *default-log-port* "WARNING: \"-runtests\" is deprecated. Use \"-run\" with \"-testpatt\" instead"))
;; 
;;      ;; (debug:print 0 *default-log-port* "on-exit disabled. Please re-enable")
;;      (on-exit std-exit-procedure)
;;      
;;      ;;======================================================================
;;      ;; Misc general calls
;;      ;;======================================================================
;; 
;; ;; TODO: Restore this functionality
;; 
;;      #; (if (and (args:get-arg "-cache-db")
;;               (args:get-arg "-source-db"))
;;          (let* ((temp-dir (or (args:get-arg "-target-db") (create-directory (conc "/tmp/" (get-environment-variable "USER") "/" (string-translate (current-directory) "/" "_")))))
;;                 (target-db (conc temp-dir "/cached.db"))
;;                 (source-db (args:get-arg "-source-db")))        
;;            (db:cache-for-read-only source-db target-db)
;;            (set! *didsomething* #t)))
;;      
;;      ;; handle a clean-cache request as early as possible
;;      ;;
;;      (if (args:get-arg "-clean-cache")
;;          (let ((toppath  (launch:setup)))
;;            (set! *didsomething* #t) ;; suppress the help output.
;;            (runs:clean-cache (common:args-get-target)
;;      			(args:get-arg "-runname")
;;      			toppath)))
;;      	  
;;      (if (args:get-arg "-env2file")
;;          (begin
;;            (save-environment-as-files (args:get-arg "-env2file"))
;;            (set! *didsomething* #t)))
;;      
;;      (if (args:get-arg "-list-disks")
;;          (let ((toppath (launch:setup)))
;;            (print 
;;             (string-intersperse 
;;      	(map (lambda (x)
;;      	       (string-intersperse 
;;      		x
;;      		" => "))
;;      	     (common:get-disks *configdat*))
;;      	"\n"))
;;            (set! *didsomething* #t)))
;;      
;;      
;;   (if (args:get-arg "-refdb2dat")
;;          (let* ((input-db (args:get-arg "-refdb2dat"))
;;      	   (out-file (args:get-arg "-o"))
;;      	   (out-fmt  (or (args:get-arg "-dumpmode") "scheme"))
;;      	   (out-port (if (and out-file 
;;      			      (not (member out-fmt '("sqlite3" "csv"))))
;;      			 (open-output-file out-file)
;;      			 (current-output-port)))
;;      	   (res-data (configf:read-refdb input-db))
;;      	   (data     (car res-data))
;;      	   (msg      (cadr res-data)))
;;            (if (not data)
;;      	  (debug:print 0 *default-log-port* "Bad input? data=" data) ;; some error occurred
;;      	  (with-output-to-port out-port
;;      	    (lambda ()
;;      	      (case (string->symbol out-fmt)
;;      		((scheme)(pp data))
;;      		((perl)
;;      		 ;; (print "%hash = (")
;;      		 ;;        key1 => 'value1',
;;      		 ;;        key2 => 'value2',
;;      		 ;;        key3 => 'value3',
;;      		 ;; );
;;      		 (configf:map-all-hier-alist 
;;      		  data 
;;      		  (lambda (sheetname sectionname varname val)
;;      		    (print "$data{\"" sheetname "\"}{\"" sectionname "\"}{\"" varname "\"} = \"" val "\";"))))
;;      		((python ruby)
;;      		 (print "data={}")
;;      		 (configf:map-all-hier-alist
;;      		  data
;;      		  (lambda (sheetname sectionname varname val)
;;      		    (print "data[\"" sheetname "\"][\"" sectionname "\"][\"" varname "\"] = \"" val "\""))
;;      		  initproc1:
;;      		  (lambda (sheetname)
;;      		    (print "data[\"" sheetname "\"] = {}"))
;;      		  initproc2:
;;      		  (lambda (sheetname sectionname)
;;      		    (print "data[\"" sheetname "\"][\"" sectionname "\"] = {}"))))
;;      		((csv)
;;      		 (let* ((results  (make-hash-table)) ;; (make-sparse-array)))
;;      			(row-cols (make-hash-table))) ;; hash of hashes where section => ht { row-<name> => num or col-<name> => num
;;      		   ;; (print "data=")
;;      		   ;; (pp data)
;;      		   (configf:map-all-hier-alist
;;      		    data
;;      		    (lambda (sheetname sectionname varname val)
;;      		      ;; (print "sheetname: " sheetname ", sectionname: " sectionname ", varname: " varname ", val: " val)
;;      		      (let* ((dat      (get-dat results sheetname))
;;      			     (vec      (refdb:csv-get-svec dat))
;;      			     (rownames (refdb:csv-get-rows dat))
;;      			     (colnames (refdb:csv-get-cols dat))
;;      			     (currrown (hash-table-ref/default rownames varname #f))
;;      			     (currcoln (hash-table-ref/default colnames sectionname #f))
;;      			     (rown     (or currrown 
;;      					   (let* ((lastn   (refdb:csv-get-maxrow dat))
;;      						  (newrown (+ lastn 1)))
;;      					     (refdb:csv-set-maxrow! dat newrown)
;;      					     newrown)))
;;      			     (coln     (or currcoln 
;;      					   (let* ((lastn   (refdb:csv-get-maxcol dat))
;;      						  (newcoln (+ lastn 1)))
;;      					     (refdb:csv-set-maxcol! dat newcoln)
;;      					     newcoln))))
;;      			(if (not (sparse-array-ref vec 0 coln)) ;; (eq? rown 0)
;;      			    (begin
;;      			      (sparse-array-set! vec 0 coln sectionname)
;;      			      ;; (print "sparse-array-ref " 0 "," coln "=" (sparse-array-ref vec 0 coln))
;;      			      ))
;;      			(if (not (sparse-array-ref vec rown 0)) ;; (eq? coln 0)
;;      			    (begin
;;      			      (sparse-array-set! vec rown 0 varname)
;;      			      ;; (print "sparse-array-ref " rown "," 0 "=" (sparse-array-ref vec rown 0))
;;      			      ))
;;      			(if (not currrown)(hash-table-set! rownames varname rown))
;;      			(if (not currcoln)(hash-table-set! colnames sectionname coln))
;;      			;; (print "dat=" dat ", rown=" rown ", coln=" coln)
;;      			(sparse-array-set! vec rown coln val)
;;      			;; (print "sparse-array-ref " rown "," coln "=" (sparse-array-ref vec rown coln))
;;      			)))
;;      		   (for-each
;;      		    (lambda (sheetname)
;;      		      (let* ((sheetdat (get-dat results sheetname))
;;      			     (svec     (refdb:csv-get-svec sheetdat))
;;      			     (maxrow   (refdb:csv-get-maxrow sheetdat))
;;      			     (maxcol   (refdb:csv-get-maxcol sheetdat))
;;      			     (fname    (if out-file 
;;      					   (string-substitute "%s" sheetname out-file) ;; "/foo/bar/%s.csv")
;;      					   (conc sheetname ".csv"))))
;;      			(with-output-to-file fname
;;      			  (lambda ()
;;      			    ;; (print "Sheetname: " sheetname)
;;      			    (let loop ((row       0)
;;      				       (col       0)
;;      				       (curr-row '())
;;      				       (result   '()))
;;      			      (let* ((val (sparse-array-ref svec row col))
;;      				     (disp-val (if val
;;      						   (conc "\"" val "\"")
;;      						   "")))
;;      				(if (> col 0)(display ","))
;;      				(display disp-val)
;;      				(cond
;;      				 ((> row maxrow)(display "\n") result)
;;      				 ((>= col maxcol)
;;      				  (display "\n")
;;      				  (loop (+ row 1) 0 '() (append result (list curr-row))))
;;      				 (else
;;      				  (loop row (+ col 1) (append curr-row (list val)) result)))))))))
;;      		    (hash-table-keys results))))
;;      		((sqlite3)
;;      		 (let* ((db-file   (or out-file (pathname-file input-db)))
;;      			(db-exists (common:file-exists? db-file))
;;      			(db        (sqlite3:open-database db-file)))
;;      		   (if (not db-exists)(sqlite3:execute db "CREATE TABLE data (sheet,section,var,val);"))
;;      		   (configf:map-all-hier-alist
;;      		    data
;;      		    (lambda (sheetname sectionname varname val)
;;      		      (sqlite3:execute db
;;      				       "INSERT OR REPLACE INTO data (sheet,section,var,val) VALUES (?,?,?,?);"
;;      				       sheetname sectionname varname val)))
;;      		   (sqlite3:finalize! db)))
;;      		(else
;;      		 (pp data))))))
;;            (if out-file (close-output-port out-port))
;;            (exit) ;; yes, bending the rules here - need to exit since this is a utility
;;            ))
;; 
;;   ;; disabled for now
;;   
;;      #;(if (args:get-arg "-ping")
;;          (let* ((server-id     (string->number (args:get-arg "-ping"))) ;; extract run-id (i.e. no ":"
;;      	   (host:port     (args:get-arg "-ping")))
;;            (server-ready? (or server-id host:port) #f do-exit: #t)))
;;      
;;      ;;======================================================================
;;      ;; Capture, save and manipulate environments
;;      ;;======================================================================
;;      
;;      ;; NOTE: Keep these above the section where the server or client code is setup
;;      
;;      (let ((envcap (args:get-arg "-envcap")))
;;        (if envcap
;;            (let* ((db      (env:open-db (if (null? remargs) "envdat.db" (car remargs)))))
;;      	(env:save-env-vars db envcap)
;;      	(env:close-database db)
;;      	(set! *didsomething* #t))))
;;      
;;      ;; delta "language" will eventually be res=a+b-c but for now it is just res=a-b 
;;      ;;
;;      (let ((envdelta (args:get-arg "-envdelta")))
;;        (if envdelta
;;            (let ((match (string-split envdelta "-")));; (string-match "([a-z0-9_]+)=([a-z0-9_\\-,]+)" envdelta)))
;;      	(if (not (null? match))
;;      	    (let* ((db        (env:open-db (if (null? remargs) "envdat.db" (car remargs))))
;;      		   ;; (resctx    (cadr match))
;;      		   ;; (equn      (caddr match))
;;      		   (parts     match) ;; (string-split equn "-"))
;;      		   (minuend   (car parts))
;;      		   (subtraend (cadr parts))
;;      		   (added     (env:get-added   db minuend subtraend))
;;      		   (removed   (env:get-removed db minuend subtraend))
;;      		   (changed   (env:get-changed db minuend subtraend)))
;;      	      ;; (pp (hash-table->alist added))
;;      	      ;; (pp (hash-table->alist removed))
;;      	      ;; (pp (hash-table->alist changed))
;;      	      (if (args:get-arg "-o")
;;      		  (with-output-to-file
;;      		      (args:get-arg "-o")
;;      		    (lambda ()
;;      		      (env:print added removed changed)))
;;      		  (env:print added removed changed))
;;      	      (env:close-database db)
;;      	      (set! *didsomething* #t))
;;      	    (debug:print-error 0 *default-log-port* "Parameter to -envdelta should be new=start-end")))))
;;      
;;      ;;======================================================================
;;      ;; Start the server - can be done in conjunction with -runall or -runtests (one day...)
;;      ;;   we start the server if not running else start the client thread
;;      ;;======================================================================
;;      
;;      ;; Server? Start up here.
;;      ;;
;;      (if (args:get-arg "-server")
;; 	 (if  (not (args:get-arg "-db"))
;; 	      (debug:print 0 *default-log-port* "ERROR: -db required to start server")
;; 	      (let ((tl        (launch:setup))
;; 		    (dbname    (args:get-arg "-db"))) ;; transport-type (string->symbol (or (args:get-arg "-transport") "http"))))
;; 		(rmt:server-launch dbname)
;; 		(set! *didsomething* #t))))
;; 	 
;;      ;; The adjutant is a bit different, it does NOT run (launch:setup) as it is not necessarily tied to
;;      ;; a specific Megatest area. Detail are being hashed out and this may change.
;;      ;;
;;      (if (args:get-arg "-adjutant")
;;          (begin
;;            (adjutant-run)
;;            (set! *didsomething* #t)))
;;      
;;      (if (or (args:get-arg "-list-servers")
;;              (args:get-arg "-kill-servers"))
;;          (let ((tl (launch:setup)))
;;            (if tl ;; all roads from here exit
;;      	  (let* ((servers (rmt:get-servers-info *toppath*))
;;      		 (fmtstr  "~8a~22a~20a~20a~8a\n"))
;; 	    ;; id INTEGER PRIMARY KEY,
;; 	    ;; host TEXT,
;; 	    ;; port INTEGER,
;; 	    ;; servkey TEXT,
;; 	    ;; pid TEXT,
;; 	    ;; ipaddr TEXT,
;; 	    ;; apath TEXT,
;; 	    ;; dbname TEXT,
;; 	    ;; event_time 
;;      	    (format #t fmtstr "pid" "Interface:port" "State" "dbname" "apath")
;;      	    (format #t fmtstr "===" "==============" "=====" "======" "=====")
;;      	    (for-each ;;  ( mod-time host port start-time pid )
;;      	     (lambda (server)
;; 	       (match-let
;; 		(((id host port servkey pid ipaddr apath dbname event_time) server))
;;      		(format #t
;;      			fmtstr
;;      			pid
;;      			(conc host":"port)
;;      			(if (server-ready? host port servkey) "Running" "Dead")
;;      			dbname ;; (seconds->hr-min-sec mod)
;;      			apath
;; 			)
;;      		 (if (args:get-arg "-kill-servers")
;;      		     (begin
;;      		       (debug:print-info 0 *default-log-port* "Attempting to kill server with pid " pid " !!needs completion!!")
;;      		       #;(server:kill server)))))
;;      	     servers)
;;      	    ;; (debug:print-info 1 *default-log-port* "Done with listservers")
;;      	    (set! *didsomething* #t)
;;      	    (exit))
;;      	  (exit))))
;;            ;; must do, would have to add checks to many/all calls below
;;      
;;      ;;======================================================================
;;      ;; Weird special calls that need to run *after* the server has started?
;;      ;;======================================================================
;;      
;;      (if (args:get-arg "-list-targets")
;;          (if (launch:setup)
;;              (let* ((rconfdat (configf:read-config (conc *toppath* "/runconfigs.config") #f #f))
;; 		    (targets  (common:get-runconfig-targets rconfdat)))
;;                ;; (debug:print 1 *default-log-port* "Found "(length targets) " targets")
;;                (case (string->symbol (or (args:get-arg "-dumpmode") "alist"))
;;                  ((alist)
;;                   (for-each (lambda (x)
;;                               ;; (print "[" x "]"))
;;                               (print x))
;;                             targets))
;;                  ((json)
;;                   (json-write targets))
;;                  (else
;;                   (debug:print-error 0 *default-log-port* "dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets")))
;;                (set! *didsomething* #t))))
;; 
;; 
;;      (if (args:get-arg "-show-runconfig")
;;          (let ((tl (launch:setup)))
;;            (push-directory *toppath*)
;;            (let ((data (full-runconfigs-read)))
;;      	;; keep this one local
;;      	(cond
;;      	 ((and (args:get-arg "-section")
;;      	       (args:get-arg "-var"))
;;      	  (let ((val (or (configf:lookup data (args:get-arg "-section")(args:get-arg "-var"))
;;      			 (configf:lookup data "default" (args:get-arg "-var")))))
;;      	    (if val (print val))))
;;      	 ((or (not (args:get-arg "-dumpmode"))
;;                    (string=? (args:get-arg "-dumpmode") "ini"))
;;      	  (configf:config->ini data))
;;      	 ((string=? (args:get-arg "-dumpmode") "sexp")
;;      	  (pp (hash-table->alist data)))
;;      	 ((string=? (args:get-arg "-dumpmode") "json")
;;      	  (json-write data))
;;      	 (else
;;      	  (debug:print-error 0 *default-log-port* "-dumpmode of " (args:get-arg "-dumpmode") " not recognised")))
;;      	(set! *didsomething* #t))
;;            (pop-directory)))
;;      
;;      (if (args:get-arg "-show-config")
;;          (let ((tl   (launch:setup))
;;      	  (data *configdat*)) ;; (configf:read-config "megatest.config" #f #t)))
;;            (push-directory *toppath*)
;;            ;; keep this one local
;;            (cond 
;;             ((and (args:get-arg "-section")
;;      	     (args:get-arg "-var"))
;;      	(let ((val (configf:lookup data (args:get-arg "-section")(args:get-arg "-var"))))
;;      	  (if val (print val))))
;;      
;;             ;; print just a section if only -section
;;      
;;             ((equal? (args:get-arg "-dumpmode") "sexp")
;;      	(pp (hash-table->alist data)))
;;             ((equal? (args:get-arg "-dumpmode") "json")
;;      	(json-write data))
;;             ((or (not (args:get-arg "-dumpmode"))
;;      	    (string=? (args:get-arg "-dumpmode") "ini"))
;;      	(configf:config->ini data))
;;             (else
;;      	(debug:print-error 0 *default-log-port* "-dumpmode of " (args:get-arg "-dumpmode") " not recognised")))
;;            (set! *didsomething* #t)
;;            (pop-directory)
;;            (bdat-time-to-exit-set! *bdat* #t)))
;;      
;;      (if (args:get-arg "-show-cmdinfo")
;;          (if (or (args:get-arg ":value")(get-environment-variable "MT_CMDINFO"))
;;      	(let ((data (common:read-encoded-string (or (args:get-arg ":value")(get-environment-variable "MT_CMDINFO")))))
;;      	  (if (equal? (args:get-arg "-dumpmode") "json")
;;      	      (json-write data)
;;      	      (pp data))
;;      	  (set! *didsomething* #t))
;;      	(debug:print-info 0 *default-log-port* "environment variable MT_CMDINFO is not set")))
;;      
;;      ;;======================================================================
;;      ;; Remove old run(s)
;;      ;;======================================================================
;;      
;;      ;; since several actions can be specified on the command line the removal
;;      ;; is done first
;;      (define (operate-on action #!key (mode #f)(target-in #f)(runname-in #f)(keys-in #f)(keyvals-in #f)) ;; #f is "use default"
;;        (let* ((runrec (runs:runrec-make-record))
;;      	 (target (or target-in   (common:args-get-target))) ;; eventually get rid of the call to common:args-get-target
;;      	 (runname (or runname-in
;;      		      (args:get-arg "-runname"))) ;; eventually get rid of the get-arg calls
;;      	 (testpatt (or (args:get-arg "-testpatt")
;;      		       (and (eq? action 'archive) ;; if it is an archive command fallback to MT_TEST_NAME and MT_ITEMPATH
;;      			    (common:get-full-test-name))
;;      		       (and (eq? action 'kill-runs)
;;      			    "%/%") ;; I'm just guessing that this is correct :(
;;      		       (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")))
;;      		       ))) ;;
;;          (cond
;;           ((not target)
;;            (debug:print-error 0 *default-log-port* "Missing required parameter for "
;;      			 action ", you must specify -target or -reqtarg")
;;            (exit 1))
;;           ((not runname)
;;            (debug:print-error 0 *default-log-port* "Missing required parameter for "
;;      			 action ", you must specify the run name pattern with -runname patt")
;;            (exit 2))
;;           ((not testpatt)
;;            (debug:print-error 0 *default-log-port* "Missing required parameter for "
;;      			 action ", you must specify the test pattern with -testpatt")
;;            (exit 3))
;;           (else
;;            (if (not (car *configinfo*))
;;      	  (begin
;;      	    (debug:print-error 0 *default-log-port* "Attempted " action "on test(s) but run area config file not found")
;;      	    (exit 1))
;;      	  ;; put test parameters into convenient variables
;;      	  (begin
;;      	    ;; check for correct version, exit with message if not correct
;; 
;; 	    ;; TODO: restore this functionality
;; 	    
;; 	    ;; (common:exit-on-version-changed)
;; 	    
;;      	    (runs:operate-on  action
;;      			      target
;;      			      runname
;;      			      testpatt
;;      			      state:  (common:args-get-state)
;;      			      status: (common:args-get-status)
;;      			      new-state-status: (args:get-arg "-set-state-status")
;;                                    mode: mode)))
;;            (set! *didsomething* #t)))))
;;      
;;      (if (args:get-arg "-kill-runs")
;;          (general-run-call 
;;           "-kill-runs"
;;           "kill runs"
;;           (lambda (target runname keys keyvals)
;;             (operate-on 'kill-runs mode: #f)
;;             )))
;;      
;;      (if (args:get-arg "-kill-rerun")
;;          (let* ((target-patt (common:args-get-target))
;;                 (runname-patt (args:get-arg "-runname")))
;;            (cond ((not target-patt)
;;                   (debug:print-error 0 *default-log-port* "Missing target, must specify target for -kill-rerun with -target <target name>")
;;                   (exit 1))
;;                  ((not runname-patt)
;;                   (debug:print-error 0 *default-log-port* "Missing runname, must specify runname for -kill-rerun with -runname <run name>")
;;                   (exit 1))
;;                  ((string-search "[ ,%]" target-patt)
;;                   (debug:print-error 0 *default-log-port* "Invalid target ["target-patt"], must specify exact target (no wildcards) for -kill-rerun with -target <target name>")
;;                   (exit 1))
;;                  ((string-search "[ ,%]" runname-patt)
;;                   (debug:print-error 0 *default-log-port* "Invalid runname ["runname-patt"], must specify exact runname (no wildcards) for -kill-rerun with -runname <runname name>")
;;                   (exit 1))
;;                  (else
;;                   (general-run-call 
;;                    "-kill-runs"
;;                    "kill runs"
;;                    (lambda (target runname keys keyvals)
;;                      (operate-on 'kill-runs mode: #f)
;;                      ))
;;            
;;                   (thread-sleep! 15))
;;                  ;; fall thru and let "-run" loop fire
;;                  )))
;;      
;;      
;;      (if (args:get-arg "-remove-runs")
;;          (general-run-call 
;;           "-remove-runs"
;;           "remove runs"
;;           (lambda (target runname keys keyvals)
;;             (operate-on 'remove-runs mode: (if (args:get-arg "-keep-records")
;;                                                'remove-data-only
;;                                                'remove-all)))))
;;      
;;      (if (args:get-arg "-remove-keep")
;;          (general-run-call 
;;           "-remove-keep"
;;           "remove keep"
;;           (lambda (target runname keys keyvals)
;;             (let ((actions (map string->symbol
;;                                 (string-split
;;      			    (or (args:get-arg "-actions")
;;      				"print")
;;      			    ",")))) ;; default to printing the output
;;               (runs:remove-all-but-last-n-runs-per-target target runname
;;      						     (string->number (args:get-arg "-remove-keep"))
;;      						     actions: actions)))))
;;      
;;      (if (args:get-arg "-set-state-status")
;;          (general-run-call 
;;           "-set-state-status"
;;           "set state and status"
;;           (lambda (target runname keys keyvals)
;;             (operate-on 'set-state-status))))
;;      
;;      (if (or (args:get-arg "-set-run-status")
;;      	(args:get-arg "-get-run-status"))
;;          (general-run-call
;;           "-set-run-status"
;;           "set run status"
;;           (lambda (target runname keys keyvals)
;;             (let* ((runsdat  (rmt:get-runs-by-patt keys runname 
;;      					(common:args-get-target)
;;      					#f #f #f #f))
;;      	      (header   (vector-ref runsdat 0))
;;      	      (rows     (vector-ref runsdat 1)))
;;      	 (if (null? rows)
;;      	     (begin
;;      	       (debug:print-info 0 *default-log-port* "No matching run found.")
;;      	       (exit 1))
;;      	     (let* ((row      (car (vector-ref runsdat 1)))
;;      		    (run-id   (db:get-value-by-header row header "id")))
;;      	       (if (args:get-arg "-set-run-status")
;;      		   (rmt:set-run-status run-id (args:get-arg "-set-run-status") msg: (args:get-arg "-m"))
;;      		   (print (rmt:get-run-status run-id))
;;      		   )))))))
;;      
;;      ;;======================================================================
;;      ;; Query runs
;;      ;;======================================================================
;;      
;;      ;; -fields runs:id,target,runname,comment+tests:id,testname,item_path+steps
;;      ;;
;;      ;; csi> (extract-fields-constraints "runs:id,target,runname,comment+tests:id,testname,item_path+steps")
;;      ;;         => (("runs" "id" "target" "runname" "comment") ("tests" "id" "testname" "item_path") ("steps"))
;;      ;;
;;      ;;   NOTE: remember that the cdr will be the list you expect (cdr ("runs" "id" "target" "runname" "comment")) => ("id" "target" "runname" "comment")
;;      ;;         and so alist-ref will yield what you expect
;;      ;;
;;      (define (extract-fields-constraints fields-spec)
;;        (map (lambda (table-spec) ;; runs:id,target,runname
;;      	 (let ((dat (string-split table-spec ":"))) ;; ("runs" "id,target,runname")
;;      	   (if (> (length dat) 1)
;;      	       (cons (car dat)(string-split (cadr dat) ",")) ;; "id,target,runname"
;;      	       dat)))
;;             (string-split fields-spec "+")))
;;      
;;      (define (get-value-by-fieldname datavec test-field-index fieldname)
;;        (let ((indx (hash-table-ref/default test-field-index fieldname #f)))
;;          (if indx
;;      	(if (>= indx (vector-length datavec))
;;      	    #f ;; index too high, should raise an error I suppose
;;      	    (vector-ref datavec indx))
;;      	#f)))
;;      
;;      
;;      
;;      
;;      
;;      (when (args:get-arg "-testdata-csv")
;;        (if (launch:setup)
;;            (let* ((keys        (rmt:get-keys)) ;; (db:get-keys dbstruct))
;;                   (runpatt     (or (args:get-arg "-runname") "%"))
;;                   (testpatt    (common:args-get-testpatt #f))
;;                   (datapatt    (args:get-arg "-testdata-csv"))
;;                   (match-data  (string-match "^([^/]+)/(.*)" (args:get-arg "-testdata-csv")))
;;                   (categorypatt (if match-data (list-ref match-data 1) "%"))
;;                   (setvarpatt  (if match-data
;;                                    (list-ref match-data 2)
;;                                    (args:get-arg "-testdata-csv")))
;;                   (runsdat     (rmt:get-runs-by-patt keys (or runpatt "%") 
;;                                                      (common:args-get-target) #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
;;                   (header      (db:get-header runsdat))
;;                   (access-mode (db:get-access-mode))
;;                   (testpatt    (common:args-get-testpatt #f))
;;                   (fields-spec (if (args:get-arg "-fields")
;;                                    (extract-fields-constraints (args:get-arg "-fields"))
;;                                    (list (cons "runs" (append keys (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count")))
;;                                          (cons "tests"  db:test-record-fields) ;; "id" "testname" "test_path")
;;                                          (list "steps" "id" "stepname"))))
;;                   (tests-spec  (let ((t (alist-ref "tests" fields-spec equal?)))
;;                                  (if (and t (null? t)) ;; all fields
;;                                      db:test-record-fields
;;                                      t)))
;;                   (adj-tests-spec (delete-duplicates (if tests-spec (cons "id" tests-spec) db:test-record-fields))) 
;;                   (test-field-index (make-hash-table))
;;                   (runs (db:get-rows runsdat))
;;                   )
;;              (if (and tests-spec (not (null? tests-spec))) ;; do some validation and processing of the test-spec
;;                  (let ((invalid-tests-spec (filter (lambda (x)(not (member x db:test-record-fields))) tests-spec)))
;;                    (if (null? invalid-tests-spec)
;;                        ;; generate the lookup map test-field-name => index-number
;;                        (let loop ((hed (car adj-tests-spec))
;;                                   (tal (cdr adj-tests-spec))
;;                                   (idx 0))
;;                          (hash-table-set! test-field-index hed idx)
;;                          (if (not (null? tal))(loop (car tal)(cdr tal)(+ idx 1))))
;;                        (begin
;;                          (debug:print-error 0 *default-log-port* "Invalid test fields specified: " (string-intersperse invalid-tests-spec ", "))
;;                          (exit)))))
;;              (let* ((table-header (string-split "target,run,test,itempath,category,var,value,comment" ","))
;;                     (table-rows
;;                      (apply append (map  
;;                                     (lambda (run)
;;                                       (let* ((target (string-intersperse (map (lambda (x)
;;      							 (db:get-value-by-header run header x))
;;      						       keys) "/"))
;;                                              (statuses (string-split (or (args:get-arg "-status") "") ","))
;;                                              (run-id  (db:get-value-by-header run header "id"))
;;                                              (runname (db:get-value-by-header run header "runname")) 
;;                                              (states  (string-split (or (args:get-arg "-state") "") ","))
;;                                              (tests   (if tests-spec
;;                                                           (rmt:get-tests-for-run run-id testpatt states statuses #f #f #f 'testname 'asc ;; (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc 
;;                                                                              ;; use qryvals if test-spec provided
;;                                                                              (if tests-spec
;;                                                                                  (string-intersperse adj-tests-spec ",")
;;                                                                                  ;; db:test-record-fields
;;                                                                                  #f)
;;                                                                              #f
;;                                                                              'normal)
;;                                                           '())))
;;                                         (apply append
;;                                                (map
;;                                                 (lambda (test)
;;                                                   (let* (
;;                                                          (test-id      (if (member "id"           tests-spec)(get-value-by-fieldname test test-field-index "id"          ) #f)) ;; (db:test-get-id         test))
;;                                                          (testname     (if (member "testname"     tests-spec)(get-value-by-fieldname test test-field-index "testname"    ) #f)) ;; (db:test-get-testname   test))
;;                                                          (itempath     (if (member "item_path"    tests-spec)(get-value-by-fieldname test test-field-index "item_path"   ) #f)) ;; (db:test-get-item-path  test))
;;                                                          (fullname     (conc testname
;;                                                                              (if (equal? itempath "")
;;                                                                                  "" 
;;                                                                                  (conc "/" itempath ))))
;;                                                          (testdat-raw (map vector->list (rmt:read-test-data-varpatt run-id test-id categorypatt setvarpatt)))
;;                                                          (testdat (filter
;;                                                                    (lambda (x)
;;                                                                      (not (equal? "logpro"
;;                                                                                   (list-ref x 10))))
;;                                                                    testdat-raw)))
;;                                                     (map 
;;                                                      (lambda (item)
;;                                                        (receive (id test_id category
;;                                                                     variable value expected
;;                                                                     tol units comment status type)
;;                                                            (apply values item)
;;                                                          (list target runname testname itempath category variable value comment)))
;;                                                      testdat)))
;;                                                 tests))))
;;                                     runs))))
;;                (print (string-join table-header ","))
;;                (for-each (lambda(table-row)
;;                            (print (string-join (map ->string table-row) ",")))
;;      
;;                          
;;                                  table-rows))))
;;        (set! *didsomething* #t)
;;        (bdat-time-to-exit-set! *bdat* #t))
;;      
;;      
;;      
;;      ;; NOTE: list-runs and list-db-targets operate on local db!!!
;;      ;;
;;      ;; IDEA: megatest list -runname blah% ...
;;      ;;
;;      (if (or (args:get-arg "-list-runs")
;;      	(args:get-arg "-list-db-targets"))
;;          (if (launch:setup)
;;      	(let* (;; (dbstruct    (make-dbr:dbstruct path: *toppath* local: (args:get-arg "-local")))
;;      	       (runpatt     (args:get-arg "-list-runs"))
;;                     (access-mode (db:get-access-mode))
;;      	       (testpatt    (common:args-get-testpatt #f))
;;      	       ;; (if (args:get-arg "-testpatt") 
;;      	       ;;  	        (args:get-arg "-testpatt") 
;;      	       ;;  	        "%"))
;;      	       (keys        (rmt:get-keys)) ;; (db:get-keys dbstruct))
;;      	       ;; (runsdat  (db:get-runs dbstruct runpatt #f #f '()))
;;      	;; (runsdat     (rmt:get-runs-by-patt keys (or runpatt "%") (common:args-get-target) ;; (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target)
;;      	;; 		           	 #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
;;      	       (runsdat     (rmt:get-runs-by-patt keys (or runpatt "%") 
;;                                                        (common:args-get-target) #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
;;      	       (runstmp     (db:get-rows runsdat))
;;      	       (header      (db:get-header runsdat))
;;      	       ;; this is "-since" support. This looks at last mod times of <run-id>.db files
;;      	       ;; and collects those modified since the -since time.
;;      	       (runs        runstmp)
;;                              ;; (if (and (not (null? runstmp))
;;      			;;        (args:get-arg "-since"))
;;      			;;   (let ((changed-ids (db:get-changed-run-ids (string->number (args:get-arg "-since")))))
;;      			;;     (let loop ((hed (car runstmp))
;;      			;;   	     (tal (cdr runstmp))
;;      			;;   	     (res '()))
;;      			;;       (let ((new-res (if (member (db:get-value-by-header hed header "id") changed-ids)
;;      			;;   		       (cons hed res)
;;      			;;   		       res)))
;;      			;;         (if (null? tal)
;;      			;;   	  (reverse new-res)
;;      			;;   	  (loop (car tal)(cdr tal) new-res)))))
;;      			;;   runstmp))
;;      	       (db-targets  (args:get-arg "-list-db-targets"))
;;      	       (seen        (make-hash-table))
;;      	       (dmode       (let ((d (args:get-arg "-dumpmode"))) ;; json, sexpr
;;      			      (if d (string->symbol d) #f)))
;;      	       (data        (make-hash-table))
;;      	       (fields-spec (if (args:get-arg "-fields")
;;      				(extract-fields-constraints (args:get-arg "-fields"))
;;      				(list (cons "runs" (append keys (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count")))
;;      				      (cons "tests"  db:test-record-fields) ;; "id" "testname" "test_path")
;;      				      (list "steps" "id" "stepname"))))
;;      	       (runs-spec   (let ((r (alist-ref "runs"  fields-spec equal?))) ;; the check is now unnecessary
;;      			      (if (and r (not (null? r))) r (list "id" ))))
;;      	       (tests-spec  (let ((t (alist-ref "tests" fields-spec equal?)))
;;      			      (if (and t (null? t)) ;; all fields
;;      				  db:test-record-fields
;;      				  t)))
;;      	       (adj-tests-spec (delete-duplicates (if tests-spec (cons "id" tests-spec) db:test-record-fields))) ;; '("id"))))
;;      	       (steps-spec  (alist-ref "steps" fields-spec equal?))
;;      	       (test-field-index (make-hash-table)))
;;      	  (if (and tests-spec (not (null? tests-spec))) ;; do some validation and processing of the test-spec
;;      	      (let ((invalid-tests-spec (filter (lambda (x)(not (member x db:test-record-fields))) tests-spec)))
;;      		(if (null? invalid-tests-spec)
;;      		    ;; generate the lookup map test-field-name => index-number
;;      		    (let loop ((hed (car adj-tests-spec))
;;      			       (tal (cdr adj-tests-spec))
;;      			       (idx 0))
;;      		      (hash-table-set! test-field-index hed idx)
;;      		      (if (not (null? tal))(loop (car tal)(cdr tal)(+ idx 1))))
;;      		    (begin
;;      		      (debug:print-error 0 *default-log-port* "Invalid test fields specified: " (string-intersperse invalid-tests-spec ", "))
;;      		      (exit)))))
;;      	  ;; Each run
;;      	  (for-each 
;;      	   (lambda (run)
;;      	     (let ((targetstr (string-intersperse (map (lambda (x)
;;      							 (db:get-value-by-header run header x))
;;      						       keys) "/")))
;;      	       (if db-targets
;;      		   (if (not (hash-table-ref/default seen targetstr #f))
;;      		       (begin
;;      			 (hash-table-set! seen targetstr #t)
;;      			 ;; (print "[" targetstr "]"))))
;;      			 (if (not dmode)
;;      			     (print targetstr)
;;      			     (hash-table-set! data "targets" (cons targetstr (hash-table-ref/default data "targets" '())))
;;      			     )))
;;      		   (let* ((run-id  (db:get-value-by-header run header "id"))
;;      			  (runname (db:get-value-by-header run header "runname")) 
;;      			  (states  (string-split (or (args:get-arg "-state") "") ","))
;;      			  (statuses (string-split (or (args:get-arg "-status") "") ","))
;;      			  (tests   (if tests-spec
;;      				       (rmt:get-tests-for-run run-id testpatt states statuses #f #f #f 'testname 'asc ;; (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc 
;;      							     ;; use qryvals if test-spec provided
;;      							     (if tests-spec
;;      								 (string-intersperse adj-tests-spec ",")
;;      								 ;; db:test-record-fields
;;      								 #f)
;;      							     #f
;;      							     'normal)
;;      				       '())))
;;      		     (case dmode
;;      		       ((json ods sexpr)
;;      			(if runs-spec
;;      			    (for-each 
;;      			     (lambda (field-name)
;;      			       (mutils:hierhash-set! data (conc (db:get-value-by-header run header field-name)) targetstr runname "meta" field-name))
;;      			     runs-spec)))
;;      			;; (mutils:hierhash-set! data (db:get-value-by-header run header "status")     targetstr runname "meta" "status"     )
;;      			;; (mutils:hierhash-set! data (db:get-value-by-header run header "state")      targetstr runname "meta" "state"      )
;;      			;; (mutils:hierhash-set! data (conc (db:get-value-by-header run header "id"))  targetstr runname "meta" "id"         )
;;      			;; (mutils:hierhash-set! data (db:get-value-by-header run header "event_time") targetstr runname "meta" "event_time" )
;;      			;; (mutils:hierhash-set! data (db:get-value-by-header run header "comment")    targetstr runname "meta" "comment"    )
;;      			;; ;; add last entry twice - seems to be a bug in hierhash?
;;      			;; (mutils:hierhash-set! data (db:get-value-by-header run header "comment")    targetstr runname "meta" "comment"    )
;;      		       (else
;;      			(if (null? runs-spec)
;;      			    (print "Run: " targetstr "/" runname 
;;      				   " status: " (db:get-value-by-header run header "state")
;;      				   " run-id: " run-id ", number tests: " (length tests)
;;      				   " event_time: " (db:get-value-by-header run header "event_time"))
;;      			    (begin
;;      			      (if (not (member "target" runs-spec))
;;      			          ;; (display (conc "Target: " targetstr))
;;      			          (display (conc "Run: " targetstr "/" runname " ")))
;;      			      (for-each
;;      			       (lambda (field-name)
;;      				 (if (equal? field-name "target")
;;      				     (display (conc "target: " targetstr " "))
;;      				     (display (conc field-name ": " (db:get-value-by-header run header (conc field-name)) " "))))
;;      			       runs-spec)
;;      			      (newline)))))
;;      		       
;;      		     (for-each 
;;      		      (lambda (test)
;;      		      	(handle-exceptions
;;      			 exn
;;      			 (begin
;;      			   (debug:print-error 0 *default-log-port* "Bad data in test record? " test)
;;      			   (debug:print-error 5 *default-log-port* "exn=" (condition->list exn))
;;      			   (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
;;      			   (print-call-chain (current-error-port)))
;;      			 (let* ((test-id      (if (member "id"           tests-spec)(get-value-by-fieldname test test-field-index "id"          ) #f)) ;; (db:test-get-id         test))
;;      				(testname     (if (member "testname"     tests-spec)(get-value-by-fieldname test test-field-index "testname"    ) #f)) ;; (db:test-get-testname   test))
;;      				(itempath     (if (member "item_path"    tests-spec)(get-value-by-fieldname test test-field-index "item_path"   ) #f)) ;; (db:test-get-item-path  test))
;;      				(comment      (if (member "comment"      tests-spec)(get-value-by-fieldname test test-field-index "comment"     ) #f)) ;; (db:test-get-comment    test))
;;      				(tstate       (if (member "state"        tests-spec)(get-value-by-fieldname test test-field-index "state"       ) #f)) ;; (db:test-get-state      test))
;;      				(tstatus      (if (member "status"       tests-spec)(get-value-by-fieldname test test-field-index "status"      ) #f)) ;; (db:test-get-status     test))
;;      				(event-time   (if (member "event_time"   tests-spec)(get-value-by-fieldname test test-field-index "event_time"  ) #f)) ;; (db:test-get-event_time test))
;;      				(rundir       (if (member "rundir"       tests-spec)(get-value-by-fieldname test test-field-index "rundir"      ) #f)) ;; (db:test-get-rundir     test))
;;      				(final_logf   (if (member "final_logf"   tests-spec)(get-value-by-fieldname test test-field-index "final_logf"  ) #f)) ;; (db:test-get-final_logf test))
;;      				(run_duration (if (member "run_duration" tests-spec)(get-value-by-fieldname test test-field-index "run_duration") #f)) ;; (db:test-get-run_duration test))
;;      				(fullname     (conc testname
;;      						    (if (equal? itempath "")
;;      							"" 
;;      							(conc "(" itempath ")")))))
;;      			   (case dmode
;;      			     ((json ods sexpr)
;;      			      (if tests-spec
;;      				  (for-each
;;      				   (lambda (field-name)
;;      				     (mutils:hierhash-set! data  (get-value-by-fieldname test test-field-index field-name) targetstr runname "data" (conc test-id) field-name))
;;      				   tests-spec)))
;;      			     ;; ;; (mutils:hierhash-set! data  fullname   targetstr runname "data" (conc test-id) "tname"     )
;;      			     ;;  (mutils:hierhash-set! data  testname   targetstr runname "data" (conc test-id) "testname"  )
;;      			     ;;  (mutils:hierhash-set! data  itempath   targetstr runname "data" (conc test-id) "itempath"  )
;;      			     ;;  (mutils:hierhash-set! data  comment    targetstr runname "data" (conc test-id) "comment"   )
;;      			     ;;  (mutils:hierhash-set! data  tstate     targetstr runname "data" (conc test-id) "state"     )
;;      			     ;;  (mutils:hierhash-set! data  tstatus    targetstr runname "data" (conc test-id) "status"    )
;;      			     ;;  (mutils:hierhash-set! data  rundir     targetstr runname "data" (conc test-id) "rundir"    )
;;      			     ;;  (mutils:hierhash-set! data  final_logf targetstr runname "data" (conc test-id) "final_logf")
;;      			     ;;  (mutils:hierhash-set! data  run_duration targetstr runname "data" (conc test-id) "run_duration")
;;      			     ;;  (mutils:hierhash-set! data  event-time targetstr runname "data" (conc test-id) "event_time")
;;      			     ;;  ;; add last entry twice - seems to be a bug in hierhash?
;;      			     ;;  (mutils:hierhash-set! data  event-time targetstr runname "data" (conc test-id) "event_time")
;;      			     ;;  )
;;      			     (else
;;      			      (if (and tstate tstatus event-time)
;;      				  (format #t
;;      					  "  Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n"
;;      					  (if fullname fullname "")
;;      					  (if tstate   tstate   "")
;;      					  (if tstatus  tstatus  "")
;;      					  (get-value-by-fieldname test test-field-index "run_duration");;(if test     (db:test-get-run_duration test) "")
;;      					  (if event-time event-time "")
;;      					  (get-value-by-fieldname test test-field-index "host")) ;;(if test (db:test-get-host test)) "")
;;      				  (print "  Test: " fullname
;;      					 (if tstate  (conc " State: "  tstate)  "")
;;      					 (if tstatus (conc " Status: " tstatus) "")
;;      					 (if (get-value-by-fieldname test test-field-index "run_duration")
;;      					     (conc " Runtime: " (get-value-by-fieldname test test-field-index "run_duration"))
;;      					     "")
;;      					 (if event-time (conc " Time: " event-time) "")
;;      					 (if (get-value-by-fieldname test test-field-index "host")
;;      					     (conc " Host: " (get-value-by-fieldname test test-field-index "host"))
;;      					     "")))
;;      			      (if (not (or (equal? (get-value-by-fieldname test test-field-index "status") "PASS")
;;      					   (equal? (get-value-by-fieldname test test-field-index "status") "WARN")
;;      					   (equal? (get-value-by-fieldname test test-field-index "state")  "NOT_STARTED")))
;;      				  (begin
;;      				    (print   (if (get-value-by-fieldname test test-field-index "cpuload")
;;      						 (conc "         cpuload:  "   (get-value-by-fieldname test test-field-index "cpuload"))
;;      						 "") ;; (db:test-get-cpuload test)
;;      					     (if (get-value-by-fieldname test test-field-index "diskfree")
;;      						 (conc "\n         diskfree: " (get-value-by-fieldname test test-field-index "diskfree")) ;; (db:test-get-diskfree test)
;;      						 "")
;;      					     (if (get-value-by-fieldname test test-field-index "uname")
;;      						 (conc "\n         uname:    " (get-value-by-fieldname test test-field-index "uname")) ;; (db:test-get-uname test)
;;      						 "")
;;      					     (if (get-value-by-fieldname test test-field-index "rundir")
;;      						 (conc "\n         rundir:   " (get-value-by-fieldname test test-field-index "rundir")) ;; (db:test-get-rundir test)
;;      						 "")
;;      ;;					     "\n         rundir:   " (get-value-by-fieldname test test-field-index "") ;; (sdb:qry 'getstr ;; (filedb:get-path *fdb* 
;;      ;; 					     (db:test-get-rundir test) ;; )
;;      					     )
;;      				    ;; Each test
;;      				    ;; DO NOT remote run
;;      				    (let ((steps (rmt:get-steps-for-test run-id (db:test-get-id test)))) ;; (db:get-steps-for-test dbstruct run-id (db:test-get-id test))))
;;      				      (for-each 
;;      				       (lambda (step)
;;      					 (format #t 
;;      						 "    Step: ~20a State: ~10a Status: ~10a Time ~22a\n"
;;      						 (tdb:step-get-stepname step)
;;      						 (tdb:step-get-state step)
;;      						 (tdb:step-get-status step)
;;      						 (tdb:step-get-event_time step)))
;;      				       steps)))))))))
;;      		      (if (args:get-arg "-sort")
;;      			  (sort tests
;;      				(lambda (a-test b-test)
;;      				  (let* ((key    (args:get-arg "-sort"))
;;      					 (first  (get-value-by-fieldname a-test test-field-index key))
;;      					 (second (get-value-by-fieldname b-test test-field-index key)))
;;      				    ((cond 
;;      				      ((and (number? first)(number? second)) <)
;;      				      ((and (string? first)(string? second)) string<=?)
;;      				      (else equal?))
;;      				     first second))))
;;      			  tests))))))
;;      	   runs)
;;      	  (case dmode
;;      	    ((json)  (json-write data))
;;      	    ((sexpr) (pp (common:to-alist data))))
;;      	  (let* ((metadat-fields (delete-duplicates
;;      				  (append keys '( "runname" "time" "owner" "pass_count" "fail_count" "state" "status" "comment" "id"))))
;;      		 (run-fields    '(
;;      				  "testname"
;;      				  "item_path"
;;      				  "state"
;;      				  "status"
;;      				  "comment"
;;      				  "event_time"
;;      				  "host"
;;      				  "run_id"
;;      				  "run_duration"
;;      				  "attemptnum"
;;      				  "id"
;;      				  "archived"
;;      				  "diskfree"
;;      				  "cpuload"
;;      				  "final_logf"
;;      				  "shortdir"
;;      				  "rundir"
;;      				  "uname"
;;      				  )
;;      				)
;;      		 (newdat          (common:to-alist data))
;;      		 (allrundat       (if (null? newdat)
;;      				      '()
;;      				      (car (map cdr newdat)))) ;; (car (map cdr (car (map cdr newdat)))))
;;      		 (runs            (append
;;      				   (list "runs" ;; sheetname
;;      					 metadat-fields)
;;      				   (map (lambda (run)
;;      					  ;; (print "run: " run)
;;      					  (let* ((runname (car run))
;;      						 (rundat  (cdr run))
;;      						 (metadat (let ((tmp (assoc "meta" rundat)))
;;      							    (if tmp (cdr tmp) #f))))
;;      					    ;; (print "runname: " runname "\n\nrundat: " )(pp rundat)(print "\n\nmetadat: ")(pp metadat)
;;      					    (if metadat
;;      						(map (lambda (field)
;;      						       (let ((tmp (assoc field metadat)))
;;      							 (if tmp (cdr tmp) "")))
;;      						     metadat-fields)
;;      						(begin
;;      						  (debug:print 0 *default-log-port* "WARNING: meta data for run " runname " not found")
;;      						  '()))))
;;      					allrundat)))
;;      		 ;; '( ( "target" ( "runname" ( "data" ( "runid" ( "id . "37" ) ( ... ))))
;;      		 (run-pages      (map (lambda (targdat)
;;      					(let* ((target  (car targdat))
;;      					       (runsdat (cdr targdat)))
;;      					  (if runsdat
;;      					      (map (lambda (rundat)
;;      						     (let* ((runname  (car rundat))
;;      							    (rundat   (cdr rundat))
;;      							    (testsdat (let ((tmp (assoc "data" rundat)))
;;      									(if tmp (cdr tmp) #f))))
;;      						       (if testsdat
;;      							   (let ((tests (map (lambda (test)
;;      									       (let* ((test-id  (car test))
;;      										      (test-dat (cdr test)))
;;      										 (map (lambda (field)
;;      											(let ((tmp (assoc field test-dat)))
;;      											  (if tmp (cdr tmp) "")))
;;      										      run-fields)))
;;      									     testsdat)))
;;      							     ;; (print "Target: " target "/" runname " tests:")
;;      							     ;; (pp tests)
;;      							     (cons (conc target "/" runname)
;;      								   (cons (list (conc target "/" runname))
;;      									 (cons '()
;;      									       (cons run-fields tests)))))
;;      							   (begin
;;      							     (debug:print 4 *default-log-port* "WARNING: run " target "/" runname " appears to have no data")
;;      							     ;; (pp rundat)
;;      							     '()))))
;;      						   runsdat)
;;      					      '())))
;;      				      newdat)) ;; we use newdat to get target
;;      		 (sheets         (filter (lambda (x)
;;      					   (not (null? x)))
;;      					 (cons runs (map car run-pages)))))
;;      	    ;; (print "allrundat:")
;;      	    ;; (pp allrundat)
;;      	    ;; (print "runs:")
;;      	    ;; (pp runs)
;;      	    ;(print "sheets: ")
;;      	    ;; (pp sheets)
;;      	    (if (eq? dmode 'ods)
;;      		(let* ((tempdir    (conc "/tmp/" (current-user-name) "/" (pseudo-random-integer 10000) "_" (current-process-id)))
;;      		       (outputfile (or (args:get-arg "-o") "out.ods"))
;;      		       (ouf        (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)))))
;;      		  (create-directory tempdir #t)
;;      		  (ods:list->ods tempdir ouf sheets))))
;;      	  ;; (system (conc "rm -rf " tempdir))
;;      	  (set! *didsomething* #t)
;; 	  (bdat-time-to-exit-set! *bdat* #t)
;; 	  ) ;; end if true branch (end of a let)
;; 	) ;; end if
;;          ) ;; end if -list-runs
;; 
;;      ;; list-waivers
;;      (if (and (args:get-arg "-list-waivers")
;;      	 (launch:setup))
;;          (let* ((runpatt     (or (args:get-arg "-runname") "%"))
;;      	   (testpatt    (common:args-get-testpatt #f))
;;      	   (keys        (rmt:get-keys)) 
;;      	   (runsdat     (rmt:get-runs-by-patt
;;      			 keys runpatt 
;;      			 (common:args-get-target) #f #f
;;      			 '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
;;      	   (runs        (db:get-rows runsdat))
;;      	   (header      (db:get-header runsdat))
;;      	   (results     (make-hash-table))  ;; [target] ( (testname/itempath . "comment") ... )
;;      	   (addtest     (lambda (target testname itempath comment)
;;      			  (hash-table-set! results target (cons (cons (conc testname "/" itempath) comment)
;;      								(hash-table-ref/default results target '())))))
;;      	   (last-target #f))
;;            (for-each
;;             (lambda (run)
;;      	 (let* ((run-id  (db:get-value-by-header run header "id"))
;;      		(target  (rmt:get-target run-id))
;;      		(runname (db:get-value-by-header run header "runname")) 
;;      		(tests   (rmt:get-tests-for-run
;;      			  run-id testpatt '("COMPLETED") '("WAIVED") #f #f #f 'testname 'asc							     ;; use qryvals if test-spec provided
;;      			  #f #f #f)))
;;      	   (if (not (equal? target last-target))
;;      	       (print "[" target "]"))
;;      	   (set! last-target target)
;;      	   (print "# " runname)
;;      	   (for-each
;;      	    (lambda (testdat)
;;      	      (let* ((testfullname (conc (db:test-get-testname testdat)
;;      					 (if (equal? "" (db:test-get-item-path testdat))
;;      					     ""
;;      					     (conc "/" (db:test-get-item-path testdat)))
;;      					 )))
;;      	      (print testfullname " " (db:test-get-comment testdat))))
;;      	    tests)))
;;             runs)
;;            (set! *didsomething* #t)))
;;            
;;      
;;      ;; get lock in db for full run for this directory
;;      ;; for all tests with deps
;;      ;;   walk tree of tests to find head tasks
;;      ;;   add head tasks to task queue
;;      ;;   add dependant tasks to task queue 
;;      ;;   add remaining tasks to task queue
;;      ;; for each task in task queue
;;      ;;   if have adequate resources
;;      ;;     launch task
;;      ;;   else
;;      ;;     put task in deferred queue
;;      ;; if still ok to run tasks
;;      ;;   process deferred tasks per above steps
;;      
;;      ;; run all tests are are Not COMPLETED and PASS or CHECK
;;      (if (or (args:get-arg "-runall")
;;      	(args:get-arg "-run")
;;      	(args:get-arg "-rerun-clean")
;;      	(args:get-arg "-rerun-all")
;;      	(args:get-arg "-runtests")
;;              (args:get-arg "-kill-rerun"))
;;          (let ((need-clean (or (args:get-arg "-rerun-clean")
;;                                (args:get-arg "-rerun-all")))
;;      	  (orig-cmdline (string-intersperse (argv) " ")))
;;            (general-run-call 
;;             "-runall"
;;             "run all tests"
;;             (lambda (target runname keys keyvals)
;;      	 (if (or (string-search "%" target)
;;      		 (string-search "%" runname)) ;; we are being asked to re-run multiple runs
;;      	     (let* ((run-specs (rmt:simple-get-runs runname #f #f target #f))) ;; list of simple-run records
;;      	       (debug:print-info 0 *default-log-port* "Pattern supplied for target or runname with "
;;      				 (length run-specs) " matches round. Running each in turn.")
;;      	       (if (null? run-specs)
;;      		   (debug:print 0 *default-log-port* "WARNING: No runs match target " target " and runname " runname))
;;      	       (for-each (lambda (spec) 
;;      			   (let* ((precmd     (if (args:get-arg "-precmd")(conc (args:get-arg "-precmd") " ") ""))
;;      				  (newcmdline (conc
;;      					       precmd
;;      					       (string-substitute
;;      						(conc "target " target)
;;      						(conc "target " (simple-run-target spec))
;;      						(string-substitute
;;      						 (conc "runname " runname)
;;      						 (conc "runname " (simple-run-runname spec))
;;      						 orig-cmdline)))))
;;      			     (debug:print 0 *default-log-port* "ORIG: " orig-cmdline)
;;      			     (debug:print 0 *default-log-port* "NEW:  " newcmdline)
;;      			     (system newcmdline)))
;;      			 run-specs))
;;      	     (handle-run-requests target runname keys keyvals need-clean))))))
;;      
;;      ;;======================================================================
;;      ;; run one test
;;      ;;======================================================================
;;      
;;      ;; 1. find the config file
;;      ;; 2. change to the test directory
;;      ;; 3. update the db with "test started" status, set running host
;;      ;; 4. process launch the test
;;      ;;    - monitor the process, update stats in the db every 2^n minutes
;;      ;; 5. as the test proceeds internally it calls megatest as each step is
;;      ;;    started and completed
;;      ;;    - step started, timestamp
;;      ;;    - step completed, exit status, timestamp
;;      ;; 6. test phone home
;;      ;;    - if test run time > allowed run time then kill job
;;      ;;    - if cannot access db > allowed disconnect time then kill job
;;      
;;      ;; == duplicated == (if (or (args:get-arg "-run")(args:get-arg "-runtests"))
;;      ;; == duplicated ==   (general-run-call 
;;      ;; == duplicated ==    "-runtests" 
;;      ;; == duplicated ==    "run a test" 
;;      ;; == duplicated ==    (lambda (target runname keys keyvals)
;;      ;; == duplicated ==      ;;
;;      ;; == duplicated ==      ;; May or may not implement it this way ...
;;      ;; == duplicated ==      ;;
;;      ;; == duplicated ==      ;; Insert this run into the tasks queue
;;      ;; == duplicated ==      ;; (open-run-close tasks:add tasks:open-db 
;;      ;; == duplicated ==      ;;    	     "runtests" 
;;      ;; == duplicated ==      ;;    	     user
;;      ;; == duplicated ==      ;;    	     target
;;      ;; == duplicated ==      ;;    	     runname
;;      ;; == duplicated ==      ;;    	     (args:get-arg "-runtests")
;;      ;; == duplicated ==      ;;    	     #f))))
;;      ;; == duplicated ==      (runs:run-tests target
;;      ;; == duplicated == 		     runname
;;      ;; == duplicated == 		     (common:args-get-testpatt #f) ;; (args:get-arg "-runtests")
;;      ;; == duplicated == 		     user
;;      ;; == duplicated == 		     args:arg-hash))))
;;      
;;      ;;======================================================================
;;      ;; Rollup into a run
;;      ;;======================================================================
;;      
;;      ;; (if (args:get-arg "-rollup")
;;      ;;     (general-run-call 
;;      ;;      "-rollup" 
;;      ;;      "rollup tests" 
;;      ;;      (lambda (target runname keys keyvals)
;;      ;;        (runs:rollup-run keys
;;      ;; 			keyvals
;;      ;; 			(or (args:get-arg "-runname")(args:get-arg ":runname") )
;;      ;; 			user))))
;;      
;;      ;;======================================================================
;;      ;; Lock or unlock a run
;;      ;;======================================================================
;;      
;;      (if (or (args:get-arg "-lock")(args:get-arg "-unlock"))
;;          (general-run-call 
;;           (if (args:get-arg "-lock") "-lock" "-unlock")
;;           "lock/unlock tests" 
;;           (lambda (target runname keys keyvals)
;;             (runs:handle-locking 
;;      		  target
;;      		  keys
;;      		  (or (args:get-arg "-runname")(args:get-arg ":runname") )
;;      		  (args:get-arg "-lock")
;;      		  (args:get-arg "-unlock")
;;      		  (bdat-user *bdat*)))))
;;      
;;      ;;======================================================================
;;      ;; Get paths to tests
;;      ;;======================================================================
;;      ;; Get test paths matching target, runname, and testpatt
;;      (if (or (args:get-arg "-test-files")(args:get-arg "-test-paths"))
;;          ;; if we are in a test use the MT_CMDINFO data
;;          (if (get-environment-variable "MT_CMDINFO")
;;      	(let* ((startingdir (current-directory))
;;      	       (cmdinfo   (common:read-encoded-string (get-environment-variable "MT_CMDINFO")))
;;      	       (transport (assoc/default 'transport cmdinfo))
;;      	       (testpath  (assoc/default 'testpath  cmdinfo))
;;      	       (test-name (assoc/default 'test-name cmdinfo))
;;      	       (runscript (assoc/default 'runscript cmdinfo))
;;      	       (db-host   (assoc/default 'db-host   cmdinfo))
;;      	       (run-id    (assoc/default 'run-id    cmdinfo))
;;      	       (itemdat   (assoc/default 'itemdat   cmdinfo))
;;      	       (state     (args:get-arg ":state"))
;;      	       (status    (args:get-arg ":status"))
;;      	       ;;(target    (args:get-arg "-target"))
;;      	       (target    (common:args-get-target))
;;      	       (toppath   (assoc/default 'toppath   cmdinfo)))
;;      	  (change-directory toppath)
;;      	  (if (not target)
;;      	      (begin
;;      		(debug:print-error 0 *default-log-port* "-target is required.")
;;      		(exit 1)))
;;      	  (if (not (launch:setup))
;;      	      (begin
;;      		(debug:print 0 *default-log-port* "Failed to setup, giving up on -test-paths or -test-files, exiting")
;;      		(exit 1)))
;;      	  (let* ((keys     (rmt:get-keys))
;;      		 ;; db:test-get-paths must not be run remote
;;      		 (paths    (tests:test-get-paths-matching keys target (args:get-arg "-test-files"))))
;;      	    (set! *didsomething* #t)
;;      	    (for-each (lambda (path)
;;      			(if (common:file-exists? path)
;;      			(print path)))	
;;      		      paths)))
;;      	;; else do a general-run-call
;;      	(general-run-call 
;;      	 "-test-files"
;;      	 "Get paths to test"
;;      	 (lambda (target runname keys keyvals)
;;      	   (let* ((db       #f)
;;      		  ;; DO NOT run remote
;;      		  (paths    (tests:test-get-paths-matching keys target (args:get-arg "-test-files"))))
;;      	     (for-each (lambda (path)
;;      			 (print path))
;;      		       paths))))))
;;      
;;      ;;======================================================================
;;      ;; Archive tests
;;      ;;======================================================================
;;      ;; Archive tests matching target, runname, and testpatt
;;      (if (equal? (args:get-arg "-archive") "replicate-db")
;;          (begin
;;                ;; check if source
;;                ;; check if megatest.db exist
;;               (launch:setup)
;;               (if (not (args:get-arg "-source"))
;;                   (begin 
;;                   (debug:print-info 1 *default-log-port* "Missing required argument -source <archive path>")
;;                   (exit 1)))
;;               (if (common:file-exists? (conc  *toppath* "/megatest.db"))
;;                   (begin  
;;                     (debug:print-info 1 *default-log-port* "File " (conc  *toppath* "/megatest.db") " already exists. Please remove it before trying to replicate db")
;;                     (exit 1)))
;;               (if (and (common:get-db-tmp-area) (> (length (directory   (common:get-db-tmp-area) #f)) 0))
;;                 (begin
;;                 (debug:print-info 1 *default-log-port* (common:get-db-tmp-area) " not empty. Please remove it before trying to replicate db")
;;                 (exit 1)))    
;;                ;; check if timestamp 
;;                (let* ((source (args:get-arg "-source"))
;;                      (src     (if (not (equal? (substring source 0 1) "/"))
;;                                   (conc (current-directory) "/" source)
;;                                   source))
;;                      (ts (if (args:get-arg "-time-stamp")   (args:get-arg "-time-stamp") "latest")))
;;                    (if  (common:directory-exists? src)
;;                        (begin 
;;                        (archive:restore-db src ts)
;;                  (set! *didsomething* #t))
;;             (begin
;;               (debug:print-error 1 *default-log-port* "Path " source " not found")
;;               (exit 1))))))   
;;          ;; else do a general-run-call
;;         (if (and (args:get-arg "-archive") (not (equal? (args:get-arg "-archive") "replicate-db"))) 
;;          (begin
;;            ;; for the archive get we need to preserve the starting dir as part of the target path
;;            (if (and (args:get-arg "-dest")
;;      	       (not (equal? (substring (args:get-arg "-dest") 0 1) "/")))
;;      	  (let ((newpath  (conc (current-directory) "/" (args:get-arg "-dest"))))
;;      	    (debug:print-info 1 *default-log-port* "Preserving original path to destination, was " (args:get-arg "-dest") ", now " newpath)
;;      	    (hash-table-set! args:arg-hash "-dest" newpath)))
;;            (general-run-call 
;;             "-archive"
;;             "Archive"
;;             (lambda (target runname keys keyvals)
;;      	 (operate-on 'archive target-in: target runname-in: runname )))))
;;      
;;      ;;======================================================================
;;      ;; Extract a spreadsheet from the runs database
;;      ;;======================================================================
;; 
;; ;; TODO: Reenable this functionality
;; 
;;      #;(if (args:get-arg "-extract-ods")
;;          (general-run-call
;;           "-extract-ods"
;;           "Make ods spreadsheet"
;;           (lambda (target runname keys keyvals)
;;             (let ((dbstruct   (make-dbr:dbstruct path: *toppath* local: #t))
;;      	     (outputfile (args:get-arg "-extract-ods"))
;;      	     (runspatt   (or (args:get-arg "-runname")(args:get-arg ":runname")))
;;      	     (pathmod    (args:get-arg "-pathmod")))
;;      	     ;; (keyvalalist (keys->alist keys "%")))
;;      	 (debug:print 2 *default-log-port* "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvals: " keyvals)
;;      	 (db:extract-ods-file dbstruct outputfile keyvals (if runspatt runspatt "%") pathmod)
;;      	 (db:close-all dbstruct)
;;      	 (set! *didsomething* #t)))))
;;      
;;      ;;======================================================================
;;      ;; execute the test
;;      ;;    - gets called on remote host
;;      ;;    - receives info from the -execute param
;;      ;;    - passes info to steps via MT_CMDINFO env var (future is to use a dot file)
;;      ;;    - gathers host info and 
;;      ;;======================================================================
;;      
;;      (if (args:get-arg "-execute")
;;          (begin
;;            (launch:execute (args:get-arg "-execute"))
;;            (set! *didsomething* #t)))
;;      
;;      ;;======================================================================
;;      ;; recover from a test where the managing mtest was killed but the underlying
;;      ;; process might still be salvageable
;;      ;;======================================================================
;;      
;;      (if (args:get-arg "-recover-test")
;;          (let* ((params (string-split (args:get-arg "-recover-test") ",")))
;;            (if (> (length params) 1) ;; run-id and test-id
;;      	  (let ((run-id (string->number (car params)))
;;      		(test-id (string->number (cadr params))))
;;      	    (if (and run-id test-id)
;;      		(begin
;;      		  (launch:recover-test run-id test-id)
;;      		  (set! *didsomething* #t))
;;      		(begin
;;      		  (debug:print-error 0 *default-log-port* "bad run-id or test-id, must be integers")
;;      		  (exit 1)))))))
;;      
;;   (if (args:get-arg "-step")
;;       (begin
;;            (thread-sleep! 1.5)
;;            (megatest:step 
;;             (args:get-arg "-step")
;;             (or (args:get-arg "-state")(args:get-arg ":state"))
;;             (or (args:get-arg "-status")(args:get-arg ":status"))
;;             (args:get-arg "-setlog")
;;             (args:get-arg "-m"))
;;            ;; (if db (sqlite3:finalize! db))
;;            (set! *didsomething* #t)
;;            (thread-sleep! 1.5)))
;;          
;;      (if (or (args:get-arg "-setlog")       ;; since setting up is so costly lets piggyback on -test-status
;;      	;;     (not (args:get-arg "-step")))  ;; -setlog may have been processed already in the "-step" previous
;;      	;;     NEW POLICY - -setlog sets test overall log on every call.
;;      	(args:get-arg "-set-toplog")
;;      	(args:get-arg "-test-status")
;;      	(args:get-arg "-set-values")
;;      	(args:get-arg "-load-test-data")
;;      	(args:get-arg "-runstep")
;;      	(args:get-arg "-summarize-items"))
;;          (if (not (get-environment-variable "MT_CMDINFO"))
;;      	(begin
;;      	  (debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!")
;;      	  (exit 5))
;;      	(let* ((startingdir (current-directory))
;;      	       (cmdinfo   (common:read-encoded-string (get-environment-variable "MT_CMDINFO")))
;;      	       (transport (assoc/default 'transport cmdinfo))
;;      	       (testpath  (assoc/default 'testpath  cmdinfo))
;;      	       (test-name (assoc/default 'test-name cmdinfo))
;;      	       (runscript (assoc/default 'runscript cmdinfo))
;;      	       (db-host   (assoc/default 'db-host   cmdinfo))
;;      	       (run-id    (assoc/default 'run-id    cmdinfo))
;;      	       (test-id   (assoc/default 'test-id   cmdinfo))
;;      	       (itemdat   (assoc/default 'itemdat   cmdinfo))
;;      	       (work-area (assoc/default 'work-area cmdinfo))
;;      	       (db        #f) ;; (open-db))
;;      	       (state     (args:get-arg ":state"))
;;      	       (status    (args:get-arg ":status"))
;;      	       (stepname  (args:get-arg "-step")))
;;      	  (if (not (launch:setup))
;;      	      (begin
;;      		(debug:print 0 *default-log-port* "Failed to setup, exiting")
;;      		(exit 1)))
;;      
;;      	  (if (args:get-arg "-runstep")(debug:print-info 1 *default-log-port* "Running -runstep, first change to directory " work-area))
;;      	  (change-directory work-area)
;;      	  ;; can setup as client for server mode now
;;      	  ;; (client:setup)
;;      
;;      	  (if (args:get-arg "-load-test-data")
;;      	      ;; has sub commands that are rdb:
;;      	      ;; DO NOT put this one into either rmt: or open-run-close
;;      	      (tdb:load-test-data run-id test-id))
;;      	  (if (args:get-arg "-setlog")
;;      	      (let ((logfname (args:get-arg "-setlog")))
;;      		(rmt:test-set-log! run-id test-id logfname)))
;;      	  (if (args:get-arg "-set-toplog")
;;      	      ;; DO NOT run remote
;;      	      (tests:test-set-toplog! run-id test-name (args:get-arg "-set-toplog")))
;;      	  (if (args:get-arg "-summarize-items")
;;      	      ;; DO NOT run remote
;;      	      (tests:summarize-items run-id test-id test-name #t)) ;; do force here
;;      	  (if (args:get-arg "-runstep")
;;      	      (if (null? remargs)
;;      		  (begin
;;      		    (debug:print-error 0 *default-log-port* "nothing specified to run!")
;;      		    (if db (sqlite3:finalize! db))
;;      		    (exit 6))
;;      		  (let* ((stepname   (args:get-arg "-runstep"))
;;      			 (logprofile (args:get-arg "-logpro"))
;;      			 (logfile    (conc stepname ".log"))
;;      			 (cmd        (if (null? remargs) #f (car remargs)))
;;      			 (params     (if cmd (cdr remargs) '()))
;;      			 (exitstat   #f)
;;      			 (shell      (let ((sh (get-environment-variable "SHELL") ))
;;      				       (if sh 
;;      					   (last (string-split sh "/"))
;;      					   "bash")))
;;      			 (redir      (case (string->symbol shell)
;;      				       ((tcsh csh ksh)    ">&")
;;      				       ((zsh bash sh ash) "2>&1 >")
;;      				       (else ">&")))
;;      			 (fullcmd    (conc "(" (string-intersperse 
;;      						(cons cmd params) " ")
;;      					   ") " redir " " logfile)))
;;      		    ;; mark the start of the test
;;      		    (rmt:teststep-set-status! run-id test-id stepname "start" "n/a" (args:get-arg "-m") logfile)
;;      		    ;; run the test step
;;      		    (debug:print-info 2 *default-log-port* "Running \"" fullcmd "\" in directory \"" startingdir)
;;      		    (change-directory startingdir)
;;      		    (set! exitstat (system fullcmd))
;;      		    (set! *globalexitstatus* exitstat)
;;      		    ;; (change-directory testpath)
;;      		    ;; run logpro if applicable ;; (process-run "ls" (list "/foo" "2>&1" "blah.log"))
;;      		    (if logprofile
;;      			(let* ((htmllogfile (conc stepname ".html"))
;;      			       (oldexitstat exitstat)
;;      			       (cmd         (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " ")))
;;      			  (debug:print-info 2 *default-log-port* "running \"" cmd "\"")
;;      			  (change-directory startingdir)
;;      			  (set! exitstat (system cmd))
;;      			  (set! *globalexitstatus* exitstat) ;; no necessary
;;      			  (change-directory testpath)
;;      			  (rmt:test-set-log! run-id test-id htmllogfile)))
;;      		    (let ((msg (args:get-arg "-m")))
;;      		      (rmt:teststep-set-status! run-id test-id stepname "end" exitstat msg logfile))
;;      		    )))
;;      	  (if (or (args:get-arg "-test-status")
;;      		  (args:get-arg "-set-values"))
;;      	      (let ((newstatus (cond
;;      				((number? status)       (if (equal? status 0) "PASS" "FAIL"))
;;      				((and (string? status)
;;      				      (string->number status))(if (equal? (string->number status) 0) "PASS" "FAIL"))
;;      				(else status)))
;;      		    ;; transfer relevant keys into a hash to be passed to test-set-status!
;;      		    ;; could use an assoc list I guess. 
;;      		    (otherdata (let ((res (make-hash-table)))
;;      				 (for-each (lambda (key)
;;      					     (if (args:get-arg key)
;;      						 (hash-table-set! res key (args:get-arg key))))
;;      					   (list ":value" ":tol" ":expected" ":first_err" ":first_warn" ":units" ":category" ":variable"))
;;      				 res)))
;;      		(if (and (args:get-arg "-test-status")
;;      			 (or (not state)
;;      			     (not status)))
;;      		    (begin
;;      		      (debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -test-status\n" help)
;;      		      (if (sqlite3:database? db)(sqlite3:finalize! db))
;;      		      (exit 6)))
;;      		(let* ((msg    (args:get-arg "-m"))
;;      		       (numoth (length (hash-table-keys otherdata))))
;;      		  ;; Convert to rpc inside the tests:test-set-status! call, not here
;;      		  (tests:test-set-status! run-id test-id state newstatus msg otherdata work-area: work-area))))
;;      	  (if (sqlite3:database? db)(sqlite3:finalize! db))
;;      	  (set! *didsomething* #t))))
;;      
;;      ;;======================================================================
;;      ;; Various helper commands can go below here
;;      ;;======================================================================
;;      
;;      (if (or (args:get-arg "-showkeys")
;;              (args:get-arg "-show-keys"))
;;          (let ((db #f)
;;      	  (keys #f))
;;            (if (not (launch:setup))
;;      	  (begin
;;      	    (debug:print 0 *default-log-port* "Failed to setup, exiting")
;;      	    (exit 1)))
;;            (set! keys (rmt:get-keys)) ;;  db))
;;            (debug:print 1 *default-log-port* "Keys: " (string-intersperse keys ", "))
;;            (if (sqlite3:database? db)(sqlite3:finalize! db))
;;            (set! *didsomething* #t)))
;;      
;;      (if (args:get-arg "-gui")
;;          (begin
;;            (debug:print 0 *default-log-port* "Look at the dashboard for now")
;;            ;; (megatest-gui)
;;            (set! *didsomething* #t)))
;;      
;;      (if (args:get-arg "-create-megatest-area")
;;          (begin
;;            (genexample:mk-megatest.config)
;;            (set! *didsomething* #t)))
;;      
;;      (if (args:get-arg "-create-test")
;;          (let ((testname (args:get-arg "-create-test")))
;;            (genexample:mk-megatest-test testname)
;;            (set! *didsomething* #t)))
;;      
;;      ;;======================================================================
;;      ;; Update the database schema, clean up the db
;;      ;;======================================================================
;; 
;; ;; TODO: Restore this functionality
;; 
;;       #;(if (args:get-arg "-rebuild-db")
;;          (begin
;;            (if (not (launch:setup))
;;      	  (begin
;;      	    (debug:print 0 *default-log-port* "Failed to setup, exiting") 
;;      	    (exit 1)))
;;            ;; keep this one local
;;            ;; (open-run-close patch-db #f)
;;            (let ((dbstruct (db:setup #f areapath: *toppath*)))
;;              (common:cleanup-db dbstruct full: #t))
;;            (set! *didsomething* #t)))
;;      
;;      #;(if (args:get-arg "-cleanup-db")
;;          (begin
;;            (if (not (launch:setup))
;;      	  (begin
;;      	    (debug:print 0 *default-log-port* "Failed to setup, exiting") 
;;      	    (exit 1)))
;;            (let ((dbstruct (db:setup #f areapath: *toppath*)))
;;              (common:cleanup-db dbstruct))
;;            (set! *didsomething* #t)))
;;      
;;      (if (args:get-arg "-mark-incompletes")
;;          (begin
;;            (if (not (launch:setup))
;;      	  (begin
;;      	    (debug:print 0 *default-log-port* "Failed to setup, exiting")
;;      	    (exit 1)))
;;            (runs:find-and-mark-incomplete-and-check-end-of-run #f)
;;            (set! *didsomething* #t)))
;;      
;;      ;;======================================================================
;;      ;; Update the tests meta data from the testconfig files
;;      ;;======================================================================
;;      
;;      (if (args:get-arg "-update-meta")
;;          (begin
;;            (if (not (launch:setup))
;;      	  (begin
;;      	    (debug:print 0 *default-log-port* "Failed to setup, exiting") 
;;      	    (exit 1)))
;;            (runs:update-all-test_meta #f)
;;            (set! *didsomething* #t)))
;;      
;;      ;;======================================================================
;;      ;; Start a repl
;;      ;;======================================================================
;;      
;;      ;; fakeout readline
;;      ;; (include "readline-fix.scm")
;;      
;;      
;;      (when (args:get-arg "-diff-rep")
;;        (when (and
;;               (not (args:get-arg "-diff-html"))
;;               (not (args:get-arg "-diff-email")))
;;          (debug:print 0 *default-log-port* "Must specify -diff-html or -diff-email with -diff-rep")
;;          (set! *didsomething* 1)
;;          (exit 1))
;;        
;;        (let* ((toppath (launch:setup)))
;;          (do-diff-report
;;           (args:get-arg "-src-target")
;;           (args:get-arg "-src-runname")
;;           (args:get-arg "-target")
;;           (args:get-arg "-runname")
;;           (args:get-arg "-diff-html")
;;           (args:get-arg "-diff-email"))
;;          (set! *didsomething* #t)
;;          (exit 0)))
;;      
;;      (if (or (get-environment-variable "MT_RUNSCRIPT")
;;      	(args:get-arg "-repl")
;;      	(args:get-arg "-load"))
;;          (let* ((toppath (launch:setup)))
;; 		
;;      	        ;; (dbstruct (if (and toppath
;; 		;; 	      #;(common:on-homehost?))
;; 		;; 	 (db:setup #f) ;; sets up main.db
;; 		;; 	 #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f)))
;; 	   (if *toppath*
;; 	       (cond
;; 		((get-environment-variable "MT_RUNSCRIPT")
;; 		 ;; How to run megatest scripts
;; 		 ;;
;; 		 ;; #!/bin/bash
;; 		 ;;
;; 		 ;; export MT_RUNSCRIPT=yes
;; 		 ;; megatest << EOF
;; 		 ;; (print "Hello world")
;; 		 ;; (exit)
;; 		 ;; EOF
;; 		 
;; 		 (repl))
;; 		(else
;; 		 (begin
;; 		   ;; (set! *db* dbstruct)
;; 		   ;; (import extras) ;; might not be needed
;; 		   ;; (import chicken.csi)
;; 		   ;; (import readline)
;; 		   #;(import apropos
;; 			   archivemod
;; 			   commonmod
;; 			   configfmod
;; 			   dbmod
;; 			   debugprint
;; 			   ezstepsmod
;; 			   launchmod
;; 			   processmod
;; 			   rmtmod
;; 			   runsmod
;; 			   servermod
;; 			   tasksmod
;; 			   testsmod)
;; 		   
;; 		   (set-history-length! 300)
;; 		   (load-history-from-file ".megatest_history")
;; 		   (current-input-port (make-linenoise-port))
;; 		   ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
;; 		   
;; 		   ;; (if *use-new-readline*
;; 		   ;; 	  (begin
;; 		   ;; 	    (install-history-file (get-environment-variable "HOME") ".megatest_history") ;;  [homedir] [filename] [nlines])
;; 		   ;; 	    (current-input-port (make-readline-port "megatest> ")))
;; 		   ;; 	  (begin
;; 		   ;; 	    (gnu-history-install-file-manager
;; 		   ;; 	     (string-append
;; 		   ;; 	      (or (get-environment-variable "HOME") ".") "/.megatest_history"))
;; 		   ;; 	    (current-input-port (make-gnu-readline-port "megatest> "))))
;; 		   (if (args:get-arg "-repl")
;; 		       (repl)
;; 		       (load (args:get-arg "-load")))
;; 		   ;; (db:close-all dbstruct) <= taken care of by on-exit call
;; 		   )
;; 		 (exit)))
;; 	       (set! *didsomething* #t))))
;;      
;;      ;;======================================================================
;;      ;; Wait on a run to complete
;;      ;;======================================================================
;;      
;;      (if (and (args:get-arg "-run-wait")
;;      	 (not (or (args:get-arg "-run")
;;      		  (args:get-arg "-runtests")))) ;; run-wait is built into runtests now
;;          (begin
;;            (if (not (launch:setup))
;;      	  (begin
;;      	    (debug:print 0 *default-log-port* "Failed to setup, exiting") 
;;      	    (exit 1)))
;;            (operate-on 'run-wait)
;;            (set! *didsomething* #t)))
;;      
;;      ;; ;; ;; redo me ;; Not converted to use dbstruct yet
;;      ;; ;; ;; redo me ;;
;;      ;; ;; ;; redo me (if (args:get-arg "-convert-to-norm")
;;      ;; ;; ;; redo me     (let* ((toppath (setup-for-run))
;;      ;; ;; ;; redo me 	   (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t))))
;;      ;; ;; ;; redo me       (for-each 
;;      ;; ;; ;; redo me        (lambda (field)
;;      ;; ;; ;; redo me 	 (let ((dat '()))
;;      ;; ;; ;; redo me 	   (debug:print-info 0 *default-log-port* "Getting data for field " field)
;;      ;; ;; ;; redo me 	   (sqlite3:for-each-row
;;      ;; ;; ;; redo me 	    (lambda (id val)
;;      ;; ;; ;; redo me 	      (set! dat (cons (list id val) dat)))
;;      ;; ;; ;; redo me 	    (db:get-db db run-id)
;;      ;; ;; ;; redo me 	    (conc "SELECT id," field " FROM tests;"))
;;      ;; ;; ;; redo me 	   (debug:print-info 0 *default-log-port* "found " (length dat) " items for field " field)
;;      ;; ;; ;; redo me 	   (let ((qry (sqlite3:prepare db (conc "UPDATE tests SET " field "=? WHERE id=?;"))))
;;      ;; ;; ;; redo me 	     (for-each
;;      ;; ;; ;; redo me 	      (lambda (item)
;;      ;; ;; ;; redo me 		(let ((newval ;; (sdb:qry 'getid 
;;      ;; ;; ;; redo me 		       (cadr item))) ;; )
;;      ;; ;; ;; redo me 		  (if (not (equal? newval (cadr item)))
;;      ;; ;; ;; redo me 		      (debug:print-info 0 *default-log-port* "Converting " (cadr item) " to " newval " for test #" (car item)))
;;      ;; ;; ;; redo me 		  (sqlite3:execute qry newval (car item))))
;;      ;; ;; ;; redo me 	      dat)
;;      ;; ;; ;; redo me 	     (sqlite3:finalize! qry))))
;;      ;; ;; ;; redo me        (db:close-all dbstruct)
;;      ;; ;; ;; redo me        (list "uname" "rundir" "final_logf" "comment"))
;;      ;; ;; ;; redo me       (set! *didsomething* #t)))
;; 
;; ;; TODO: restore this functionality
;; 
;;      #;(if (args:get-arg "-import-megatest.db")
;;          (begin
;;            (db:multi-db-sync 
;;             (db:setup #f)
;;             'killservers
;;             'dejunk
;;             'adj-testids
;;             'old2new
;;             ;; 'new2old
;;             )
;;            (set! *didsomething* #t)))
;;      
;;      #;(when (args:get-arg "-sync-brute-force")
;;        ((server:get-bruteforce-syncer (db:setup #t) persist-until-sync: #t))
;;        (set! *didsomething* #t))
;;      
;;      #;(if (args:get-arg "-sync-to-megatest.db")
;;          (let* ((dbstruct (db:setup #f))
;;      	   (tmpdbpth (cdr (dbr:dbstruct-tmpdb dbstruct)))
;;      	   (lockfile (conc tmpdbpth ".lock"))
;;      	   (locked   (common:simple-file-lock lockfile)) 
;;      	   (res      (if locked
;;      			 (db:multi-db-sync 
;;      			  dbstruct
;;      			  'new2old)
;;      			 #f)))
;;            (if res
;;      	  (begin
;;      	    (common:simple-file-release-lock lockfile)
;;      	    (print "Synced " res " records to megatest.db"))
;;      	  (print "Skipping sync, there is a sync in progress."))
;;            (set! *didsomething* #t)))
;;      
;;      (if (args:get-arg "-sync-to")
;;          (let ((toppath (launch:setup)))
;;            (tasks:sync-to-postgres *configdat* (args:get-arg "-sync-to"))
;;            (set! *didsomething* #t)))
;;      
;;      (if (args:get-arg "-list-test-time")
;;           (let* ((toppath (launch:setup))) 
;;           (task:get-test-times)  
;;           (set! *didsomething* #t)))
;;      
;;      (if (args:get-arg "-list-run-time")
;;           (let* ((toppath (launch:setup))) 
;;           (task:get-run-times)  
;;           (set! *didsomething* #t)))
;;           
;;      (if (args:get-arg "-generate-html")
;;          (let* ((toppath (launch:setup)))
;;            (if (tests:create-html-tree #f)
;;                (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/page0.html")
;;                (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html"))
;;            (set! *didsomething* #t)))
;;      
;;      (if (args:get-arg "-generate-html-structure")
;;          (let* ((toppath (launch:setup)))
;;            ;(if (tests:create-html-tree #f)
;;       				(if (tests:create-html-summary #f)
;;                (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/targets.html")
;;                (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html"))
;;            (set! *didsomething* #t)))
;;      
;;      (if (args:get-arg "-syscheck")
;;          (begin
;;            (mutils:syscheck common:raw-get-remote-host-load
;;      		       server:get-best-guess-address
;;      		       configf:read-config)
;;            (set! *didsomething* #t)))
;;      
;;      (if (args:get-arg "-extract-skeleton")
;;          (let* ((toppath (launch:setup)))
;;            (genexample:extract-skeleton-area (args:get-arg "-extract-skeleton"))
;;            (set! *didsomething* #t)))
;;      
;;      ;;======================================================================
;;      ;; Exit and clean up
;;      ;;======================================================================
;;      
;;      (if (not *didsomething*)
;;          (debug:print 0 *default-log-port* help)
;;          (bdat-time-to-exit-set! *bdat* #t)
;;          )
;;      ;;(debug:print-info 13 *default-log-port* "thread-join! watchdog")
;;      
;;      ;; join the watchdog thread if it has been thread-start!ed  (it may not have been started in the case of a server that never enters running state)
;;      ;;   (symbols returned by thread-state: created ready running blocked suspended sleeping terminated dead)
;;      ;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
;;      #;(let* ((watchdog (bdat-watchdog *bdat*)))
;;        (if (thread? watchdog)
;; 	   (case (thread-state watchdog)
;; 	     ((ready running blocked sleeping terminated dead)
;; 	      (thread-join! watchdog)))))
;;      
;;      (bdat-time-to-exit-set! *bdat* #t)
;;      
;;      (if (not (eq? *globalexitstatus* 0))
;;          (if (or (args:get-arg "-run")(args:get-arg "-runtests")(args:get-arg "-runall"))
;;              (begin
;; 	       (debug:print 0 *default-log-port* "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*)
;; 	       (exit 0))
;;              (case *globalexitstatus*
;; 	       ((0)(exit 0))
;; 	       ((1)(exit 1))
;; 	       ((2)(exit 2))
;; 	       (else (exit 3)))))
;;      )
;; 
;; ;; (import megatest-main commonmod)
;; ;; (import srfi-18)

(import scheme
	chicken.base
	chicken.condition
	chicken.string
	chicken.sort
	
	list-utils
	;; postgresql
	srfi-1
	srfi-69
	typed-records
	
	(prefix dbi dbi:)
	configfmod
	(prefix mtargs args:)

;;======================================================================
;; Copyright 2022, 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/>.

;;======================================================================

;; generate entries for ~/.megatestrc with the following
;;
;;  grep define ../rmt.scm | grep rmt: |perl -pi -e 's/\(define\s+\((\S+)\W.*$/\1/'|sort -u

(declare (unit rmtmod))

(declare (uses apimod))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses dbmod))
(declare (uses debugprint))
(declare (uses itemsmod))
(declare (uses mtargs))
(declare (uses mtver))
(declare (uses pgdb))
(declare (uses portloggermod))
(declare (uses servermod))
(declare (uses tasksmod))
(declare (uses ulex))
(declare (uses dbmgrmod))

(module rmtmod
	*
	
(import scheme
		
	chicken.base

	chicken.process-context.posix
	chicken.sort
	chicken.string
	;; chicken.tcp
	chicken.random
	chicken.time
	chicken.time.posix

	
	directory-utils
	format
	;; http-client
	;; intarweb
	matchable
	md5
	message-digest
	;; nng ;; nanomsg
	(prefix base64 base64:)
	(prefix sqlite3 sqlite3:)
	regex
	s11n
	;; spiffy
	;; spiffy-directory-listing
	;; spiffy-request-vars

	pgdb
	pkts
	portloggermod
	(prefix mtargs args:)
	servermod
	stml2
	tasksmod











































































































































































































































	dbmgrmod

	ulex




	)



































































































;;======================================================================
;;
;; A C T U A L   A P I   C A L L S  
;;
;;======================================================================














;;======================================================================
;;  M I S C
;;======================================================================

(define (rmt:login run-id)
  (rmt:send-receive 'login run-id (list *toppath* megatest-version *my-signature*)))

		     dbh
		     spec-id target run-name state status owner event-time comment fail-count pass-count  area-id last-update publish-time))
		       (let* ((smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f)))
             (if (or (not smallest-time) (< last-update smallest-time))
        				(hash-table-set! smallest-last-update-time "smallest-time" last-update))
             (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time))
		  #f)))))))

(define (tasks:sync-test-gen-data dbh cached-info test-data-ids smallest-last-update-time)
  (let ((test-ht (hash-table-ref cached-info 'tests))
        (data-ht (hash-table-ref cached-info 'data)))
    (for-each
     (lambda (test-data-id)
        (let* ((test-data-info  (rmt:get-data-info-by-id test-data-id))
               (data-id (db:test-data-get-id  test-data-info))

  (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))))


















































(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 (bdat-time-to-exit *bdat*) ;; hurry up
		       #f
		       (begin
			 (bdat-time-to-exit-set! *bdat* #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
		  (let* ((start-time (current-seconds)))
		    #;(if *db-serv-info*
			(let* ((host (servdat-host *db-serv-info*))
			       (port 	       (servdat-port *db-serv-info*)))
			  (debug:print-info 0 *default-log-port* "Shutting down server/responder.")
			  ;;
			  ;; TODO - add flushing/waiting on the work queue
			  ;;
			  (rmt:server-shutdown host port)
			  (portlogger:open-run-close portlogger:set-port port "released")))
				
		    (debug:print-info 0 *default-log-port* "Shutdown activities completed in "(- (current-seconds) start-time)" seconds"))
		  ;; (if *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated
		  #;(if (bdat-task-db *bdat*)    ;; TODO: Check that this is correct for task db
		  (let ((db (cdr (bdat-task-db *bdat*))))
		  (if (sqlite3:database? db)
		  (begin
		  (debug:print-info 0 *default-log-port* "Closing down task db "db)

      (thread-start! th2)
      (thread-join! th1)
      )
    )

  0)






;; 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. 
;;
;; conn is a conndat record
;;
#;(define (server:ping uconn #!key (do-exit #f))

  (let* ((srvkey (conndat-srvkey uconn))
	 (msg (sexpr->string '(ping ,srvkey))))
    (send-receive uconn 'ping msg))) ;; (server-ready? host port server-id))

;;======================================================================
;; http-transportmod.scm contents moved here
;;======================================================================

(define (http-transport:make-server-url hostport)
  (if (not hostport)
      #f
      (conc "http://" (car hostport) ":" (cadr hostport))))

;;======================================================================
;; S E R V E R
;; ======================================================================





(define (rmt:get-servers-info apath)




























































  (rmt:send-receive 'get-servers-info #f `(,apath)))




;; (define (http-get-function fnkey)







































;;   (hash-table-ref/default *http-functions* fnkey (lambda () "nothing here yet")))




;;======================================================================
;; C L I E N T S
;;======================================================================

(define (rmt:get-time-to-cleanup)
  (let ((res #f))