Megatest

# module source files
MSRCFILES = dbfile.scm debugprint.scm mtargs.scm commonmod.scm dbmod.scm \
            tcp-transportmod.scm rmtmod.scm portlogger.scm apimod.scm \
	    configfmod.scm processmod.scm servermod.scm megatestmod.scm \
	    stml2.scm fsmod.scm cpumod.scm mtmod.scm odsmod.scm \
            pkts.scm testsmod.scm pgdb.scm cookie.scm launchmod.scm \
            subrunmod.scm runsmod.scm tasksmod.scm archivemod.scm \
            ezstepsmod.scm mtbody.scm envmod.scm

transport-mode.scm : transport-mode.scm.template
	cp transport-mode.scm.template transport-mode.scm

dashboard-transport-mode.scm : dashboard-transport-mode.scm.template
	cp dashboard-transport-mode.scm.template dashboard-transport-mode.scm

mtest : transport-mode.scm
dboard : dashboard-transport-mode.scm

# dbmod.import.o is just a hack here

mofiles/mtbody.o     : mofiles/launchmod.o readline-fix.scm mofiles/envmod.o
process.o            : mofiles/processmod.o
mofiles/configfmod.o : mofiles/processmod.o
mofiles/processmod.o : mofiles/commonmod.o
mofiles/servermod.o  : mofiles/commonmod.o
mofiles/rmtmod.o     : mofiles/mtmod.o mofiles/apimod.o
mofiles/dbmod.o      : mofiles/mtmod.o
# mofiles/mtmod.o      : mofiles/tcp-transportmod.o

     srfi-18
     posix
     matchable
     s11n
     typed-records)

(declare (uses dbmod))
(declare (uses dbfile))
(declare (uses tcp-transportmod))
(declare (uses megatestmod))

(module apimod
	(
	 *server-signature*
	 api:tcp-dispatch-request-make-handler-core
	 api:register-thread
	 api:unregister-thread
	 api:get-count-threads-alive
	 api:print-db-stats
	 api:queue-processor
	 api:dispatch-request
	 )
	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix matchable typed-records srfi-1 srfi-18 srfi-69 )
(import commonmod)
(import debugprint)

     z3)

(import stml2
	)

