Megatest

	fossil timeline -n 350 -t ci -F "%h,%a,%b,%t,\"%c\"" > recent-commits.csv


SHELL=/bin/bash
PREFIX=$(PWD)
CSCOPTS=
INSTALL=install
SRCFILES = launch.scm runconfig.scm	\
           server.scm configf.scm keys.scm		\
           process.scm runs.scm \
           mt.scm	\
           ezsteps.scm api.scm		\
           subrun.scm archive.scm env.scm


# cgisetup/models/pgdb.scm

# 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 genexample.scm mutils.scm \
            diff-report.scm tdb.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 mofiles/genexample.o mofiles/mutils.o mofiles/diff-report.o mofiles/tdb.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 debugprint))
(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)
(import dbmod)
(import dbfile)

;;

;;  strftime('%m/%d/%Y %H:%M:%S','now','localtime')

(declare (unit archive))
(declare (uses debugprint))
(declare (uses mtargs))
;; (declare (uses common))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses rmtmod))

(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69
     format md5 message-digest srfi-18)

(declare (uses mtmod))
(declare (uses dbmod))
(declare (uses dbfile))

(use srfi-69)

(module archivemod
	(
	 archive:get-archive-disks
	 archive:allocate-new-archive-block
	 archive:get-timestamp-dir
	 archive:megatest-db
	 archive:bup-get-data
	 archive:restore-db

	 )

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

	srfi-13
	srfi-18
	srfi-69
	typed-records
	z3
	)
	
;; (include "common_records.scm")
;; (include "db_records.scm")

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

;; ;; NOT CURRENTLY USED

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

;; gotta compile with csc, doesn't work with csi -s for whatever reason

(use srfi-69)
(use matchable)
(use utils)
(use ports)
(use extras)
(use srfi-1)
(use posix)
(use srfi-12)

;; turn scheme file to a list of sexps, sexps of interest will be in the form of (define (<procname> <args>) <body> )
(define (load-scm-file scm-file)
  ;;(print "load "scm-file)
  (handle-exceptions
   exn
   '()
   (with-input-from-string
       (conc "("
             (with-input-from-file scm-file read-all)
             ")" )
     read)))