(module commonmod
	(
	 make-sparse-array
	 sparse-array-set!
	 sparse-array-ref
	 keys->valslots
	 item-list->path
	 common:human-time
	 number-of-processes-running
	 get-normalized-cpu-load
	 common:find-local-megatest

(declare (uses processmod))
(declare (uses mtargs))

(use regex regex-case)

(module configfmod
	(
	 configf:map-all-hier-alist
	 configf:read-refdb
	 lookup
	 configf:lookup
	 get-section
	 configf:get-section
	 configf:lookup-number
	 read-config
	 runconfigs-get

	 dbmod:open-dbmoddb
	 dbmod:run-id->dbfname

	 db:roll-up-rules
	 db:get-all-state-status-counts-for-test
	 db:test-set-state-status-db
	 db:general-call
	 db:cache-for-read-only
	 db:convert-test-itempath

	 db:test-data-rollup
	 db:keep-trying-until-true
	 db:get-test-info-by-id
	 db:with-db
	 db:get-test-id

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

(declare (unit env))

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

;; (import (prefix mtargs args:)
;; 	debugprint)
;; 
;; (use sql-de-lite) ;; srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables)
;; 
;; (define (env:open-db fname)
;;   (let* ((db-exists (common:file-exists? fname))
;; 	 (db        (open-database fname)))
;;     (if (not db-exists)
;; 	(begin
;; 	  (exec (sql db "CREATE TABLE envvars (
;;                     id INTEGER PRIMARY KEY,
;;                     context TEXT NOT NULL,
;;                     var TEXT NOT NULL,
;;                     val TEXT NOT NULL,
;;                        CONSTRAINT envvars_constraint UNIQUE (context,var))"))))
;;     (set-busy-handler! db (busy-timeout 10000))
;;     db))
;; 
;; ;; save vars in given context, this is NOT incremental by default
;; ;;
;; (define (env:save-env-vars db context #!key (incremental #f)(vardat #f))
;;   (with-transaction
;;    db
;;    (lambda ()
;;      ;; first clear out any vars for this context
;;      (if (not incremental)(exec (sql db "DELETE FROM envvars WHERE context=?") context))
;;      (for-each
;;       (lambda (varval)
;; 	(let ((var (car varval))
;; 	      (val (cdr varval)))
;; 	  (if incremental (exec (sql db "DELETE FROM envvars WHERE context=? AND var=?") context var))
;; 	  (exec (sql db "INSERT INTO envvars (context,var,val) VALUES (?,?,?)") context var val)))
;; 	(if vardat
;; 	    (hash-table->alist vardat)
;; 	    (get-environment-variables))))))
;; 
;; ;; merge contexts in the order given
;; ;;  - each context is applied in the given order
;; ;;  - variables in the paths list are split on the separator and the components
;; ;;    merged using simple delta addition
;; ;;    returns a hash of the merged vars
;; ;;
;; (define (env:merge-contexts db basecontext contexts paths)
;;   (let ((result (make-hash-table)))
;;     (for-each
;;      (lambda (context)
;;        (query
;; 	(for-each-row
;; 	 (lambda (row)
;; 	   (let ((var  (car row))
;; 		 (val  (cadr row)))
;; 	     (hash-table-set! result var 
;; 			      (if (and (hash-table-ref/default result var #f)
;; 				       (assoc var paths)) ;; this var is a path and there is a previous path
;; 				  (let ((sep (cadr (assoc var paths))))
;; 				    (env:merge-path-envvar sep (hash-table-ref result var) val))
;; 				  val)))))
;; 	(sql db "SELECT var,val FROM envvars WHERE context=?")
;; 	context))
;;      contexts)
;;     result))
;; 
;; ;;  get list of removed variables between two contexts
;; ;;
;; (define (env:get-removed db contexta contextb)
;;   (let ((result (make-hash-table)))
;;     (query
;;      (for-each-row
;;       (lambda (row)
;; 	(let ((var  (car row))
;; 	      (val  (cadr row)))
;; 	  (hash-table-set! result var val))))
;;      (sql db "SELECT var,val FROM envvars WHERE context=? AND var NOT IN (SELECT var FROM envvars WHERE context=?)")
;;      contexta contextb)
;;     result))
;; 
;; ;;  get list of variables added to contextb from contexta
;; ;;
;; (define (env:get-added db contexta contextb)
;;   (let ((result (make-hash-table)))
;;     (query
;;      (for-each-row
;;       (lambda (row)
;; 	(let ((var  (car row))
;; 	      (val  (cadr row)))
;; 	  (hash-table-set! result var val))))
;;      (sql db "SELECT var,val FROM envvars WHERE context=? AND var NOT IN (SELECT var FROM envvars WHERE context=?)")
;;      contextb contexta)
;;     result))
;; 
;; ;;  get list of variables in both contexta and contexb that have been changed
;; ;;
;; (define (env:get-changed db contexta contextb)
;;   (let ((result (make-hash-table)))
;;     (query
;;      (for-each-row
;;       (lambda (row)
;; 	(let ((var  (car row))
;; 	      (val  (cadr row)))
;; 	  (hash-table-set! result var val))))
;;      (sql db "SELECT var,val FROM envvars AS a WHERE context=? AND val != (SELECT val FROM envvars WHERE var=a.var AND context=?)")
;;      contextb contexta)
;;     result))

;; 
;; ;;
;; (define (env:blind-merge l1 l2)
;;   (if (null? l1) l2
;;       (if (null? l2) l1
;; 	  (cons (car l1) (cons (car l2) (env:blind-merge (cdr l1) (cdr l2)))))))
;; 
;; ;; given a before and an after envvar calculate a new merged path
;; ;;
;; (define (env:merge-path-envvar separator patha pathb)
;;   (let* ((patha-parts  (string-split patha separator))
;; 	 (pathb-parts  (string-split pathb separator))
;; 	 (common-parts (lset-intersection equal? patha-parts pathb-parts))
;; 	 (final        (delete-duplicates ;; env:blind-merge 
;; 			(append pathb-parts common-parts patha-parts))))
;; ;;     (print "BEFORE:   " (string-intersperse patha-parts  "\n       "))
;; ;;     (print "AFTER:    " (string-intersperse pathb-parts  "\n       "))
;; ;;     (print "COMMON:   " (string-intersperse common-parts "\n       "))
;;     (string-intersperse final separator)))
;; 
;; (define (env:process-path-envvar varname separator patha pathb)
;;   (let ((newpath (env:merge-path-envvar separator patha pathb)))
;;     (setenv varname newpath)))
;; 
;; (define (env:have-context db context)
;;   (> (query fetch-value (sql db "SELECT count(id) FROM envvars WHERE context=?") context)
;;      0))
;; 
;; ;; this is so the calling block does not need to import sql-de-lite
;; (define (env:close-database db)
;;   (close-database db))
;; 
;; (define (env:lazy-hash-table->alist indat)
;;   (if (hash-table? indat)
;;       (let ((dat (hash-table->alist indat)))
;; 	(if (null? dat)
;; 	    #f 
;; 	    dat))
;;       #f))
;; 
;; (define (env:inc-path path)
;;   (print "PATH "
;; 	 (conc "#{scheme (env:min-path \"" path "\" \"#{getenv PATH}\")}")))
;; ;; 	 (conc
;; ;; 	  "#{scheme (string-intersperse "
;; ;; 	  "(delete-duplicates "
;; ;; 	  "(append (string-split \"" path "\" \":\") "
;; ;; 	  "(string-split \"#{getenv PATH}\" \":\")))"
;; ;; 	  " \":\")}")))
;; 
;; (define (env:min-path path1 path2)
;;   (string-intersperse
;;    (delete-duplicates
;;     (append
;;      (string-split path1 ":")
;;      (string-split path2 ":")))
;;    ":"))
;; 
;; ;; inc path will set a PATH that is incrementally modified when read - config mode only
;; ;;
;; (define (env:print added removed changed #!key (inc-path #t))
;;   (let ((a  (env:lazy-hash-table->alist added))
;; 	(r  (env:lazy-hash-table->alist removed))
;; 	(c  (env:lazy-hash-table->alist changed)))
;;     (case (if (args:get-arg "-dumpmode")
;; 	      (string->symbol (args:get-arg "-dumpmode"))
;; 	      'bash)
;;       ((bash)
;;        (if a
;; 	   (begin
;; 	     (print "# Added vars")
;; 	     (map (lambda (dat)(print "export " (car dat) "=" (cdr dat)))
;; 		  (hash-table->alist added))))
;;        (if r
;; 	   (begin
;; 	     (print "# Removed vars")
;; 	     (map (lambda (dat)(print "unset " (car dat)))
;; 		  (hash-table->alist removed))))
;;        (if c
;; 	   (begin
;; 	     (print "# Changed vars")
;; 	     (map (lambda (dat)(print "export " (car dat) "=" (cdr dat)))
;; 		  (hash-table->alist changed)))))
;;       ((csh)
;;        (if a
;; 	   (begin
;; 	     (print "# Added vars")
;; 	     (map (lambda (dat)(print "setenv " (car dat) " " (cdr dat)))
;; 		  (hash-table->alist added))))
;;        (if r
;; 	   (begin
;; 	     (print "# Removed vars")
;; 	     (map (lambda (dat)(print "unsetenv " (car dat)))
;; 		  (hash-table->alist removed))))
;;        (if c
;; 	   (begin
;; 	     (print "# Changed vars")
;; 	     (map (lambda (dat)(print "setenv " (car dat) " " (cdr dat)))
;; 		  (hash-table->alist changed)))))
;;       ((config ini)
;;        (if a
;; 	   (begin
;; 	     (print "# Added vars")
;; 	     (map (lambda (dat)
;; 		    (let ((var (car dat))
;; 			  (val (cdr dat)))
;; 		      (if (and inc-path
;; 			       (equal? var "PATH"))
;; 			  (env:inc-path val)
;; 			  (print var " " val))))
;; 		  (hash-table->alist added))))
;;        (if r
;; 	   (begin
;; 	     (print "# Removed vars")
;; 	     (map (lambda (dat)(print "#{scheme (unsetenv \"" (car dat) "\")}"))
;; 		  (hash-table->alist removed))))
;;        (if c
;; 	   (begin
;; 	     (print "# Changed vars")
;; 	     (map (lambda (dat)
;; 		    (let ((var (car dat))
;; 			  (val (cdr dat)))
;; 		      (if (and inc-path
;; 			       (equal? var "PATH"))
;; 			  (env:inc-path val)
;; 			  (print var " " val))))
;; 		  (hash-table->alist changed)))))
;;       (else
;;        (debug:print-error 0 *default-log-port* "No dumpmode specified, use -dumpmode [bash|csh|config]")))))
;; 

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

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

(use sql-de-lite)

(declare (unit envmod))

(declare (uses debugprint))
(declare (uses mtargs))
(declare (uses commonmod))

(module envmod
	*
	
(import scheme
	chicken

	posix
	srfi-1
	data-structures
	srfi-69)

(import (prefix mtargs args:)
	debugprint
	commonmod)

(import sql-de-lite) ;; srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables)

(define (env:open-db fname)
  (let* ((db-exists (common:file-exists? fname))
	 (db        (open-database fname)))
    (if (not db-exists)
	(begin
	  (exec (sql db "CREATE TABLE envvars (
                    id INTEGER PRIMARY KEY,
                    context TEXT NOT NULL,
                    var TEXT NOT NULL,
                    val TEXT NOT NULL,
                       CONSTRAINT envvars_constraint UNIQUE (context,var))"))))
    (set-busy-handler! db (busy-timeout 10000))
    db))

;; save vars in given context, this is NOT incremental by default
;;
(define (env:save-env-vars db context #!key (incremental #f)(vardat #f))
  (with-transaction
   db
   (lambda ()
     ;; first clear out any vars for this context
     (if (not incremental)(exec (sql db "DELETE FROM envvars WHERE context=?") context))
     (for-each
      (lambda (varval)
	(let ((var (car varval))
	      (val (cdr varval)))
	  (if incremental (exec (sql db "DELETE FROM envvars WHERE context=? AND var=?") context var))
	  (exec (sql db "INSERT INTO envvars (context,var,val) VALUES (?,?,?)") context var val)))
	(if vardat
	    (hash-table->alist vardat)
	    (get-environment-variables))))))

;; merge contexts in the order given
;;  - each context is applied in the given order
;;  - variables in the paths list are split on the separator and the components
;;    merged using simple delta addition
;;    returns a hash of the merged vars
;;
(define (env:merge-contexts db basecontext contexts paths)
  (let ((result (make-hash-table)))
    (for-each
     (lambda (context)
       (query
	(for-each-row
	 (lambda (row)
	   (let ((var  (car row))
		 (val  (cadr row)))
	     (hash-table-set! result var 
			      (if (and (hash-table-ref/default result var #f)
				       (assoc var paths)) ;; this var is a path and there is a previous path
				  (let ((sep (cadr (assoc var paths))))
				    (env:merge-path-envvar sep (hash-table-ref result var) val))
				  val)))))
	(sql db "SELECT var,val FROM envvars WHERE context=?")
	context))
     contexts)
    result))

;;  get list of removed variables between two contexts
;;
(define (env:get-removed db contexta contextb)
  (let ((result (make-hash-table)))
    (query
     (for-each-row
      (lambda (row)
	(let ((var  (car row))
	      (val  (cadr row)))
	  (hash-table-set! result var val))))
     (sql db "SELECT var,val FROM envvars WHERE context=? AND var NOT IN (SELECT var FROM envvars WHERE context=?)")
     contexta contextb)
    result))

;;  get list of variables added to contextb from contexta
;;
(define (env:get-added db contexta contextb)
  (let ((result (make-hash-table)))
    (query
     (for-each-row
      (lambda (row)
	(let ((var  (car row))
	      (val  (cadr row)))
	  (hash-table-set! result var val))))
     (sql db "SELECT var,val FROM envvars WHERE context=? AND var NOT IN (SELECT var FROM envvars WHERE context=?)")
     contextb contexta)
    result))

;;  get list of variables in both contexta and contexb that have been changed
;;
(define (env:get-changed db contexta contextb)
  (let ((result (make-hash-table)))
    (query
     (for-each-row
      (lambda (row)
	(let ((var  (car row))
	      (val  (cadr row)))
	  (hash-table-set! result var val))))
     (sql db "SELECT var,val FROM envvars AS a WHERE context=? AND val != (SELECT val FROM envvars WHERE var=a.var AND context=?)")
     contextb contexta)
    result))

;;
(define (env:blind-merge l1 l2)
  (if (null? l1) l2
      (if (null? l2) l1
	  (cons (car l1) (cons (car l2) (env:blind-merge (cdr l1) (cdr l2)))))))

;; given a before and an after envvar calculate a new merged path
;;
(define (env:merge-path-envvar separator patha pathb)
  (let* ((patha-parts  (string-split patha separator))
	 (pathb-parts  (string-split pathb separator))
	 (common-parts (lset-intersection equal? patha-parts pathb-parts))
	 (final        (delete-duplicates ;; env:blind-merge 
			(append pathb-parts common-parts patha-parts))))
;;     (print "BEFORE:   " (string-intersperse patha-parts  "\n       "))
;;     (print "AFTER:    " (string-intersperse pathb-parts  "\n       "))
;;     (print "COMMON:   " (string-intersperse common-parts "\n       "))
    (string-intersperse final separator)))

(define (env:process-path-envvar varname separator patha pathb)
  (let ((newpath (env:merge-path-envvar separator patha pathb)))
    (setenv varname newpath)))

(define (env:have-context db context)
  (> (query fetch-value (sql db "SELECT count(id) FROM envvars WHERE context=?") context)
     0))

;; this is so the calling block does not need to import sql-de-lite
(define (env:close-database db)
  (close-database db))

(define (env:lazy-hash-table->alist indat)
  (if (hash-table? indat)
      (let ((dat (hash-table->alist indat)))
	(if (null? dat)
	    #f 
	    dat))
      #f))

(define (env:inc-path path)
  (print "PATH "
	 (conc "#{scheme (env:min-path \"" path "\" \"#{getenv PATH}\")}")))
;; 	 (conc
;; 	  "#{scheme (string-intersperse "
;; 	  "(delete-duplicates "
;; 	  "(append (string-split \"" path "\" \":\") "
;; 	  "(string-split \"#{getenv PATH}\" \":\")))"
;; 	  " \":\")}")))

(define (env:min-path path1 path2)
  (string-intersperse
   (delete-duplicates
    (append
     (string-split path1 ":")
     (string-split path2 ":")))
   ":"))

;; inc path will set a PATH that is incrementally modified when read - config mode only
;;
(define (env:print added removed changed #!key (inc-path #t))
  (let ((a  (env:lazy-hash-table->alist added))
	(r  (env:lazy-hash-table->alist removed))
	(c  (env:lazy-hash-table->alist changed)))
    (case (if (args:get-arg "-dumpmode")
	      (string->symbol (args:get-arg "-dumpmode"))
	      'bash)
      ((bash)
       (if a
	   (begin
	     (print "# Added vars")
	     (map (lambda (dat)(print "export " (car dat) "=" (cdr dat)))
		  (hash-table->alist added))))
       (if r
	   (begin
	     (print "# Removed vars")
	     (map (lambda (dat)(print "unset " (car dat)))
		  (hash-table->alist removed))))
       (if c
	   (begin
	     (print "# Changed vars")
	     (map (lambda (dat)(print "export " (car dat) "=" (cdr dat)))
		  (hash-table->alist changed)))))
      ((csh)
       (if a
	   (begin
	     (print "# Added vars")
	     (map (lambda (dat)(print "setenv " (car dat) " " (cdr dat)))
		  (hash-table->alist added))))
       (if r
	   (begin
	     (print "# Removed vars")
	     (map (lambda (dat)(print "unsetenv " (car dat)))
		  (hash-table->alist removed))))
       (if c
	   (begin
	     (print "# Changed vars")
	     (map (lambda (dat)(print "setenv " (car dat) " " (cdr dat)))
		  (hash-table->alist changed)))))
      ((config ini)
       (if a
	   (begin
	     (print "# Added vars")
	     (map (lambda (dat)
		    (let ((var (car dat))
			  (val (cdr dat)))
		      (if (and inc-path
			       (equal? var "PATH"))
			  (env:inc-path val)
			  (print var " " val))))
		  (hash-table->alist added))))
       (if r
	   (begin
	     (print "# Removed vars")
	     (map (lambda (dat)(print "#{scheme (unsetenv \"" (car dat) "\")}"))
		  (hash-table->alist removed))))
       (if c
	   (begin
	     (print "# Changed vars")
	     (map (lambda (dat)
		    (let ((var (car dat))
			  (val (cdr dat)))
		      (if (and inc-path
			       (equal? var "PATH"))
			  (env:inc-path val)
			  (print var " " val))))
		  (hash-table->alist changed)))))
      (else
       (debug:print-error 0 *default-log-port* "No dumpmode specified, use -dumpmode [bash|csh|config]")))))

)

(declare (uses api))
(declare (uses env))
(declare (uses diff-report))
(declare (uses runs))
(declare (uses launch))
(declare (uses server))
(declare (uses genexample))














































































































































































































































































































































































































































































































































































































































































































(declare (uses mtbody))




































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































(import mtbody)





















































































































































































































































































































































































































































































































































































































(main)

(declare (uses servermod))
(declare (uses fsmod))

(use srfi-69)

(module megatestmod
	(
	 common:get-disks
	 db:set-tests-state-status
	 db:set-state-status-and-roll-up-items
	 common:get-install-area
	 tests:get-all
	 common:use-cache?

	 mt:lazy-read-test-config
	 common:get-full-test-name
	 tests:extend-test-patts
	 tests:get-itemmaps
	 tests:get-items
	 tests:get-global-waitons
	 tests:get-tests-search-path
	 tests:filter-test-names
	 common:args-get-testpatt
	 tests:filter-test-names-not-matched
	 common:args-get-runname
	 common:load-views-config
	 )

(import scheme)
(cond-expand
 (chicken-4
  
  (import chicken
	  ports

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

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

;;======================================================================
;;   All the crud that was in megatest.scm
;;======================================================================

(declare (unit mtbody))
(declare (uses debugprint))
(declare (uses mtargs))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses dbmod))
(declare (uses dbfile))
(declare (uses envmod))
(declare (uses apimod))

(use srfi-69)

(module mtbody
	*
	
(import scheme)
(cond-expand
 (chicken-4
  
  (import chicken
	  ports
	  (prefix base64 base64:)

	  (prefix sqlite3 sqlite3:)
	  data-structures 
	  directory-utils
	  extras
	  files
	  matchable
	  md5
	  message-digest
	  pathname-expand
	  posix
	  posix-extras
	  regex
	  regex-case
	  sparse-vectors
	  srfi-1
	  srfi-18
	  srfi-69
	  typed-records
	  z3
	  
	  debugprint
	  commonmod
	  configfmod
	  ;; tcp-transportmod
	  (prefix mtargs args:)
	  )
  (use srfi-69))
 (chicken-5
  (import (prefix sqlite3 sqlite3:)
	  ;; data-structures
	  ;; extras
	  ;; files
	  ;; posix
	  ;; posix-extras
	  chicken.base
	  chicken.condition
	  chicken.file
	  chicken.file.posix
	  chicken.io
	  chicken.pathname
	  chicken.port
	  chicken.process
	  chicken.process-context
	  chicken.process-context.posix
	  chicken.sort
	  chicken.string
	  chicken.time
	  chicken.time.posix
	  
	  matchable
	  md5
	  message-digest
	  pathname-expand
	  regex
	  regex-case
	  srfi-1
	  srfi-18
	  srfi-69
	  typed-records
	  system-information

	  debugprint
  )))

;; imports common to chk5 and ck4
(import srfi-13)

(import (prefix mtargs args:)
        debugprint
	dbmod
	commonmod
	processmod
	configfmod
	dbfile
	dbmod
	portlogger
	tcp-transportmod
	rmtmod
	apimod
	stml2
	mtmod
	megatestmod
	servermod
	tasksmod
	runsmod
	rmtmod
	launchmod
	fsmod
	envmod
	apimod
        )

(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 "megatest-fossil-hash.scm")

(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:))
(use readline apropos json http-client directory-utils typed-records)
(use http-client srfi-18 extras format tcp-server tcp)

;; Added for csv stuff - will be removed
;;
(use sparse-vectors)

(require-library mutils)

;;======================================================================
;; api handler stuff
;;======================================================================

;; QUEUE METHOD

(define (api:tcp-dispatch-request-make-handler-new dbstruct) ;; cmd run-id params)
  (api:tcp-dispatch-request-make-handler-core dbstruct api:dispatch-request))


;; indat is (cmd run-id params meta)
;;
;; WARNING: Do not print anything in the lambda of this function as it
;;          reads/writes to current in/out port
;;
(define (api:tcp-dispatch-request-make-handler-old dbstruct) ;; cmd run-id params)
  (assert *toppath* "FATAL: api:tcp-dispatch-request-make-handler called but *toppath* not set.")
  (if (not *server-signature*)
      (set! *server-signature* (tt:mk-signature *toppath*)))
  (lambda (indat)
    (api:register-thread (current-thread))
    (let* ((result 
	    (let* ((numthreads (api:get-count-threads-alive))
		   (delay-wait (if (> numthreads 10)
				   (- numthreads 10)
				   0))
		   (normal-proc (lambda (cmd run-id params)
				  (case cmd
				    ((ping) *server-signature*)
				    (else
				     (api:dispatch-request dbstruct cmd run-id params))))))
	      (set! *api-process-request-count* numthreads)
	      (set! *db-last-access* (current-seconds))
;; 	      (if (not (eq? numthreads numthreads))
;; 	      (begin
;; 	      (api:remove-dead-or-terminated)
;; 	      (let ((threads-now (api:get-count-threads-alive)))
;; 	      (debug:print 0 *default-log-port* "WARNING: numthreads="numthreads", numthreads="numthreads", remaining="threads-now)
;; 	      (set! numthreads threads-now))))
	      (match indat
		     ((cmd run-id params meta)
		      (let* ((start-t (current-milliseconds))
			     (db-ok  (let* ((dbfname (dbmod:run-id->dbfname run-id))
					    (ok      (equal? dbfname (dbr:dbstruct-dbfname dbstruct))))
				       (case cmd
					 ((ping) #t) ;; we are fine
					 (else
					  (assert ok "FATAL: database file and run-id not aligned.")))))
			     (ttdat   *server-info*)
			     (server-state (tt-state ttdat))
			     (maxthreads   20) ;; make this a parameter?
			     (status  (cond
				       ((and (> numthreads maxthreads)
					     (> (random 100) 70)) ;; allow a 30% probability to go through so we can figure out what is going wrong in main.db server.
					'busy)
				       ;; ((> numthreads 5) 'loaded) ;; this gets transmitted to the client which calls tt:backoff-incr to slow stuff down.
				       (else 'ok)))
			     (errmsg  (case status
					((busy)   (conc "Server overloaded, "numthreads" threads in flight"))
					((loaded) (conc "Server loaded, "numthreads" threads in flight"))
					(else     #f)))
			     (result  (case status
					((busy)
					 (if (eq? cmd 'ping)
					     (normal-proc cmd run-id params)
					     ;; numthreads must be greater than 5 for busy
					     (* 0.1 (- numthreads maxthreads)) ;; was 15 - return a number for the remote to delay
					     )) ;; (- numthreads 29)) ;; call back in as many seconds
					((loaded)
					 (normal-proc cmd run-id params))
					(else
					 (normal-proc cmd run-id params))))
			     (meta   (case cmd
				       ((ping) `((sstate . ,server-state)))
				       (else   `((wait . ,delay-wait)))))
			     (payload (list status errmsg result meta)))
			;; (cmd run-id params meta)
			(db:add-stats cmd run-id params (- (current-milliseconds) start-t))
			payload))
		     (else
		      (assert #f "FATAL: failed to deserialize indat "indat))))))
      ;; (set! *api-process-request-count* (- *api-process-request-count* 1))
      ;; (serialize payload)
     
      (api:unregister-thread (current-thread))
      result)))

(define api:tcp-dispatch-request-make-handler api:tcp-dispatch-request-make-handler-new) ;; choose -old or -new

;; end api stuff

;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions
(define (open-logfile logpath-in)
  (let ((lpath #f))
    (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)))
       (set! lpath logpath) ;; just for printing if error
       (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: "lpath)
          (define *didsomething* #t)  
          (exit 1)))))

(define (main)
  ;; remove when configf fully modularized
  (read-config-set! configf:read-file)

  (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 some parameters here - these need to be put in something that can be loaded from other
  ;; executables such as dashboard and mtutil
  ;;
  (include "transport-mode.scm")
  (dbfile:db-init-proc db:initialize-main-db)
  (debug:enable-timestamp #t) 


  (set! rmtmod:send-receive rmt:send-receive)
  ;;(lambda params (apply rmt:send-receive params))) ;; make send-receive available to rmtmod via parameter


  ;; 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-write-access? *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))

  ;; 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
  -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
  -import-sexpr fname     : import a sexpr file (use -list-runs % -dumpmode sexpr to create)
  -remove-dbs all         : remove Megatest DBs before importing sexpr. (Use only with -import-sexpr)
  -regen-testfiles        : regenerate scripts and logpro files from testconfig, run in test context
  
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
  -db2db                  : sync db to db, use -from, -to for dbs, -period and -timeout for continuous sync

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

  ;;  -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"
			  "-from"
			  "-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"
			  "-adjutant"
			  "-transport"
			  "-port"
			  "-extract-ods"
			  "-pathmod"
			  "-env2file"
			  "-envcap"
			  "-envdelta"
			  "-setvars"
			  "-set-state-status"
			  "-import-sexpr"
                          "-remove-dbs" ;; to be used only with -import-sexpr to remove megatest dbs first.
			  "-period"  ;; sync period in seconds
			  "-timeout" ;; exit sync if timeout in seconds exceeded since last change

                          ;; 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"
			  "-db"
			  "-ping"
			  "-refdb2dat"
			  "-o"
			  "-log"
                          "-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"
			  "-regen-testfiles"
			  
			  ;; 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"
			  "-db2db"
                          "-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"))))
            (setenv "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 (setenv "MT_TARGET" targ)))

  ;; set the purpose field in procinf

  (procinf-purpose-set! *procinf* (get-purpose args:arg-hash))
  (procinf-mtversion-set! *procinf* megatest-version)

  ;; The watchdog is to keep an eye on things like db sync etc.
  ;;

  ;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
  ;;(define *watchdog* (make-thread
  ;;		    (lambda ()
  ;;		      (handle-exceptions
  ;;			  exn
  ;;			  (begin
  ;;			    (print-call-chain)
  ;;			    (print " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn))
  ;;			(common:watchdog)))
  ;;		    "Watchdog thread"))

  ;;(if (not (args:get-arg "-server"))
  ;;    (thread-start! *watchdog*)) ;; if starting a server; wait till we get to running state before kicking off watchdog
  (let* ((no-watchdog-args
	  '("-list-runs"
            "-testdata-csv"
            "-list-servers"
            "-server"
	    "-adjutant"
            "-list-disks"
            "-list-targets"
            "-show-runconfig"
            ;;"-list-db-targets"
            "-show-runconfig"
            "-show-config"
            "-show-cmdinfo"
	    "-cleanup-db"
            ))
	 (no-watchdog-argvals (list '("-archive" . "replicate-db")))
	 (start-watchdog-specail-arg-val (let loop ((hed  (car no-watchdog-argvals))
                                                    (tail (cdr   no-watchdog-argvals)))
                                           ;; (print "hed" hed " arg " (args:get-arg (car hed)) " val:" (cdr hed)  " eql" (equal? (args:get-arg (car hed)) (cdr hed)))  
                                           (if (equal? (args:get-arg (car hed)) (cdr hed))
                                               #f
                                               (if (null? tail)
                                                   #t
                                                   (loop (car tail) (cdr tail))))))      
	 (no-watchdog-args-vals (filter (lambda (x) x)
					(map args:get-arg no-watchdog-args)))
	 (start-watchdog (and (null? no-watchdog-args-vals) start-watchdog-specail-arg-val)))
					;(print  "no-watchdog-args="no-watchdog-args "no-watchdog-args-vals="no-watchdog-args-vals " start-watchdog-specail-arg-val:" start-watchdog-specail-arg-val " start-watchdog:" start-watchdog) 
    ;;  (if start-watchdog
    ;;      (thread-start! *watchdog*))
    #t
    )

  ;; stop the train watchdog
  (stop-the-train)

  ;; 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
      (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")(launch:setup)))   ;; run launch:setup if -server, ensure we do NOT run launch:setup if -log specified
	      (dbname (args:get-arg "-db"))   ;; for the server logfile name
	      (logf (or (args:get-arg "-log") ;; use -log unless we are a server, then craft a logfile name
			(conc tl "/logs/server-"(or dbname "unk")"-"(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)))

  (define *didsomething* #f)

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


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

  (on-exit std-exit-procedure)

  ;;======================================================================
  ;; Misc general calls
  ;;======================================================================

  (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/" (getenv "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)))

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

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

  (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")))
	(debug:print 0 *default-log-port* "NOT YET REIMPLEMENTED FOR TCP/INMEM") ;; bug
	(exit)))
  ;; (server:ping (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")
      (let* (;; (run-id     (args:get-arg "-run-id"))
	     (dbfname    (args:get-arg "-db"))
	     (tl         (launch:setup))
	     (keys       (keys:config-get-fields *configdat*)))
	(case (rmt:transport-mode)
	  ((tcp)
	   (let* ((timeout    (server:expiration-timeout)))
	     (debug:print 0 *default-log-port* "INFO: megatest -server starting on " (get-host-name) " for " dbfname " using tcp method with timeout of "timeout)
	     (tt-server-timeout-param timeout)
	     (api:queue-processor)
	     (thread-start! (make-thread api:print-db-stats "print-db-stats"))
	     (if dbfname
		 (tt:start-server tl #f dbfname api:tcp-dispatch-request-make-handler keys)
		 (begin
		   (debug:print 0 *default-log-port* "ERROR: transport mode is tcp - -db is required.")
		   (exit 1)))))
	  ((nfs)(debug:print 0 *default-log-port* "WARNING: server start called in nfs mode '"(rmt:transport-mode)))
	  (else (debug:print 0 *default-log-port* "ERROR: rmt:transport-mode value not recognised "(rmt:transport-mode))))
	(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 (args:get-arg "-list-servers")
      (let* ((tl (launch:setup)) ;; need this to initialize *toppath*
             (servdir (tt:get-servinfo-dir *toppath*))
             (servfiles (glob (conc servdir "/*:*.db")))
             (fmtstr  "~10a~22a~10a~25a~25a~8a\n")
             (dbfiles (append (glob (conc *toppath* "/.mtdb/main.db")) (glob (conc *toppath* "/.mtdb/?.db"))(glob (conc *toppath* "/.mtdb/??.db"))))
             (ttdat (make-tt areapath: *toppath*))
	     )
	(format #t fmtstr "DB" "host:port" "PID" "age" "last mod" "state")
	(for-each
         (lambda (dbfile)
           (let* (
		  (dbfname (conc (pathname-file dbfile) ".db"))
		  (sfiles   (tt:find-server *toppath* dbfname))
		  )
             (for-each 
              (lambda (sfile)
                (let (
                      (sinfos (tt:get-server-info-sorted ttdat dbfname))
                      )
                  (for-each 
                   (lambda (sinfo)
                     (let* (
                            (db (list-ref sinfo 5))
                            (pid (list-ref sinfo 4))
                            (host (list-ref sinfo 0))
                            (port (list-ref sinfo 1))
                            (server-id (list-ref sinfo 3))
                            (age (seconds->hr-min-sec (- (current-seconds) (list-ref sinfo 2))))
                            (last-mod (seconds->string (list-ref sinfo 2)))
                            (status (system (conc "ssh " host " ps " pid " > /dev/null")))
                            (state (if (> status 0)
                                       "dead"
                                       (tt:ping host port server-id 0)
                                       ))
                            )
                       (format #t fmtstr db (conc host ":" port) pid age last-mod state)
                       )
                     )
                   sinfos
                   )
                  ) 
		)
              sfiles
              )
             )
	   )
	 dbfiles
	 )
	(set! *didsomething* #t)
	(exit)  
	)
      )




  (if (args:get-arg "-kill-servers")
      
      (let* ((tl (launch:setup)) ;; need this to initialize *toppath*
             (servdir (tt:get-servinfo-dir *toppath*))
             (servfiles (glob (conc servdir "/*:*.db")))
             (fmtstr  "~10a~22a~10a~25a~25a~8a\n")
             (dbfiles (if (file-exists? (conc *toppath* "/.mtdb/main.db")) (append (glob (conc *toppath* "/.mtdb/main.db")) (glob (conc *toppath* "/.mtdb/?.db"))(glob (conc *toppath* "/.mtdb/??.db"))) '()))
             (ttdat (make-tt areapath: *toppath*))
	     )
	(format #t fmtstr "DB" "host:port" "PID" "age" "last mod" "state")
	(for-each
         (lambda (dbfile)
           (let* (
		  (dbfname (conc (pathname-file dbfile) ".db"))
		  (sfiles   (tt:find-server *toppath* dbfname))
		  )
             (for-each 
              (lambda (sfile)
                (let (
                      (sinfos (tt:get-server-info-sorted ttdat dbfname))
                      )
                  (for-each 
                   (lambda (sinfo)
                     (let* (
                            (db (list-ref sinfo 5))
                            (pid (list-ref sinfo 4))
                            (host (list-ref sinfo 0))
                            (port (list-ref sinfo 1))
                            (server-id (list-ref sinfo 3))
                            (age (seconds->hr-min-sec (- (current-seconds) (list-ref sinfo 2))))
                            (last-mod (seconds->string (list-ref sinfo 2)))
                            (killed (system (conc "ssh " host " kill " pid " > /dev/null")))
                            (dummy2 (sleep 1))
                            (state (if (> (system (conc "ssh " host " ps " pid " > /dev/null")) 0) "dead" "alive"))
                            )
                       (format #t fmtstr db (conc host ":" port) pid age last-mod state)
                       (system (conc "rm " sfile))
                       )
                     )
                   sinfos
                   )
                  ) 
		)
              sfiles
              )
             )
	   )
	 dbfiles
	 )
	;; remove this db, because otherwise metadata contains records for old servers, and this causes a problem with db:no-sync-get-lock-with-id.
	(if (file-exists? (conc *toppath* "/.mtdb/no-sync.db"))
	    (delete-file (conc *toppath* "/.mtdb/no-sync.db"))
	    )
	(set! *didsomething* #t)
	(exit)  
	)
      )

  ;;======================================================================
  ;; Weird special calls that need to run *after* the server has started?
  ;;======================================================================

  (if (args:get-arg "-list-targets")
      (if (launch:setup)
          (let ((targets (common:get-runconfig-targets)))
            ;; (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*)) ;; (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)
	(set! *time-to-exit* #t)))

  (if (args:get-arg "-show-cmdinfo")
      (if (or (args:get-arg ":value")(getenv "MT_CMDINFO"))
	  (let ((data (common:read-encoded-string (or (args:get-arg ":value")(getenv "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
	      (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)
    (set! *time-to-exit* #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* ((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 (args:get-arg "-dumpmode")
		     (not (member (args:get-arg "-dumpmode") '("sexpr" "json" "ods" "list"))))
		(begin
		  (debug:print 0 *default-log-port* "ERROR: dumpmode "(args:get-arg "-dumpmode")" not recognised. Use sexpr, json, ods or list")
		  (exit)))
	    (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"    )
			 ((#f list)
			  (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))))
			 (else
			  (debug:print 0 *default-log-port* "ERROR: dumpmode "(args:get-arg "-dumpmode")" not recognised. Use sexpr, json, ods or list")
			  ))
		       
		       (for-each 
			(lambda (test)
		      	  (common:debug-handle-exceptions #f
							  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) "/" (random 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)
            (set! *time-to-exit* #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)))
  
  ;;======================================================================
  ;; 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")
		      ;;     "%")
		      user
		      args:arg-hash
		      run-count: rerun-cnt)))

  ;; 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 found. 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))))
	(set! *didsomething* #t)))

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

  ;;======================================================================
  ;; 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 (getenv "MT_CMDINFO")
	  (let* ((startingdir (current-directory))
		 (cmdinfo   (common:read-encoded-string (getenv "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))))))

  ;;======================================================================
  ;; Utils for test areas
  ;;======================================================================

  (if (args:get-arg "-regen-testfiles")
      (if (getenv "MT_TEST_RUN_DIR")
	  (begin
	    (launch:setup)
	    (change-directory (getenv "MT_TEST_RUN_DIR"))
	    (let* ((testname (getenv "MT_TEST_NAME"))
		   (itempath (getenv "MT_ITEMPATH")))
	      (launch:extract-scripts-logpro (getenv "MT_TEST_RUN_DIR") testname itempath #f))
	    (set! *didsomething* #t))
	  (debug:print 0 *default-log-port* "ERROR: Must run -regen-testfiles in a test environment (i.e. test xterm from dashboard)")))
  
  ;;======================================================================
  ;; 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:make-tmpdir-name *toppath* "") (> (length (directory   (common:make-tmpdir-name *toppath* "") #f)) 0))
            (begin
              (debug:print-info 1 *default-log-port* (common:make-tmpdir-name *toppath* "") " 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
  ;;======================================================================

  (if (args:get-arg "-extract-ods")
      (general-run-call
       "-extract-ods"
       "Make ods spreadsheet"
       (lambda (target runname keys keyvals)
	 (let ((dbstruct   (make-dbr:dbstruct areapath: *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)))))))

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

  (define (megatest:step step state status logfile msg)
    (if (not (getenv "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 (getenv "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))))))

  (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 (getenv "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 (getenv "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

	    (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
  ;;======================================================================

  (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 ((dbstructs (db:setup)))
          (common:cleanup-db dbstructs 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)))

	;;      (if (not (server:choose-server *toppath* 'home?))
	;;	  (begin
	;;	    (debug:print 0 *default-log-port* "Servers are not running on this host or no servers alive. Cannot run cleanup-db")
	;;	    (exit 1)))

	(let ((dbstructs (db:setup)))
          (common:cleanup-db dbstructs))
	(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)))
	(open-run-close db:find-and-mark-incomplete #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 (getenv "MT_RUNSCRIPT")
	  (args:get-arg "-repl")
	  (args:get-arg "-load"))
      (let* ((toppath (launch:setup))
	     (dbstructs (if (and toppath
				 ;; NOTE: server:choose-server is starting a server
				 ;;   either add equivalent for tcp mode or ????
				 #;(server:choose-server toppath 'home?))
                            (db:setup)
                            #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f)))
	(if *toppath*
	    (cond
	     ((getenv "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* dbstructs)
		(import extras) ;; might not be needed
		;; (import csi)
		(import readline)
		(import apropos)
		(import dbfile)
		;; (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)))

  (if (args:get-arg "-import-megatest.db")
      (begin
	(launch:setup)
	(db:multi-db-sync 
	 (db:setup)
	 'killservers
	 'dejunk
	 'adj-testids
	 'old2new
	 )
	(set! *didsomething* #t)))

  (if (args:get-arg "-import-sexpr")
      (let*(
	    (toppath (launch:setup))
	    (tmppath (common:make-tmpdir-name toppath "")))
	(if (file-exists? (conc toppath "/.mtdb")) 
	    (if (args:get-arg "-remove-dbs")
		(let* ((dbfiles (conc toppath "/.mtdb/* " tmppath "/*")))
		  (debug:print 0 *default-log-port* "Removing db files: " dbfiles)
		  (system (conc "rm -rvf " dbfiles))
		  )
		(begin
		  (debug:print 0 *default-log-port* "ERROR: Cannot import sexpr with an existing DB present.")
		  (debug:print 0 *default-log-port* "Add '-remove-dbs all'  to remove the current Megatest DBs.")
		  (set! *didsomething* #t)
		  (exit)
		  )
		)
	    (debug:print 0 *default-log-port* "Did not find " (conc toppath "/.mtdb"))
	    )
	(db:setup)
	(rmt:import-sexpr (args:get-arg "-import-sexpr"))
	(set! *didsomething* #t)))

  (if (args:get-arg "-sync-to-megatest.db")
      (let* ((duh      (launch:setup))
	     (dbstruct (db:setup))
	     (tmpdbpth (dbr:dbstruct-tmppath 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)
	      (debug:print 0 *default-log-port* "Synced " res " records to megatest.db"))
	    (debug:print 0 *default-log-port* "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)))


  ;; use with -from and -to
  ;;
  (if (args:get-arg "-db2db")
      (let* ((duh         (launch:setup))
	     (src-db      (args:get-arg "-from"))
	     (dest-db     (args:get-arg "-to"))
	     ;; (sync-period (args:get-arg-number "-period"))
	     ;; (sync-timeout (args:get-arg-number "-timeout"))
	     (sync-period-in  (args:get-arg "-period"))
	     (sync-timeout-in (args:get-arg "-timeout"))
	     (sync-period     (if sync-period-in (string->number sync-period-in) #f))
	     (sync-timeout    (if sync-timeout-in (string->number sync-timeout-in) #f))
	     (lockfile    (conc dest-db".sync-lock"))
	     (keys        (db:get-keys #f))
	     (thesync     (lambda (last-update)
			    (debug:print-info 0 *default-log-port* "Attempting to sync data from "src-db" to "dest-db"...")
			    (debug:print-info 0 *default-log-port* "PID = " (current-process-id))
			    (if (not (file-exists? dest-db))
				(begin
				  (debug:print 0 *default-log-port* "Using copy to create "dest-db" from "src-db)
				  (file-copy src-db dest-db)
				  1)
				(let ((res (dbmod:db-to-db-sync src-db dest-db last-update (dbfile:db-init-proc) keys)))
				  (if res
				      (debug:print-info 2 *default-log-port* "Synced " res " records from "src-db" to "dest-db)
				      (debug:print-info 0 *default-log-port* "No sync due to permissions or other issue."))
				  res))))
	     (start-time  (current-seconds))
             (synclock-mod-time (if (file-exists? lockfile)
				    (handle-exceptions
				     exn
				     #f
				     (file-modification-time synclock-file))
				    #f))
             (age (if synclock-mod-time (- (current-seconds) synclock-mod-time) 1000))
             )
	(if (and src-db dest-db)
	    (if (file-exists? src-db)
		(if (and (file-exists? lockfile) (< age 20))
		    (debug:print 0 *default-log-port* "Lock "lockfile" exists, skipping sync...")
                    (begin
                      (if (file-exists? lockfile)
			  (begin
			    (debug:print 0 *default-log-port* "Deleting old lock file " lockfile)
			    (delete-file lockfile)
			    )
			  )
		      (dbfile:with-simple-file-lock
		       lockfile
		       (lambda ()
			 (let loop ((last-changed (current-seconds))
				    (last-update  0))
			   (let* ((changes (handle-exceptions
					    exn
					    (begin
					      (debug:print 0 *default-log-port* "Exception in sync: "(condition->list exn))
					      (delete-file lockfile)
					      (exit))
					    (thesync last-update)))
				  (now-time (current-seconds)))
			     (if (and sync-period sync-timeout) ;; 
				 (if (and (< (- now-time start-time) 600) ;; hard limit on how long we run for
					  (>  sync-timeout (- now-time last-changed)))
				     (begin
				       (if sync-period (thread-sleep! sync-period))
				       (loop (if (> changes 0) now-time last-changed) now-time))))))))
                      (debug:print 0 *default-log-port* "Releasing lock file " lockfile)
                      )
		    )
		(debug:print 0 *default-log-port* "No sync due to unreadble or non-existant source file"src-db))
	    (debug:print 0 *default-log-port* "Usage for -db2db; -to and -from must be specified"))
	(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
			 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)
      (set! *time-to-exit* #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
  ;;(if (thread? *watchdog*)
  ;;    (case (thread-state *watchdog*)
  ;;      ((ready running blocked sleeping terminated dead)
  ;;       (thread-join! *watchdog*))))

  (set! *time-to-exit* #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)))))
  ) ;; main
)

(declare (uses debugprint))
(declare (uses commonmod))

(use srfi-69)

(module processmod
	(
	 process:children

	 process:cmd-run->list
	 process:alive?
	 run-n-wait
	 process:cmd-run-with-stderr-and-exitcode->list

	 process:alive-on-host?
	 process:get-sub-pids

(declare (uses archivemod))
(declare (uses fsmod))

(use srfi-69)

(module runsmod
	(
	 runs:clean-cache
	 rmt:find-and-mark-incomplete
	 launch:setup
	 launch:end-of-run-check
	 launch:test-copy

	 set-item-env-vars
	 runs:set-megatest-env-vars

(declare (uses mtargs))

(module servermod
	(
	 remote-hh-dat
	 server:mk-signature
	 common:wait-for-normalized-load
	 server:expiration-timeout
	 )

(import scheme
	chicken)
	
(use (srfi 18) extras s11n)
(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)

(declare (uses portlogger))
(declare (uses mtmod))

(use address-info tcp)

(module tcp-transportmod
	(
	 make-tt
	 tt:start-server
	 tt:get-servinfo-dir
	 tt-server-timeout-param
	 tt:mk-signature
	 tt-state
	 tt:server-process-run
	 tt:make-remote
	 tt-ro-mode-checked-set!
	 tt-ro-mode-set!
	 tt-ro-mode