;; extract a list of procname, filename, args and body of procedures defined in filename, input from load-scm-file
;;   -- be advised:
;;      * this may be fooled by macros, since this code does not take them into account.
;;      * this code does only checks for form (define (<procname> ... ) <body>)
;;           so it excludes from reckoning
;;               - generated functions, as in things like foo-set! from defstructs,
;;               - define-inline, (
;;               - define procname (lambda ..
;;               - etc...
(define (get-toplevel-procs+file+args+body filename)
  (let* ((scm-tree (load-scm-file filename))
         (procs
          (filter identity
                  (map
                   (match-lambda 
                    [('define ('uses args ...) body ...) #f] ;; filter out (define (uses ...
                    [('define ('unit args ...) body ...) #f] ;; filter out (define (unit ...
                    [('define ('prefix args ...) body ...) #f] ;; filter out (define (prefix ...
                    [('define (defname args ...) body ...) ;; match (define (procname <args>) <body>)
                     (if (atom? defname) ;; filter out things we dont understand (procname is a list, what??)
                         (list defname filename args body)
                         #f)]
                    [else #f] ) scm-tree))))
    procs))


;; given a sexp, return a flat list of atoms in that sexp
(define (get-atoms-in-body body)
  (cond
   ((null? body) '())
   ((atom? body) (list body))
   (else
    (apply append (map get-atoms-in-body body)))))

;;  given a file, return a list of procname, file, list of atoms in said procname
(define (get-procs+file+atoms file)
  (let* ((toplevel-proc-items (get-toplevel-procs+file+args+body file))
         (res
          (map
           (lambda (item)
             (let* ((proc (car item))
                    (file (cadr item))
                    (args (caddr item))
                    (body (cadddr item))
                    (atoms (append (get-atoms-in-body args) (get-atoms-in-body body))))
               (list proc file atoms)))
           toplevel-proc-items)))
    res))

;; uniquify a list of atoms 
(define (unique-atoms lst)
  (let loop ((lst (flatten lst)) (res '()))
    (if (null? lst)
        (reverse res)
        (let ((c (car lst)))
          (loop (cdr lst) (if (member c res) res (cons c res)))))))

;; given a list of procname, filename, list of procs called from procname, cross reference and reverse
;; returning alist mapping procname to procname that calls said procname
(define (get-callers-alist all-procs+file+calls)
  (let* ((all-procs (map car all-procs+file+calls))
         (caller-ht (make-hash-table))) 
    ;; let's cross reference with a hash table
    (for-each (lambda (proc) (hash-table-set! caller-ht proc '())) all-procs)
    (for-each (lambda (item)
               (let* ((proc (car item))
                      (file (cadr item))
                      (calls (caddr item)))
                 (for-each (lambda (callee)
                             (hash-table-set! caller-ht callee
                                              (cons proc
                                                    (hash-table-ref caller-ht callee))))
                           calls)))
              all-procs+file+calls)
    (map (lambda (x)
           (let ((k (car x))
                 (r (unique-atoms (cdr x))))
             (cons k r)))                    
         (hash-table->alist caller-ht))))

;; create a handy cross-reference of callees to callers in the form of an alist.
(define (get-xref all-scm-files)
  (let* ((all-procs+file+atoms
          (apply append (map get-procs+file+atoms all-scm-files)))
         (all-procs (map car all-procs+file+atoms))
         (all-procs+file+calls  ; proc calls things in calls list
          (map (lambda (item)
                 (let* ((proc (car item))
                        (file (cadr item))
                        (atoms (caddr item))
                        (calls
                         (filter identity
                                 (map
                                  (lambda (x)
                                    (if (and ;; (not (equal? x proc))  ;; uncomment to prevent listing self
                                         (member x all-procs))
                                        x
                                        #f))
                                  atoms))))
                   (list proc file calls)))
               all-procs+file+atoms))
         (callers (get-callers-alist all-procs+file+calls))) 
    callers))

     typed-records
     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

	 common:get-intercept
	 common:get-num-cpus
	 common:get-cpu-load
	 common:hms-string->seconds
	 seconds->time-string
	 common:get-megatest-exe

	 megatest-version
	 common:get-toppath
	 common:generic-ssh
	 common:file-exists?
	 common:with-env-vars
	 common:nice-path
	 common:get-fields

	 common:get-normalized-cpu-load
	 common:unix-ping
	 common:get-normalized-cpu-load
	 common:raw-get-remote-host-load
	 common:to-alist

	 ;; globals
	 *common:badly-ended-states*
	 *common:dont-roll-up-states*
	 *common:ended-states*
	 *common:not-started-ok-statuses*
	 *common:running-states*
	 *common:std-states*
	 *common:std-statuses*
	 *common:well-ended-states*
	 *configdat*
	 *configinfo*
	 *db-access-allowed*
	 *db-api-call-time*
	 *db-cache-path*
	 *db-keys*
	 *default-area-tag*
	 *host-loads*
	 *keyvals*
	 *logged-in-clients*
	 *my-client-signature*
	 *on-exit-procs*
	 *pkts-info*
	 *pre-reqs-met-cache*
	 *runremote*
	 *server-id*
	 *server-info*
	 *target*
	 *task-db*
	 *testconfigs*
	 *time-to-exit*
	 *toppath*
	 *transport-type*
	 
	 any->number-if-possible

	 common:special-sort
	 keys:target-set-args

	 getenv
	 setenv
	 safe-setenv

	 commonmod:get-cpu-load

	 get-area-path-signature
	 common:simple-file-lock
	 common:low-noise-print
	 common:get-create-writeable-dir
	 common:real-path
	 val->alist

	 client:get-signature

	 common:get-color-from-status
	 
	 seconds->year-work-week/day-time
	 common:simple-file-release-lock
	 common:simple-file-lock-and-wait
	 tests:lookup-itemmap

	 tests:match->sqlqry
	 runs:get-std-run-fields
	 common:min-max
	 common:max
	 common:sum
	 keys:target->keyval
	 db:patt->like

	 rmt:transport-mode
	 common:version-signature

	 keys->keystr
	 keys:config-get-fields
	 common:make-tmpdir-name

	 db:test-get-status
	 db:test-get-state
	 db:test-get-event_time
	 db:test-get-item-path
	 db:test-get-testname
	 db:test-get-id
	 db:test-get-comment
	 db:test-get-run_duration
	 db:test-get-rundir

	 tests:match
	 patt-list-match
	 common:pkts-spec

	 sdb:qry
	 seconds->work-week/day-time

	 tdb:step-get-comment
	 seconds->hr-min-sec
	 any->number
	 tdb:step-get-logfile
	 tdb:step-get-event_time
	 tdb:step-get-status
	 tdb:step-get-state
	 tdb:step-get-id
	 tdb:step-get-stepname
	 db:test-make-full-name
	 common:htree->html
	 common:list->htree

	 tdb:steps-table-get-log-file
	 tdb:steps-table-get-runtime
	 tdb:steps-table-get-status
	 tdb:steps-table-get-end
	 tdb:steps-table-get-start
	 tdb:steps-table-get-stepname
	 tdb:step-get-last_update
	 tdb:step-get-test_id

	 db:test-get-run_id
	 db:test-get-final_logf

	 tests:testqueue-get-item_path
	 tests:testqueue-get-itemdat
	 tests:testqueue-get-testname
	 tests:testqueue-get-priority
	 tests:testqueue-set-priority!
	 tests:testqueue-get-testconfig
	 tests:testqueue-get-waitons

	 tasks:wait-on-journal
	 common:get-area-path-signature

	 db:test-get-last_update
	 db:test-get-archived
	 db:test-get-uname
	 db:test-get-diskfree
	 db:test-get-cpuload
	 db:test-get-process_id
	 db:test-get-host
	 db:test-data-get-last_update
	 db:test-data-get-type
	 db:test-data-get-status
	 db:test-data-get-comment
	 db:test-data-get-units
	 db:test-data-get-tol
	 db:test-data-get-expected
	 db:test-data-get-value
	 db:test-data-get-variable
	 db:test-data-get-category
	 db:test-data-get-test_id
	 db:test-data-get-id

	 host-last-cpuload
	 host-last-update
	 host-last-cpuload-set!
	 host-last-update-set!
	 host-reachable-set!
	 make-host
	 host-last-used-set!
	 host-reachable
	 host-last-used

	 common:alist-ref/default
	 common:val->alist
	 common:in-running-test?
	 
	 common:without-vars
	 common:get-megatest-exe-path
	 common:get-megatest-exe-dir
	 common:get-param-mapping
	 common:get-mtexe
	 
	 db:test-get-is-toplevel
	 seconds->quarter
	 *globalexitstatus*

	 tests:testqueue-set-items!
	 tests:testqueue-get-items
	 *runconfigdat*
	 *passnum*
	 *already-seen-runconfig-info*
	 common:directory-writable?
	 common:dir-clean-up
	 common:fail-safe
	 common:list-or-null
	 *toptest-paths*
	 common:directory-exists?
	 *configstatus*
	 *last-launch*
	 *launch-setup-mutex*
	 commonmod:is-test-alive
	 alist->env-vars
	 *env-vars-by-run-id*
	 common:get-signature
	 common:join-backgrounded-threads
	 tests:glob-like-match
	 common:send-thunk-to-background-thread
	 db:test-get-fullname
	 common:clear-caches
	 db:mintest-get-event_time
	 *test-meta-updated*
	 tests:testqueue-set-item_path!
	 tests:testqueue-set-itemdat!
	 make-tests:testqueue

	 megatest-fossil-hash

	 common:steps-can-proceed-given-status-sym
	 status-sym->string
	 common:worse-status-sym
	 common:logpro-exit-code->status-sym

	 save-environment-as-files
	 assoc/default
	 common:read-encoded-string
	 common:which

	 stop-the-train
	 )
	
(import scheme)
(cond-expand
 (chicken-4
  
  (import chicken
	  ports
	  (prefix base64 base64:)

	  srfi-1
	  srfi-18
	  srfi-69
	  typed-records
	  system-information

	  debugprint
	  megatest-fossil-hash
	  
  )))

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

(define *fdb* #f)

(define *last-launch* (current-seconds)) ;; use for throttling the launch rate. Would be better to use the db and last time of a test in LAUNCHED state.

;; environment vars handy stuff from common.scm
;;
(define getenv get-environment-variable)

(define (safe-setenv key val)
  (if (or (substring-index "!" key)
	  (substring-index ":" key)  ;; variables containing : are for internal use and cannot be environment variables.
	  (substring-index "." key)) ;; periods are not allowed in environment variables
      (debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\" or starting with \"!\"")
      (if (and (string? val)
	       (string? key))

  ;; convert string a=1; b=2; c=a silly thing; d=
  (let ((valstr (lookup cfgdat section var)))
    (if valstr
	(val->alist valstr)
	'()))) ;; should it return empty list or #f to indicate not set?





(define (common:make-tmpdir-name areapath tmpadj)
  (let* ((area (pathname-file areapath))
         (dname (conc "/tmp/"(current-user-name)"/megatest_localdb/" area "/" (string-translate areapath "/" ".") tmpadj "/.mtdb")))
    (unless (directory-exists? dname)
      (create-directory dname #t))
    dname))

(define (common:get-fields cfgdat)
  (let ((fields (hash-table-ref/default cfgdat "fields" '())))
    (map car fields)))

(define keys:config-get-fields common:get-fields)

;;======================================================================
;; db_records.scm
;;======================================================================

;;======================================================================
;; dbstruct
;;======================================================================

(define (make-db:test)(make-vector 20))
(define (db:test-get-id           vec) (vector-ref vec 0))
(define (db:test-get-run_id       vec) (vector-ref vec 1))
(define (db:test-get-testname     vec) (vector-ref vec 2))
(define (db:test-get-state        vec) (vector-ref vec 3))
(define (db:test-get-status       vec) (vector-ref vec 4))
(define (db:test-get-event_time   vec) (vector-ref vec 5))
(define (db:test-get-host         vec) (vector-ref vec 6))
(define (db:test-get-cpuload      vec) (vector-ref vec 7))
(define (db:test-get-diskfree     vec) (vector-ref vec 8))
(define (db:test-get-uname        vec) (vector-ref vec 9))
;; (define (db:test-get-rundir       vec) (sdb:qry 'getstr (vector-ref vec 10)))
(define (db:test-get-rundir       vec) (vector-ref vec 10))
(define (db:test-get-item-path    vec) (vector-ref vec 11))
(define (db:test-get-run_duration vec) (vector-ref vec 12))
(define (db:test-get-final_logf   vec) (vector-ref vec 13))
(define (db:test-get-comment      vec) (vector-ref vec 14))
(define (db:test-get-process_id   vec) (vector-ref vec 16))
(define (db:test-get-archived     vec) (vector-ref vec 17))
(define (db:test-get-last_update     vec) (vector-ref vec 18))

;; (define (db:test-get-pass_count   vec) (vector-ref vec 15))
;; (define (db:test-get-fail_count   vec) (vector-ref vec 16))
(define (db:test-get-fullname     vec)
  (conc (db:test-get-testname vec) "/" (db:test-get-item-path vec)))

;; replace runs:make-full-test-name with this routine
(define (db:test-make-full-name testname itempath)
  (if (equal? itempath "") testname (conc testname "/" itempath)))

;; (define (db:test-get-first_err    vec) (printable (vector-ref vec 15)))
;; (define (db:test-get-first_warn   vec) (printable (vector-ref vec 16))) ;; RADT => reference 16 is repeated

(define (db:test-set-cpuload!  vec val)(vector-set! vec 7 val))
(define (db:test-set-diskfree! vec val)(vector-set! vec 8 val))
(define (db:test-set-testname! vec val)(vector-set! vec 2 val))
(define (db:test-set-state!    vec val)(vector-set! vec 3 val))
(define (db:test-set-status!   vec val)(vector-set! vec 4 val))
(define (db:test-set-run_duration! vec val)(vector-set! vec 12 val))
(define (db:test-set-final_logf! vec val)(vector-set! vec 13 val))

;; Test record utility functions

;; Is a test a toplevel?
;;
(define (db:test-get-is-toplevel vec)
  (and (equal? (db:test-get-item-path vec) "")      ;; test is not an item
       (equal? (db:test-get-uname vec)     "n/a"))) ;; test has never been run

;; make-vector-record "" db mintest id run_id testname state status event_time item_path
;; RADT => purpose of mintest??
;;
(define (make-db:mintest)(make-vector 7))
(define (db:mintest-get-id           vec)    (vector-ref  vec 0))
(define (db:mintest-get-run_id       vec)    (vector-ref  vec 1))
(define (db:mintest-get-testname     vec)    (vector-ref  vec 2))
(define (db:mintest-get-state        vec)    (vector-ref  vec 3))
(define (db:mintest-get-status       vec)    (vector-ref  vec 4))
(define (db:mintest-get-event_time   vec)    (vector-ref  vec 5))
(define (db:mintest-get-item_path    vec)    (vector-ref  vec 6))

;; make-vector-record db testmeta id testname author owner description reviewed iterated avg_runtime avg_disk
(define (make-db:testmeta)(make-vector 10 ""))
(define (db:testmeta-get-id            vec)    (vector-ref  vec 0))
(define (db:testmeta-get-testname      vec)    (vector-ref  vec 1))
(define (db:testmeta-get-author        vec)    (vector-ref  vec 2))
(define (db:testmeta-get-owner         vec)    (vector-ref  vec 3))
(define (db:testmeta-get-description   vec)    (vector-ref  vec 4))
(define (db:testmeta-get-reviewed      vec)    (vector-ref  vec 5))
(define (db:testmeta-get-iterated      vec)    (vector-ref  vec 6))
(define (db:testmeta-get-avg_runtime   vec)    (vector-ref  vec 7))
(define (db:testmeta-get-avg_disk      vec)    (vector-ref  vec 8))
(define (db:testmeta-get-tags          vec)    (vector-ref  vec 9))
(define (db:testmeta-set-id!           vec val)(vector-set! vec 0 val))
(define (db:testmeta-set-testname!     vec val)(vector-set! vec 1 val))
(define (db:testmeta-set-author!       vec val)(vector-set! vec 2 val))
(define (db:testmeta-set-owner!        vec val)(vector-set! vec 3 val))
(define (db:testmeta-set-description!  vec val)(vector-set! vec 4 val))
(define (db:testmeta-set-reviewed!     vec val)(vector-set! vec 5 val))
(define (db:testmeta-set-iterated!     vec val)(vector-set! vec 6 val))
(define (db:testmeta-set-avg_runtime!  vec val)(vector-set! vec 7 val))
(define (db:testmeta-set-avg_disk!     vec val)(vector-set! vec 8 val))

;;======================================================================
;; S I M P L E   R U N
;;======================================================================

;; (defstruct id  "runname" "state" "status" "owner" "event_time"

;;======================================================================
;; T E S T   D A T A 
;;======================================================================
(define (make-db:test-data)(make-vector 10))
(define (db:test-data-get-id               vec)    (vector-ref  vec 0))
(define (db:test-data-get-test_id          vec)    (vector-ref  vec 1))
(define (db:test-data-get-category         vec)    (vector-ref  vec 2))
(define (db:test-data-get-variable         vec)    (vector-ref  vec 3))
(define (db:test-data-get-value            vec)    (vector-ref  vec 4))
(define (db:test-data-get-expected         vec)    (vector-ref  vec 5))
(define (db:test-data-get-tol              vec)    (vector-ref  vec 6))
(define (db:test-data-get-units            vec)    (vector-ref  vec 7))
(define (db:test-data-get-comment          vec)    (vector-ref  vec 8))
(define (db:test-data-get-status           vec)    (vector-ref  vec 9))
(define (db:test-data-get-type             vec)    (vector-ref  vec 10))
(define (db:test-data-get-last_update      vec)    (vector-ref  vec 11))

(define (db:test-data-set-id!              vec val)(vector-set!  vec 0  val))
(define (db:test-data-set-test_id!         vec val)(vector-set!  vec 1  val))
(define (db:test-data-set-category!        vec val)(vector-set!  vec 2  val))
(define (db:test-data-set-variable!        vec val)(vector-set!  vec 3  val))
(define (db:test-data-set-value!           vec val)(vector-set!  vec 4  val))
(define (db:test-data-set-expected!        vec val)(vector-set!  vec 5  val))
(define (db:test-data-set-tol!             vec val)(vector-set!  vec 6  val))
(define (db:test-data-set-units!           vec val)(vector-set!  vec 7  val))
(define (db:test-data-set-comment!         vec val)(vector-set!  vec 8  val))
(define (db:test-data-set-status!          vec val)(vector-set!  vec 9  val))
(define (db:test-data-set-type!            vec val)(vector-set!  vec 10 val))

;;======================================================================
;; S T E P S 
;;======================================================================
;; Run steps
;; make-vector-record "Run steps" db step id test_id stepname step_complete step_pass event_time    
(define (make-db:step)(make-vector 9))
(define (tdb:step-get-id              vec)    (vector-ref  vec 0))
(define (tdb:step-get-test_id         vec)    (vector-ref  vec 1))
(define (tdb:step-get-stepname        vec)    (vector-ref  vec 2))
(define (tdb:step-get-state           vec)    (vector-ref  vec 3))
(define (tdb:step-get-status          vec)    (vector-ref  vec 4))
(define (tdb:step-get-event_time      vec)    (vector-ref  vec 5))
(define (tdb:step-get-logfile         vec)    (vector-ref  vec 6))
(define (tdb:step-get-comment         vec)    (vector-ref  vec 7))
(define (tdb:step-get-last_update     vec)    (vector-ref  vec 8))
(define (tdb:step-set-id!             vec val)(vector-set! vec 0 val))
(define (tdb:step-set-test_id!        vec val)(vector-set! vec 1 val))
(define (tdb:step-set-stepname!       vec val)(vector-set! vec 2 val))
(define (tdb:step-set-state!          vec val)(vector-set! vec 3 val))
(define (tdb:step-set-status!         vec val)(vector-set! vec 4 val))
(define (tdb:step-set-event_time!     vec val)(vector-set! vec 5 val))
(define (tdb:step-set-logfile!        vec val)(vector-set! vec 6 val))
(define (tdb:step-set-comment!        vec val)(vector-set! vec 7 val))


;; The steps table
(define (make-db:steps-table)(make-vector 5))
(define (tdb:steps-table-get-stepname   vec)    (vector-ref  vec 0))
(define (tdb:steps-table-get-start      vec)    (vector-ref  vec 1))
(define (tdb:steps-table-get-end        vec)    (vector-ref  vec 2))
(define (tdb:steps-table-get-status     vec)    (vector-ref  vec 3))
(define (tdb:steps-table-get-runtime    vec)    (vector-ref  vec 4))
(define (tdb:steps-table-get-log-file   vec)    (vector-ref  vec 5))

(define (tdb:step-stable-set-stepname!  vec val)(vector-set! vec 0 val))
(define (tdb:step-stable-set-start!     vec val)(vector-set! vec 1 val))
(define (tdb:step-stable-set-end!       vec val)(vector-set! vec 2 val))
(define (tdb:step-stable-set-status!    vec val)(vector-set! vec 3 val))
(define (tdb:step-stable-set-runtime!   vec val)(vector-set! vec 4 val))

;; ;; The data structure for handing off requests via wire
;; (define (make-cdb:packet)(make-vector 6))
;; (define (cdb:packet-get-client-sig   vec)    (vector-ref  vec 0))
;; (define (cdb:packet-get-qtype        vec)    (vector-ref  vec 1))
;; (define (cdb:packet-get-immediate    vec)    (vector-ref  vec 2))
;; (define (cdb:packet-get-query-sig    vec)    (vector-ref  vec 3))
;; (define (cdb:packet-get-params       vec)    (vector-ref  vec 4))
;; (define (cdb:packet-get-qtime        vec)    (vector-ref  vec 5))
;; (define (cdb:packet-set-client-sig!  vec val)(vector-set! vec 0 val))
;; (define (cdb:packet-set-qtype!       vec val)(vector-set! vec 1 val))
;; (define (cdb:packet-set-immediate!   vec val)(vector-set! vec 2 val))
;; (define (cdb:packet-set-query-sig!   vec val)(vector-set! vec 3 val))
;; (define (cdb:packet-set-params!      vec val)(vector-set! vec 4 val))
;; (define (cdb:packet-set-qtime!       vec val)(vector-set! vec 5 val))

;;======================================================================
;; key_records
;;======================================================================

(define (keys->valslots keys) ;; => ?,?,? ....
  (string-intersperse (map (lambda (x) "?") keys) ","))

;; (define (keys->key/field keys . additional)
;;   (string-join (map (lambda (k)(conc k " TEXT"))
;; 		    (append keys additional)) ","))

(define (item-list->path itemdat)
  (if (list? itemdat)
      (string-intersperse  (map cadr itemdat) "/")
      ""))


;;======================================================================
;; test_records
;;======================================================================

;; make-vector-record tests testqueue testname testconfig waitons priority items
(define (make-tests:testqueue)(make-vector 7 #f))
(define (tests:testqueue-get-testname     vec)    (vector-ref  vec 0))
(define (tests:testqueue-get-testconfig   vec)    (vector-ref  vec 1))
(define (tests:testqueue-get-waitons      vec)    (vector-ref  vec 2))
(define (tests:testqueue-get-priority     vec)    (vector-ref  vec 3))
;; items: #f=no items, list=list of items remaining, proc=need to call to get items
(define (tests:testqueue-get-items        vec)    (vector-ref  vec 4))
(define (tests:testqueue-get-itemdat      vec)    (vector-ref  vec 5))
(define (tests:testqueue-get-item_path    vec)    (vector-ref  vec 6))

(define (tests:testqueue-set-testname!    vec val)(vector-set! vec 0 val))
(define (tests:testqueue-set-testconfig!  vec val)(vector-set! vec 1 val))
(define (tests:testqueue-set-waitons!     vec val)(vector-set! vec 2 val))
(define (tests:testqueue-set-priority!    vec val)(vector-set! vec 3 val))
(define (tests:testqueue-set-items!       vec val)(vector-set! vec 4 val))
(define (tests:testqueue-set-itemdat!     vec val)(vector-set! vec 5 val))
(define (tests:testqueue-set-item_path!   vec val)(vector-set! vec 6 val))


)

(declare (unit configf))
(declare (uses process))
(declare (uses env))
(declare (uses keys))
(declare (uses debugprint))
(declare (uses mtargs))
(declare (uses mtargs.import))
;; (declare (uses common))
(declare (uses commonmod))
(declare (uses commonmod.import))
(declare (uses processmod))
(declare (uses processmod.import))
(declare (uses configfmod))
(declare (uses configfmod.import))
(declare (uses dbfile))

(declare (uses commonmod))
(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
	 configf:section-vars
	 configf:read-alist
	 configf:config->alist
	 configf:alist->config
	 configf:set-section-var

	 find-and-read-config
	 common:args-get-target
	 configf:eval-string-in-environment

	 read-config-set!
	 configf:read-file

	 configf:system
	 configf:config->ini
	 shell
	)

(import scheme
        chicken
	extras
	files
	matchable
	ports

	    #f
	    (let ((match (assoc var sectdat)))
	      (if match ;; (and match (list? match)(> (length match) 1))
		  (cadr match)
		  #f))
	    ))
      #f))

(define lookup configf:lookup)

;; use to have definitive setting:
;;  [foo]
;;  var yes
;;
;;  (configf:var-is? cfgdat "foo" "var" "yes") => #t
;;

  (let ((sectdat (hash-table-ref/default cfgdat section '())))
    (if (null? sectdat)
	'()
	(map car sectdat))))

(define (configf:get-section cfgdat section)
  (hash-table-ref/default cfgdat section '()))

(define get-section configf:get-section)

(define (configf:set-section-var cfgdat section var val)
  (let ((sectdat (configf:get-section cfgdat section)))
    (hash-table-set! cfgdat section
                     (configf:assoc-safe-add sectdat var val))))

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

	    target)
	(if target
	    (begin
	      (debug:print-error 0 *default-log-port* "Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements")
	      (if exit-if-bad (exit 1))
	      #f)
	    #f))))




(include "configf-guts.scm")

)

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

(use srfi-69)

(module cpumod
	()
       

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

;;======================================================================
;; implementation of context menu that pops up on
;; right click on test cell in Runs & Runs Summary Tabs
;;======================================================================

(declare (unit dashboard-context-menu))
;; (declare (uses common))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses gutils))
(declare (uses rmtmod))
(declare (uses ezsteps))
;; (declare (uses sdb))
;; (declare (uses filedb))

(import (prefix iup iup:))

(use canvas-draw)

(use srfi-1 posix regex regex-case srfi-69)
(use (prefix sqlite3 sqlite3:))

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

(import commonmod
	configfmod
	rmtmod
	testsmod

(use canvas-draw)

(use sqlite3 srfi-1 posix regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:))

(declare (unit dashboard-guimonitor))
;; (declare (uses common))
(declare (uses keys))
(declare (uses commonmod))
(import commonmod)

;; (include "common_records.scm")
;; (include "db_records.scm")
(include "run_records.scm")
(include "task_records.scm")

(define (control-panel db tdb keys)
  (let* ((var-params (make-hash-table)) ;; register all the widgets here for querying on run, rollup, remove?
	 (key-params (make-hash-table))

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

;;======================================================================
;; Test info panel
;;======================================================================

(declare (unit dashboard-tests))
;; (declare (uses common))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses debugprint))
(declare (uses rmtmod))
(declare (uses megatestmod))
(declare (uses dbmod))
(declare (uses dbfile))

	dbfile
	tasksmod
	testsmod
	runsmod
	subrunmod
	)

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

;;======================================================================
;; C O M M O N
;;======================================================================

(declare (uses archivemod.import))
(declare (uses runsmod))
(declare (uses runsmod.import))
(declare (uses launchmod))
(declare (uses launchmod.import))

(declare (uses configf))
;; (declare (uses common))
(declare (uses keys))

(declare (uses process))
(declare (uses launch))
(declare (uses runs))
(declare (uses dashboard-tests))
(declare (uses tree))

	stml2
	megatestmod
	tasksmod
	runsmod
	testsmod
	)

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

;; set some parameters here - these need to be put in something that can be loaded from other
;; executables such as dashboard and mtutil
;;
(include "dashboard-transport-mode.scm")

;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses debugprint))
(declare (uses mtargs))
(declare (uses mtmod))

(module dbmod
	(
	 dbmod:db-to-db-sync
	 
	 db:test-get-event_time
	 db:test-get-item-path
	 db:test-get-testname
	 db:get-value-by-header
	 
	 db:get-subdb

	 db:multi-db-sync
	 
	 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
	 db:get-test-info

	 dbmod:print-db-stats
	 db:get-keys
	 db:open-no-sync-db
	 db:add-stats

	 ;; dbr:counts record accessors
	 dbr:counts->alist

	 db:add-var
	 db:archive-register-block-name
	 db:archive-register-disk
	 db:create-all-triggers
	 db:csv->test-data
	 db:dec-var
	 db:del-var
	 db:delete-old-deleted-test-records
	 db:delete-run
	 db:delete-steps-for-test!
	 db:delete-test-records
	 db:drop-all-triggers
	 db:get-all-run-ids
	 db:get-all-runids
	 db:get-changed-record-ids
	 db:get-changed-record-run-ids
	 db:get-changed-record-test-ids
	 db:get-count-tests-running
	 db:get-count-tests-running-for-run-id
	 db:get-count-tests-running-for-testname
	 db:get-count-tests-running-in-jobgroup
	 db:get-data-info-by-id
	 db:get-key-val-pairs
	 db:get-key-vals
	 db:get-latest-host-load
	 db:get-main-run-stats
	 db:get-matching-previous-test-run-records
	 db:get-not-completed-cnt
	 db:get-num-runs
	 db:get-prereqs-not-met
	 db:get-prev-run-ids
	 db:get-raw-run-stats
	 db:get-run-ids-matching-target
	 db:get-run-info
	 db:get-run-name-from-id
	 db:get-run-record-ids
	 db:get-run-state
	 db:get-run-state-status
	 db:get-run-stats
	 db:get-run-status
	 db:get-run-times
	 db:get-runs
	 db:get-runs-by-patt
	 db:get-runs-cnt-by-patt
	 db:get-steps-data
	 db:get-steps-for-test
	 db:get-steps-info-by-id
	 db:get-target
	 db:get-targets
	 db:get-test-state-status-by-id
	 db:get-test-times
	 db:get-testinfo-state-status
	 db:get-tests-for-run
	 db:get-tests-for-run-mindata
	 db:get-tests-for-run-state-status
	 db:get-tests-tags
	 db:get-toplevels-and-incompletes
	 db:get-var
	 db:have-incompletes?
	 db:inc-var
	 db:initialize-main-db
	 db:insert-run
	 db:insert-test
	 db:lock/unlock-run
	 db:login
	 db:read-test-data
	 db:read-test-data-varpatt
	 db:register-run
	 db:set-run-state-status
	 db:set-run-status
	 db:set-state-status-and-roll-up-run
	 db:set-var
	 db:simple-get-runs
	 db:test-get-archive-block-info
	 db:test-get-logfile-info
	 db:test-get-paths-matching-keynames-target-new
	 db:test-get-records-for-index-file
	 db:test-get-rundir-from-test-id
	 db:test-get-top-process-pid
	 db:test-set-archive-block-id
	 db:test-set-state-status
	 db:test-set-top-process-pid
	 db:test-toplevel-num-items
	 db:testmeta-add-record
	 db:testmeta-get-record
	 db:testmeta-update-field
	 db:teststep-set-status!
	 db:top-test-set-per-pf-counts
	 db:update-run-event_time
	 db:update-run-stats
	 db:update-tesdata-on-repilcate-db
	 tasks:add
	 tasks:find-task-queue-records
	 tasks:get-last
	 tasks:set-state-given-param-key

	 *db-stats*
	 dbmod:nfs-get-dbstruct
	 *db-stats-mutex*

	 db:get-header
	 db:get-rows
	 db:get-changed-run-ids

	 db:set-sync
	 db:setup
	 db:get-access-mode
	 db:test-record-fields
	 
	 db:logpro-dat->csv
	 std-exit-procedure
	 )
	
(import scheme)
	
(cond-expand
 (chicken-4
  (import chicken
	  data-structures

	commonmod
	configfmod
	dbfile
	debugprint
	mtmod
	)

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

(define *number-of-writes* 0)
(define *number-non-write-queries* 0)

	configfmod
	rmtmod
        testsmod
        dbmod
	debugprint)

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

;; yes, this is non-ideal 
(define dashboard:update-summary-tab #f)
(define dashboard:update-servers-table #f)

;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;

(declare (unit diff-report))
;; (declare (uses common))
(declare (uses debugprint))
(declare (uses rmtmod))
(declare (uses commonmod))
(declare (uses stml2))

(module diff-report
	*
(import scheme
	chicken
	posix
	debugprint
	ports
	srfi-1
	srfi-13
	srfi-69
	data-structures

	stml2
	commonmod
	rmtmod
	)
         
;; (include "common_records.scm")
(use matchable)
(use fmt)
(use ducttape-lib)
(define css "")

(define (diff:tests-mindat->hash tests-mindat)
  (let* ((res (make-hash-table)))

      (debug:print 0 *default-log-port* "No match for source target/runname="dest-target"/"dest-runname)
      (debug:print 0 *default-log-port* "Cannot proceed.")
      #f)
     (else
      (diff:deliver-diff-report src-run-id dest-run-id email-recipients-list: to-list html-output-file: html-file)))))

  
)

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

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

)

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

;;  strftime('%m/%d/%Y %H:%M:%S','now','localtime')

(declare (unit ezsteps))
(declare (uses commonmod))
;; (declare (uses common))
(declare (uses configfmod))
(declare (uses debugprint))

(declare (uses runconfig))
(declare (uses rmtmod))
(declare (uses mtargs))
(declare (uses tasksmod))

(declare (uses testsmod))
(declare (uses runsmod))
(declare (uses fsmod))

(use srfi-69)

(module ezstepsmod

	()

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

	tasksmod
	subrunmod
	testsmod
	runsmod
	fsmod
	)

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


;;(rmt:get-test-info-by-id run-id test-id) -> testdat

(declare (uses configfmod))
(declare (uses commonmod))
(declare (uses processmod))

(use srfi-69)

(module fsmod
	(
	 get-df
	 get-uname
	 common:get-disk-with-most-free-space
	 common:get-disk-space-used
	 common:check-db-dir-and-exit-if-insufficient

	 )

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

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

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

(declare (unit genexample))
(declare (uses mtargs))
(declare (uses debugprint))
;; (declare (uses common))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses rmtmod))
(declare (uses testsmod))
(declare (uses dbfile))
(declare (uses tasksmod))

(use posix regex matchable)

(module genexample
	*
	
(import scheme
	chicken

	data-structures
	extras
	srfi-1
	srfi-13
	srfi-69
	posix
	regex
	matchable
	(prefix mtargs args:)
	commonmod
	configfmod
	testsmod
	rmtmod
	debugprint
	tasksmod
	dbfile)

;; (include "db_records.scm")

(define genexample:example-logpro
#<<EOF
  ;; You should have at least one expect:required. This ensures that your process ran
  ;; comment out the line below and replace "put pattern here" with a pattern that will

		      (if (not (equal? item-path ""))
			  (system (conc "refdb set " miscrdb " itemsinfo " (obfuscate testname) " " (obfuscate item-path) " x")))

		      ))))
	    tests-data)))
       (map (lambda (runrec)(simple-run-id runrec)) runs)))
    ))
)

;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

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

;;
 
;;======================================================================
;; Run keys, these are used to hierarchially organise tests and run areas
;;======================================================================

(declare (unit keys))
;; (declare (uses common))
(declare (uses debugprint))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses mtargs))

(use sqlite3 srfi-1 posix regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:)

;;======================================================================
;; launch a task - this runs on the originating host, tests themselves
;;
;;======================================================================

(declare (unit launch))
(declare (uses subrun))
;; (declare (uses common))
(declare (uses debugprint))
(declare (uses commonmod))
(declare (uses processmod))
(declare (uses configfmod))
(declare (uses configf))
(declare (uses rmtmod))
(declare (uses ezsteps))

     typed-records pathname-expand matchable)

(import (prefix base64 base64:)
	(prefix sqlite3 sqlite3:)
	(prefix mtargs args:)
)

;; (include "common_records.scm")
;; (include "key_records.scm")
;; (include "db_records.scm")
(include "megatest-fossil-hash.scm")

(import commonmod
	processmod
	configfmod

(declare (uses testsmod))
(declare (uses runsmod))
(declare (uses fsmod))

(use srfi-69)

(module launchmod

	(
	 launch:load-logpro-dat
	 launch:recover-test
	 launch:execute
	 launch:extract-scripts-logpro
	)

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

	tasksmod
	subrunmod
	testsmod
	runsmod
	fsmod
	)

;; (include "common_records.scm")
;; (include "key_records.scm")
;; (include "db_records.scm")
(include "megatest-fossil-hash.scm")

;;======================================================================
;; ezsteps
;;======================================================================

		     #f)))
    ;; now wait on that process if all is correct
    ;; periodically update the db with runtime
    ;; when the process exits look at the db, if still RUNNING after 10 seconds set
    ;; state/status appropriately
    (process-wait pid)))
























































































;; TODO: deprecate me in favor of ezsteps.scm
;;
(define (ezsteps:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat)
  (let* ((stepname       (car ezstep))  ;; do stuff to run the step
	 (stepinfo       (cadr ezstep))
	;; (let ((info (cadr ezstep)))

;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;

;; (include "common.scm")
;; (include "megatest-version.scm")




;; (declare (uses common))
;; (declare (uses megatest-version))
;; (declare (uses margs))
(declare (uses mtargs))
(declare (uses mtargs.import))
(declare (uses debugprint))
(declare (uses debugprint.import))
(declare (uses cookie))
(declare (uses cookie.import))
(declare (uses stml2))
(declare (uses stml2.import))
(declare (uses commonmod))

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






















;; fake out readline usage of toplevel-command



(set! toplevel-command (lambda (a b) #f))
































































































































































































































































































































































































































































































































































































(import mtbody)





















































































































































































































































































































































































































































































































































































































(main)

(declare (uses pkts))
(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
	 common:args-get-state
	 common:args-get-status
	 common:get-runconfig-targets
	 )

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

;;  strftime('%m/%d/%Y %H:%M:%S','now','localtime')

(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking)
(import (prefix sqlite3 sqlite3:))

(declare (unit runs))
;; (declare (uses common))

(declare (uses runconfig))
(declare (uses commonmod))
(import commonmod)

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

(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) posix-extras directory-utils
     call-with-environment-variables)

(import (prefix sqlite3 sqlite3:))

(declare (unit mt))
(declare (uses debugprint))
;; (declare (uses common))
(declare (uses commonmod))
(declare (uses configfmod))

(declare (uses runconfig))
(declare (uses server))
(declare (uses runs))
(declare (uses rmtmod))
(declare (uses megatestmod))

(import debugprint
	commonmod
	configfmod
	rmtmod
	megatestmod)

;; make mt: calls in megatestmod work
;; (read-config-set! read-config)

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

;; This is the Megatest API. All generally "useful" routines will be wrapped or extended
;; here.

;;======================================================================
;; 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))
(declare (uses genexample))
(declare (uses rmtmod))
(declare (uses archivemod))
(declare (uses mutils))
(declare (uses odsmod))
(declare (uses testsmod))
(declare (uses diff-report))
(declare (uses tdb))

(use srfi-69)
(import csi)

(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
	  ;;	  readline
	  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
	csi)

(import (prefix mtargs args:)
        archivemod
	debugprint
	dbmod
	commonmod
	processmod
	configfmod
	dbfile
	dbmod
	portlogger
	tcp-transportmod
	rmtmod
	apimod
	stml2
	mtmod
	megatestmod
	servermod
	tasksmod
	runsmod
	rmtmod
	launchmod
	fsmod
	envmod
	apimod
	genexample
	mutils
	odsmod
	testsmod
	diff-report
	tdb
        )

(include "common_records.scm")

(define *db* #f) ;; this is only for the repl, do not use in general!!!!

;; (set! toplevel-command toplevel-command)

;; (include "common_records.scm")
;; (include "key_records.scm")
;; (include "db_records.scm")
(include "run_records.scm")
(include "megatest-fossil-hash.scm")

(import (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:))
(import
 ;; readline
 apropos json http-client directory-utils typed-records)
(import 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")
		      ;;     "%")
		      (current-user-name)
		      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")
	  (current-user-name)))))

  ;;======================================================================
  ;; 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
		(define toplevel-command (lambda (a b)(print a " "b)))
		(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))
	     (synclock-file   (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? synclock-file)
				    (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? synclock-file) (< age 20))
		    (debug:print 0 *default-log-port* "Lock "synclock-file" exists, skipping sync...")
                    (begin
                      (if (file-exists? synclock-file)
			  (begin
			    (debug:print 0 *default-log-port* "Deleting old lock file " synclock-file)
			    (delete-file synclock-file)
			    )
			  )
		      (dbfile:with-simple-file-lock
		       synclock-file
		       (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 synclock-file)
					      (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 " synclock-file)
                      )
		    )
		(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
)