Megatest

mofiles/mtconfigf.o : mtconfigf/mtconfigf.scm
mofiles/ulex.o      : ulex/ulex.scm
mofiles/mutils.o    : mutils/mutils.scm
mofiles/cookie.o    : stml2/cookie.scm
mofiles/stml2.o     : stml2/stml2.scm

# for the modularized stuff

mofiles/commonmod.o : megatest-fossil-hash.scm mofiles/stml2.o \
                      mofiles/mtargs.o mofiles/pkts.o mofiles/mtconfigf.o \
                      mofiles/processmod.o
mofiles/pgdbmod.o   : mofiles/commonmod.o
mofiles/dbmod.o     : mofiles/commonmod.o mofiles/keysmod.o \
                      mofiles/tasksmod.o mofiles/odsmod.o
mofiles/tasksmod.o  : mofiles/commonmod.o mofiles/pgdbmod.o
mofiles/rmtmod.o    : mofiles/commonmod.o \
                      mofiles/apimod.o mofiles/ulex.o mofiles/itemsmod.o
mofiles/apimod.o    : mofiles/dbmod.o mofiles/commonmod.o mofiles/servermod.o
mofiles/runsmod.o   : mofiles/testsmod.o mofiles/mtmod.o
mofiles/mtmod.o     : mofiles/mtconfigf.o mofiles/rmtmod.o mofiles/tasksmod.o \
                      mofiles/dbmod.o mofiles/pgdbmod.o mofiles/launchmod.o \
                      mofiles/subrunmod.o
mofiles/servermod.o : mofiles/commonmod.o mofiles/dbmod.o
mofiles/testsmod.o  : mofiles/servermod.o mofiles/dbmod.o
mofiles/launchmod.o : mofiles/subrunmod.o mofiles/testsmod.o

# special cases where an upstream .import file is needed to compile a module
mofiles/rmtmod.o    : ulex.import.o

# Removed from megamod.o dep:   mofiles/ftail.o
mofiles/megamod.o   : \
   mofiles/rmtmod.o \
   mofiles/commonmod.o \
   mofiles/apimod.o \
   mofiles/archivemod.o \

# base64 dot-locking \
#             csv-xml z3

#  "(define (toplevel-command . a) #f)"
# if egrep 'version.*3.0' $(shell dirname $(shell dirname $(shell which csi)))/lib/chicken/7/readline.setup-info;then \

readline-fix.scm :
	if [[ $(shell chicken-status | grep readline | awk '{print $4}' | cut -d. -f1) -gt 3 ]];then \
	if [[ $(shell chicken-status | grep breadline | awk '{print $4}' | cut -d. -f1) -gt 3 ]];then \
	   echo "(define *use-new-readline* #f)" > readline-fix.scm; \
	else \
	   echo "(define *use-new-readline* #t)" > readline-fix.scm;\
	fi

altdb.scm :
	echo ";; optional alternate db setup" > altdb.scm
	echo "(define *available-db* (make-hash-table))" >> altdb.scm
	if  csi -ne '(use mysql-client)';then \
           echo "(use mysql-client)(hash-table-set! *available-db* 'mysql #t)" >> altdb.scm; \
	if  csi -ne '(import mysql-client)';then \
           echo "(import mysql-client)(hash-table-set! *available-db* 'mysql #t)" >> altdb.scm; \
	fi
	if csi -ne '(use postgresql)';then \
	   echo "(use postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\
	if csi -ne '(import postgresql)';then \
	   echo "(import postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\
	fi

portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
	csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o

# create a pdf dot graphviz diagram from notations in rmt.scm
rmt.pdf : rmt.scm

(declare (uses commonmod))
(declare (uses dbmod))
(declare (uses servermod))

(module apimod
	*
	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable
	s11n z3 (prefix base64 base64:) regex stack srfi-13
(import scheme chicken.base chicken.irregex chicken.process-context.posix chicken.string chicken.time) 
(import (prefix sqlite3 sqlite3:) typed-records srfi-18 srfi-69 format chicken.port srfi-1 matchable
	s11n z3 (prefix base64 base64:) regex stack srfi-13)
	irregex)
(import commonmod)
(import dbmod)
(import servermod)

;; (use (prefix ulex ulex:))

;; These are called by the server on recipt of /api calls

                   ;; STEPS
                   ((teststep-set-status!)         (apply db:teststep-set-status! dbstruct params))
                   ((delete-steps-for-test!)        (apply db:delete-steps-for-test! dbstruct params))
                   
                   ;; TEST DATA
                   ((test-data-rollup)             (apply db:test-data-rollup dbstruct params))
                   ((csv->test-data)               (apply db:csv->test-data dbstruct params))
                   ;;((csv->test-data)               (apply db:csv->test-data dbstruct params))

                   ;; MISC
                   ((sync-inmem->db)               (let ((run-id (car params)))
                                                     (db:sync-touched dbstruct run-id force-sync: #t)))
                   ((mark-incomplete)              (apply db:find-and-mark-incomplete dbstruct params))

                   ;; TESTMETA

(declare (unit archivemod))
(declare (uses commonmod))

(module archivemod
	*
	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
(import scheme (chicken base))
(import (prefix sqlite3 sqlite3:) typed-records srfi-18 srfi-69 format (chicken port) srfi-1 matchable)
(import commonmod)
;; (use (prefix ulex ulex:))

(include "common_records.scm")


)

((license "BSD")
 (category lang-exts)
 (author "Alex Shinn")
 (synopsis "Load modules lazily")
 (components (extension autoload)))

;;; autoload.meta -*- Hen -*-

((egg "autoload.egg")
 (synopsis "Load modules lazily")
 (category lang-exts)
 (license "BSD")
 (author "Alex Shinn")
 (doc-from-wiki)
 (files "autoload.meta" "autoload.scm" "autoload.release-info" "autoload.setup"))

;;;; autoload.scm -- load modules lazily
;;
;; Copyright (c) 2005-2009 Alex Shinn
;; All rights reserved.
;;
;; BSD-style license: http://www.debian.org/misc/bsd.license

;; Provides an Emacs-style autoload facility which takes the basic form
;;
;;   (autoload unit procedure-name ...)
;;
;; such that the first time procedure-name is called, it will perform a
;; runtime require of 'unit and then apply the procedure from the newly
;; loaded unit to the args it was passed.  Subsequent calls to
;; procedure-name will thereafter refer to the new procedure and will
;; thus not incur any overhead.
;;
;; You may also specify an alias for the procedure, and a default
;; procedure if the library can't be loaded:
;;
;;   (autoload unit (name alias default) ...)
;;
;; In this case, although the procedure name from the unit is "name,"
;; the form defines the autoload procedure as "alias."
;;
;; If the library can't be loaded then an error is signalled, unless
;; default is given, in which case the values are passed to that.
;;
;; Examples:
;;
;; ;; load iconv procedures lazily
;; (autoload iconv iconv iconv-open)
;;
;; ;; load some sqlite procedures lazily with "-" names
;; (autoload sqlite (sqlite:open sqlite-open)
;;                  (sqlite:execute sqlite-execute))
;;
;; ;; load md5 library, falling back on slower scheme version
;; (autoload scheme-md5 (md5:digest scheme-md5:digest))
;; (autoload md5 (md5:digest #f scheme-md5:digest))

(module autoload (autoload)

(import scheme (chicken base))

(define-syntax autoload
  (er-macro-transformer
   (lambda (expr rename compare)
     (let ((module (cadr expr))
           (procs (cddr expr))
           (_import (rename 'import))
           (_define (rename 'define))
           (_let (rename 'let))
           (_set! (rename 'set!))
           (_begin (rename 'begin))
           (_apply (rename 'apply))
           (_args (rename 'args))
           (_tmp (rename 'tmp))
           (_eval (rename 'eval))
           (_condition-case (rename 'condition-case)))
       `(,_begin
         ,@(map
            (lambda (x)
              (let* ((x (if (pair? x) x (list x)))
                     (name (car x))
                     (full-name
                      (string->symbol
                       (string-append (symbol->string module) "#"
                                      (symbol->string name))))
                     (alias (or (and (pair? (cdr x)) (cadr x)) name))
                     (default (and (pair? (cdr x)) (pair? (cddr x)) (caddr x))))
                (if default
                    `(,_define (,alias . ,_args)
                       (,_let ((,_tmp (,_condition-case
                                       (,_begin
                                        (,_eval
                                         (begin (require-library ,module)
                                                #f))
                                        (,_eval ',full-name))
                                        (exn () ,default))))
                           (,_set! ,alias ,_tmp)
                           (,_apply ,_tmp ,_args)))
                    `(,_define (,alias . ,_args)
                       (,_let ((,_tmp (,_begin
                                        (,_eval
                                         (begin (require-library ,module)
                                                 #f))
                                        (,_eval ',full-name))))
                         (,_set! ,alias ,_tmp)
                         (,_apply ,_tmp ,_args))))))
            procs))))))

)

(compile -s -O2 -j autoload autoload.scm)
(compile -s -O2 autoload.import.scm)

(install-extension 
 'autoload '("autoload.so" "autoload.import.so") 
 '((version 3.0) (syntax)))

(declare (unit clientmod))
(declare (uses commonmod))

(module clientmod
	*
	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
(import scheme (chicken base))
(import (prefix sqlite3 sqlite3:) typed-records srfi-18 srfi-69 format (chicken port) srfi-1 matchable)
(import commonmod)
;; (use (prefix ulex ulex:))

(include "common_records.scm")


)

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

;; (use trace)
(use typed-records)
(import typed-records)

;; moved to commonmod

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

(declare (unit commonmod))
(declare (uses mtargs))
;; (declare (uses stml2))
(declare (uses mtconfigf))
(declare (uses ulex))
(declare (uses pkts))
(module commonmod
	*
	
(import scheme chicken data-structures extras)
(import scheme (chicken base)
               (chicken process)
               (chicken format)
               (chicken process-context)
               (chicken process-context posix)
               (chicken string) 
               (chicken io)
               (chicken pretty-print)
               (chicken file)
               (chicken file posix)
               (chicken pathname)
               (chicken time)
               (chicken sort)
               (chicken condition)
               (chicken time posix)

) 

(use (prefix sqlite3 sqlite3:) posix typed-records srfi-18
     srfi-1 files format srfi-13 matchable 
     srfi-69 ports
(import (prefix sqlite3 sqlite3:) typed-records srfi-18
     srfi-1 (chicken file) format srfi-13 matchable 
     srfi-69 (chicken port)
     (prefix base64 base64:)
     regex-case regex hostinfo srfi-4
     (prefix dbi dbi:)
     stack
     md5 
     message-digest
     z3
     directory-utils
     system-information
     sparse-vectors)

(import pkts)
(import ulex)
     sparse-vectors
)

(import pkts)
(import	(prefix mtconfigf configf:))
(import	(prefix mtargs args:))

(include "common_records.scm")
(include "megatest-fossil-hash.scm")
(include "megatest-version.scm")

		      (get-environment-variable "MT_DEBUG_MODE"))))
    (set! *verbosity* (debug:calc-verbosity debugstr verbose quiet))
    (debug:check-verbosity *verbosity* debugstr)
    ;; if we were handed a bad verbosity rule then we will override it with 1 and continue
    (if (not *verbosity*)(set! *verbosity* 1))
    (if (or dmode                                            ;; (args:get-arg "-debug")
	    (not (get-environment-variable "MT_DEBUG_MODE")))
	(setenv "MT_DEBUG_MODE" (if (list? *verbosity*)
	(set-environment-variable! "MT_DEBUG_MODE" (if (list? *verbosity*)
				    (string-intersperse (map conc *verbosity*) ",")
				    (conc *verbosity*))))))
  
(define (debug:print n e . params)
  (if (debug:debug-mode n)
      (with-output-to-port (or e (current-error-port))
	(lambda ()

;;
(define (common:get-create-writeable-dir dirs)
  (if (null? dirs)
      #f
      (let loop ((hed (car dirs))
		 (tal (cdr dirs)))
	(let ((res (or (and (directory? hed)
			    (file-write-access? hed)
			    (file-writable? hed)
			    hed)
		       (handle-exceptions
			   exn
			   (begin
			     (debug:print-info 0 *default-log-port* "could not create " hed ", this might cause problems down the road.")
			     #f)
			(create-directory hed #t)))))

;;    returns the directory or #f
;;
(define (common:directory-writable? path-string)
  (handle-exceptions
   exn
   #f
   (if (and (directory-exists? path-string)
            (file-write-access? path-string))
            (file-writable? path-string))
       path-string
       #f)))
;;======================================================================
;; T I M E   A N D   D A T E
;;======================================================================

;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5

  (if (or (substring-index "!" key) (substring-index ":" key)) ;; variables containing : are for internal use and cannot be environment variables.
      (debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\" or starting with \"!\"")
      (if (and (string? val)
	       (string? key))
	  (handle-exceptions
	      exn
	      (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val)
	    (setenv key val))
	    (set-environment-variable! key val))
	  (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val))))

(define home (getenv "HOME"))
(define user (getenv "USER"))

;; put any changed environment variables back to how they were - TODO - turn this into some sort of with-
(define (common:set-vars-back all-vars)
  (for-each
     (lambda (vardat)
       (let ((var (car vardat))
	     (val (cdr vardat)))
	 (if (not (equal? (get-environment-variable var) val))
	     (handle-exceptions
	      exn
	      (debug:print-error 0 *default-log-port* "Failed to set " var " to " val)
	      (setenv var val)))))
	      (set-environment-variable! var val)))))
     all-vars))
  
  ;; returns list of fd count, socket count
(define (get-file-descriptor-count #!key  (pid (current-process-id )))
  (list
    (length (glob (conc "/proc/" pid "/fd/*")))
    (length  (filter identity (map socket? (glob (conc "/proc/" pid "/fd/*")))))

    ;; TEST DATA
    test-data-rollup
    csv->test-data

    ;; MISC
    sync-inmem->db

    ;; TESTMETA
    ;; TESTMETAl
    testmeta-add-record
    testmeta-update-field

    ;; TASKS
    tasks-add
    tasks-set-state-given-param-key
    ))

;;======================================================================
;; ALLDATA
;;======================================================================
;;

;; attempt to consolidate a bunch of global information into one struct to toss around
(defstruct alldat
  ;; misc
  (denoise           (make-hash-table))
  (areapath          #f) ;; i.e. toppath
  (mtconfig          #f)
  (log-port          #f)
  (areadat           #f) ;; i.e. runremote
  (ulexdat           #f) ;; connection to the databases
  (rmt-mutex         (make-mutex))
  (db-sync-mutex     (make-mutex))
  (db-with-db-mutex  (make-mutex))
  (read-only-queries api:read-only-queries)
  (write-queries     api:write-queries)
  (max-api-process-requests 0)
  (api-process-request-count 0)

(use posix-extras pathname-expand files)
(import pathname-expand (chicken file))

;; this plugs a hole in posix-extras in recent chicken versions > 4.9)
(let-values (( (chicken-release-number chicken-major-version)
#;(let-values (( (chicken-release-number chicken-major-version)
               (apply values
                      (map string->number
                           (take
                            (string-split (chicken-version) ".")
                            2)))))
  (let ((resolve-pathname-broken?
         (or (> chicken-release-number 4)
             (and (eq? 4 chicken-release-number) (> chicken-major-version 9)))))
    (if resolve-pathname-broken?
        (define ##sys#expand-home-path pathname-expand))))
      
(define (realpath x) (resolve-pathname  (pathname-expand (or x "/dev/null")) ))
;;(define (realpath x) (resolve-pathname  (pathname-expand (or x "/dev/null")) ))
(define (realpath x) (pathname-expand (or x "/dev/null")) )

(define (common:get-this-exe-fullpath #!key (argv (argv)))
  (let* ((this-script
          (cond
           ((and (> (length argv) 2)
                 (string-match "^(.*/csi|csi)$" (car argv))
                 (string-match "^-(s|ss|sx|script)$" (cadr argv)))

				 (begin
				   (mutex-unlock! *homehost-mutex*)
				   (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Failed to read .homehost file after trying five times. Giving up and exiting, message: "  ((condition-property-accessor 'exn 'message) exn))
				   (exit 1)))
			   (let ((hhf (conc *toppath* "/.homehost")))
			     (if (common:file-exists? hhf)
				 (with-input-from-file hhf read-line)
				 (if (file-write-access? *toppath*)
				 (if (file-writable? *toppath*)
				     (begin
				       (with-output-to-file hhf
					 (lambda ()
					   (print bestadrs)))
				       (begin
					 (mutex-unlock! *homehost-mutex*)
					 (car (common:get-homehost))))

;; get values from cached info from dropping file in logs dir
;;  e.g. key is host and dtype is normalized-load
;;
(define (common:get-cached-info key dtype #!key (age 5))
  (let* ((fullpath (conc *toppath* "/logs/" key "-" dtype ".log")))
    (if (and (file-exists? fullpath)
	     (file-read-access? fullpath))
	     (file-readable? fullpath))
	(handle-exceptions
	 exn
	 #f
	 (debug:print 2 *default-log-port* "reading file " fullpath)
	 (let ((real-age (- (current-seconds)(file-change-time fullpath)))) 
	   (if (< real-age age)
	       (with-input-from-file fullpath read)

     (lambda (disk-num)
       (let* ((dirpath    (cadr (assoc disk-num disks)))
	      (freespc    (cond
			   ((not (directory? dirpath))
			    (if (common:low-noise-print 300 "disks not a dir " disk-num)
				(debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a directory - ignoring it."))
			    -1)
			   ((not (file-write-access? dirpath))
			   ((not (file-writable? dirpath))
			    (if (common:low-noise-print 300 "disks not writeable " disk-num)
				(debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not writeable - ignoring it."))
			    -1)
			   ((not (eq? (string-ref dirpath 0) #\/))
			    (if (common:low-noise-print 300 "disks not a proper path " disk-num)
				(debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a fully qualified path - ignoring it."))
			    -1)
			   (else
			    (get-df dirpath))))
	      (free-inodes (cond
			   ((not (directory? dirpath))
			    (if (common:low-noise-print 300 "disks not a dir " disk-num)
				(debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a directory - ignoring it."))
			    -1)
			   ((not (file-write-access? dirpath))
			   ((not (file-writable? dirpath))
			    (if (common:low-noise-print 300 "disks not writeable " disk-num)
				(debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not writeable - ignoring it."))
			    -1)
			   ((not (eq? (string-ref dirpath 0) #\/))
			    (if (common:low-noise-print 300 "disks not a proper path " disk-num)
				(debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a fully qualified path - ignoring it."))
			    -1)

	(for-each (lambda (p)
		    (let* ((var (car  p))
			   (val (cadr p))
			   (prv (get-environment-variable var)))
		      (set! res (cons (list var prv) res))
		      (if val 
			  (safe-setenv var (->string val))
			  (unsetenv var))))
			  (unset-environment-variable! var))))
		  lst)
	res)
      '()))


;; clear vars matching pattern, run proc, set vars back
;; if proc is a string run that string as a command with

                      (if (string-match "^MT_.*" (car x))
                          #f
                          x))
                    envvars))))

(define (common:with-orig-env proc)
  (let  ((current-env (get-environment-variables)))
    (for-each (lambda (x) (unsetenv (car x)))             current-env)
    (for-each (lambda (x) (setenv (car x) (cdr x))) *common:orig-env*)
    (for-each (lambda (x) (unset-environment-variable! (car x)))             current-env)
    (for-each (lambda (x) (set-environment-variable! (car x) (cdr x))) *common:orig-env*)
    (let ((rv (cond
               ((string? proc)(system proc))
               (proc          (proc)))))
      (for-each (lambda (x) (unsetenv (car x))) *common:orig-env*)
      (for-each (lambda (x) (setenv (car x) (cdr x))) current-env)
      (for-each (lambda (x) (unset-environment-variable! (car x))) *common:orig-env*)
      (for-each (lambda (x) (set-environment-variable! (car x) (cdr x))) current-env)
      rv)))

(define (common:without-vars proc . var-patts)
  (let ((vars (make-hash-table)))
    (for-each
     (lambda (vardat) ;; each env var
       (for-each
	(lambda (var-patt)
	  (if (string-match var-patt (car vardat))
	      (let ((var (car vardat))
		    (val (cdr vardat)))
		(hash-table-set! vars var val)
		(unsetenv var))))
		(unset-environment-variable! var))))
	var-patts))
     (get-environment-variables))
    (cond
     ((string? proc)(system proc))
     (proc          (proc)))
    (hash-table-for-each
     vars
     (lambda (var val)
       (setenv var val)))
       (set-environment-variable! var val)))
    vars))


;;======================================================================
;; C O L O R S
;;======================================================================
      

     (for-each
      (lambda (pktsdir) ;; look at all
	(cond
	 ((not (common:file-exists? pktsdir))
	  (debug:print 0 *default-log-port* "ERROR: packets directory " pktsdir " does not exist."))
	 ((not (directory? pktsdir))
	  (debug:print 0 *default-log-port* "ERROR: packets directory path " pktsdir " is not a directory."))
	 ((not (file-read-access? pktsdir))
	 ((not (file-readable? pktsdir))
	  (debug:print 0 *default-log-port* "ERROR: packets directory path " pktsdir " is not readable."))
	 (else
	  (debug:print-info 0 *default-log-port* "Loading packets found in " pktsdir)
	  (let ((pkts (glob (conc pktsdir "/*.pkt"))))
	    (for-each
	     (lambda (pkt)
	       (let* ((uuid    (cadr (string-match ".*/([0-9a-f]+).pkt" pkt)))

           (map (lambda (env-pair)
                  (let* ((env-var     (car env-pair))
                         (new-val     (let ((tmp (cdr env-pair)))
                                        (if (list? tmp) (car tmp) tmp)))
                         (current-val (get-environment-variable env-var))
                         (restore-thunk
                          (cond
                           ((not current-val) (lambda () (unsetenv env-var)))
                           ((not current-val) (lambda () (unset-environment-variable! env-var)))
                           ((not (string? new-val)) #f)
                           ((eq? current-val new-val) #f)
                           (else 
                            (lambda () (setenv env-var current-val))))))
                            (lambda () (set-environment-variable! env-var current-val))))))
                    ;;(when (not (string? new-val))
                    ;;    (debug:print 0 *default-log-port* " PROBLEM: not a string: "new-val"\n from env-alist:\n"delta-env-alist)
                    ;;    (pp delta-env-alist)
                    ;;    (exit 1))
                        
                    
                    (cond
                     ((not new-val)  ;; modify env here
                      (unsetenv env-var))
                      (unset-environment-variable! env-var))
                     ((string? new-val)
                      (setenv env-var new-val)))
                      (set-environment-variable! env-var new-val)))
                    restore-thunk))
                delta-env-alist))))
    (let ((rv (thunk)))
      (for-each (lambda (x) (x)) restore-thunks) ;; restore env to original state
      rv)))

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

(declare (unit configfmod))
;; (declare (uses commonmod))

(module configfmod
	*
	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18
	srfi-69 format ports srfi-1 matchable regex)
(import scheme (chicken base))
(import (prefix sqlite3 sqlite3:) typed-records srfi-18
	srfi-69 format (chicken port) srfi-1 matchable regex)
;; (import commonmod)
;; (use (prefix ulex ulex:))

(include "common_records.scm")

(define (configf:lookup cfgdat section var)
  (if (hash-table? cfgdat)

(declare (uses ulex.import))
(declare (uses cookie.import))
(declare (uses stml2.import))
(declare (uses ducttape-lib.import))
(declare (uses mtconfigf.import))

(declare (uses gutilsmod))
(declare (uses servermod))
(declare (uses megamod))
(declare (uses commonmod))
(declare (uses rmtmod))
(declare (uses runsmod))
(declare (uses dbmod))
(declare (uses testsmod))
(declare (uses tasksmod))
(declare (uses dcommonmod))
(declare (uses tasksmod))


(import gutilsmod)
(import servermod)
(import megamod)
(import commonmod)
(import rmtmod)
(import runsmod)
(import dbmod)
(import testsmod)
(import tasksmod)

       (iup:hbox
        (iup:button "Hide All" #:action (lambda (obj)
                                          (for-each (lambda (graph-cell)
                                                      (let* ((graph-dat   (hash-table-ref (dboard:tabdat-graph-cell-table tabdat) graph-cell)))
                                                        (dboard:graph-dat-flag-set! graph-dat #f)))
                                                    (hash-table-keys (dboard:tabdat-graph-cell-table tabdat)))))))
      ))))

;;======================================================================
;; SYSTEM MONITOR - Track relevant Megatest processes
;;======================================================================
;;
;; A gui for launching tests
;;
(define (dashboard:sysmon commondat tabdat #!key (tab-num #f))
  (let* ((drawing               (vg:drawing-new))
	 (sysmon-tab-updater (lambda ()	
			       (debug:catch-and-dump 
				(lambda ()
				  (let ((tabdat        (dboard:common-get-tabdat commondat tab-num: tab-num)))
				    (if tabdat
					(let ((last-data-update (dboard:tabdat-last-data-update tabdat))
					      (now-time         (current-seconds)))
					  (dashboard:sysmon-canvas-updater commondat tabdat tab-num) ;; redraws canvas on user input (I think...)
					  ))))
				   "dashboard:sysmon-tab-updater")))
	 (key-listboxes #f) ;; 
	 (update-keyvals (lambda ()
			   (dboard:target-updater tabdat))))
    (dboard:tabdat-drawing-set! tabdat drawing)
    (dboard:commondat-add-updater commondat sysmon-tab-updater tab-num: tab-num)
    (iup:vbox
     (let* ((cnv-obj (iup:canvas 
		      ;; #:size "250x250" ;; "500x400"
		      #:expand "YES"
		      #:scrollbar "YES"
		      #:posx "0.5"
		      #:posy "0.5"
		      #:action (make-canvas-action
				(lambda (c xadj yadj)
				  (debug:catch-and-dump
				   (lambda ()
				     (if (not (dboard:tabdat-cnv tabdat))
					 (let ((cnv     (dboard:tabdat-cnv tabdat)))
					   (dboard:tabdat-cnv-set! tabdat c)
					   (vg:drawing-cnv-set! (dboard:tabdat-drawing tabdat)
								(dboard:tabdat-cnv tabdat))))
				     (let ((drawing (dboard:tabdat-drawing tabdat))
					   (old-xadj (dboard:tabdat-xadj   tabdat))
					   (old-yadj (dboard:tabdat-yadj   tabdat)))
				       (if (not (and (eq? xadj old-xadj)(eq? yadj old-yadj)))
					   (begin
					     ;; (print  "xadj: " xadj " yadj: " yadj "changed: "(eq? xadj old-xadj) " " (eq? yadj old-yadj))
					     (dboard:tabdat-view-changed-set! tabdat #t)
					     (dboard:tabdat-xadj-set! tabdat (* -2000 (- xadj 0.5)))
					     (dboard:tabdat-yadj-set! tabdat (*  2000 (- yadj 0.5)))
					     ))))
				   "iup:canvas action")))
		      #:wheel-cb  (lambda (obj step x y dir) ;; dir is 4 for up and 5 for down. I think.
				    (debug:catch-and-dump
				     (lambda ()
				       (let* ((drawing (dboard:tabdat-drawing tabdat))
					      (scalex  (vg:drawing-scalex drawing)))
					 (dboard:tabdat-view-changed-set! tabdat #t)
					 ;; (print "step: " step " x: " x " y: " y " dir: " dir " scalex: " scalex)
					 (vg:drawing-scalex-set! drawing
								 (+ scalex
								    (if (> step 0)
									(* scalex  0.02)
									(* scalex -0.02))))))
				     "wheel-cb"))
		      )))
       cnv-obj))))

;; run times canvas updater
;;
(define (dashboard:sysmon-canvas-updater commondat tabdat tab-num)
  (let ((cnv (dboard:tabdat-cnv tabdat))
	(dwg (dboard:tabdat-drawing tabdat))
	(mtx (dboard:tabdat-runs-mutex tabdat))
	(vch (dboard:tabdat-view-changed tabdat)))
    (if (and cnv dwg vch)
	(begin
	  (vg:drawing-xoff-set! dwg (dboard:tabdat-xadj tabdat))
	  (vg:drawing-yoff-set! dwg (dboard:tabdat-yadj tabdat))
	  (mutex-lock! mtx)
	  (canvas-clear! cnv)
	  (vg:draw dwg tabdat)
	  (mutex-unlock! mtx)
	  (dboard:tabdat-view-changed-set! tabdat #f)))))
  


;;======================================================================
;; R U N
;;======================================================================
;;
;; display and manage a single run at a time

(define (make-dashboard-buttons commondat) ;;  runs-sum-dat new-view-dat)
  (let* ((stats-dat       (dboard:tabdat-make-data))
	 (runs-dat        (dboard:tabdat-make-data))
	 (onerun-dat      (dboard:tabdat-make-data)) ;; name for run-summary structure 
	 (runcontrols-dat (dboard:tabdat-make-data))
	 (runtimes-dat    (dboard:tabdat-make-data))
	 (sysmon-dat      (dboard:tabdat-make-data))
	 (nruns           (dboard:tabdat-numruns runs-dat))
	 (ntests          (dboard:tabdat-num-tests runs-dat))
	 (keynames        (dboard:tabdat-dbkeys runs-dat))
	 (nkeys           (length keynames))
	 (runsvec         (make-vector nruns))
	 (header          (make-vector nruns))
	 (lftcol          (make-vector ntests))

			  (dashboard:summary commondat stats-dat tab-num: 0)
			  runs-view
			  (dashboard:runs-summary commondat onerun-dat tab-num: 2)
			  ;; (dashboard:new-view db data new-view-dat tab-num: 3)
			  (dashboard:run-controls commondat runcontrols-dat tab-num: 3)
			  (dashboard:run-times commondat runtimes-dat tab-num: 4)
			  ;; ;; (dashboard:runs-summary commondat onerun-dat tab-num: 4)
			  (dashboard:sysmon commondat sysmon-dat tab-num: 5)
			  additional-views
			  )))
	;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
	(iup:attribute-set! tabs "TABTITLE0" "Summary")
	(iup:attribute-set! tabs "TABTITLE1" "Runs")
	(iup:attribute-set! tabs "TABTITLE2" "Run Summary")
	(iup:attribute-set! tabs "TABTITLE3" "Run Control")
	(iup:attribute-set! tabs "TABTITLE4" "Run Times")
	(iup:attribute-set! tabs "TABTITLE5" "Sysmon")
	;; (iup:attribute-set! tabs "TABTITLE3" "New View")
	;; (iup:attribute-set! tabs "TABTITLE4" "Run Control")

	;; set the tab names for user added tabs
	(for-each
	 (lambda (tab-info)
	   (iup:attribute-set! tabs (conc "TABTITLE" (car tab-info)) (cdr tab-info)))
	 additional-tabnames)
	
	(iup:attribute-set! tabs "BGCOLOR" "190 190 190")
	;; make the iup tabs object available (for changing color for example)
	(dboard:commondat-hide-not-hide-tabs-set! commondat tabs)
	;; now set up the tabdat lookup
	(dboard:common-set-tabdat! commondat 0 stats-dat)
	(dboard:common-set-tabdat! commondat 1 runs-dat)
	(dboard:common-set-tabdat! commondat 2 onerun-dat)
	(dboard:common-set-tabdat! commondat 3 runcontrols-dat)
	(dboard:common-set-tabdat! commondat 4 runtimes-dat)
	(dboard:common-set-tabdat! commondat 5 sysmon-dat)

	(iup:vbox
	 tabs
	 ;; controls
	 ))))
    (vector keycol lftcol header runsvec)))

((license "BSD")
 (category db)
 (dependencies autoload sql-null)
 (test-dependencies test)
 (components (extension dbi)))

;; -*- scheme -*-
(
; Your egg's license:
(license "BSD")

; Pick one from the list of categories (see below) for your egg and enter it
; here.
(category db)

; A list of eggs dbi depends on.  If none, you can omit this declaration
; altogether. If you are making an egg for chicken 3 and you need to use
; procedures from the `files' unit, be sure to include the `files' egg in the
; `needs' section (chicken versions < 3.4.0 don't provide the `files' unit).
; `depends' is an alias to `needs'.
(needs (autoload "3.0") sql-null)

; A list of eggs required for TESTING ONLY.  See the `Tests' section.
(test-depends test)

(author "Matt Welland")
(synopsis "An abstract database interface."))

(repo fossil "http://www.kiatoa.com/cgi-bin/fossils/{egg-name}")
(uri zip "http://www.kiatoa.com/cgi-bin/fossils/{egg-name}/zip/{egg-name}.zip?uuid={egg-release}")
(release "0.5")
(release "0.4")
(release "0.3")
(release "0.2")
(release "0.1")

;;; dbi: Minimal gasket to postgresql, sqlite3 and mysql
;;;
;; Copyright (C) 2007-2018 Matt Welland
;; Copyright (C) 2016 Peter Bex
;; Redistribution and use in source and binary forms, with or without
;; modification, is permitted.
;;
;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
;; DAMAGE.

;; ONLY A LOWEST COMMON DEMOMINATOR IS SUPPORTED!

;; d = db handle
;; t = statement handle
;; s = statement
;; l = proc
;; p = params
;;
;;          sqlite3                    postgres                   dbi
;; prepare: (prepare d s)              n/a                        prepare (sqlite3, pg)
;; for-each (for-each-row l d s . p)   (query-for-each l s d)     for-each-row
;; for-each (for-each-row l t . p)     n/a                        NOT YET
;; exec     (exec d s . p)             (query-tuples s d)      
;; exec     (exec t . p)               n/a

;; set to 'pg or 'sqlite3
;; (define dbi:type 'sqlite3) ;; or 'pg
;;  (dbi:open 'sqlite3 (list (cons 'dbname fullname)))

;;======================================================================
;; D B I
;;======================================================================
(module dbi
    (open db-dbtype db-conn for-each-row get-one get-one-row get-rows
     exec close escape-string mk-db now database? with-transaction fold-row
     prepare map-row convert prepare-exec get-res

     ;; TODO: These don't really belong here.  Also, the naming is not
     ;; consistent with the usual Scheme conventions.
     pgdatetime-get-year pgdatetime-get-month pgdatetime-get-day
     pgdatetime-get-hour pgdatetime-get-minute pgdatetime-get-second
     pgdatetime-get-microsecond
     pgdatetime-set-year! pgdatetime-set-month! pgdatetime-set-day!
     pgdatetime-set-hour! pgdatetime-set-minute! pgdatetime-set-second!
     pgdatetime-set-microsecond!

     lazy-bool)

(import (chicken base) (chicken process) (chicken file) (chicken time) (chicken string) (chicken format) (chicken time posix) scheme srfi-1 srfi-13)
(import (chicken condition) autoload sql-null)

(define-record-type db
  (make-db dbtype dbconn)
  db?
  (dbtype db-dbtype  db-dbtype-set!)
  (dbconn db-conn    db-conn-set!))

(define (missing-egg type eggname)
  (lambda _
    (error (printf
               "Cannot access ~A databases.  Please install the ~S egg and try again." type eggname))))

;; (define (sqlite3:statement? h) #f) ;; dummy - hope it gets clobbered if sqlite3 gets loaded

;; TODO: Make a convenience macro for this?
(define sqlite3-missing (missing-egg 'sqlite3 "sqlite3"))
(autoload sqlite3
          (open-database sqlite3:open-database sqlite3-missing)
          (for-each-row sqlite3:for-each-row sqlite3-missing)
          (execute sqlite3:execute sqlite3-missing)
          (with-transaction sqlite3:with-transaction sqlite3-missing)
          (finalize! sqlite3:finalize! sqlite3-missing)
          (make-busy-timeout sqlite3:make-busy-timeout sqlite3-missing)
          (set-busy-handler! sqlite3:set-busy-handler! sqlite3-missing)
          (database? sqlite3:database? sqlite3-missing)
          (prepare sqlite3:prepare sqlite3-missing)
          (fold-row sqlite3:fold-row sqlite3-missing)
          (map-row sqlite3:map-row sqlite3-missing)
          (statement? sqlite3:statement? sqlite3-missing))

(define sql-de-lite-missing (missing-egg 'sql-de-lite "sql-de-lite"))
(autoload sql-de-lite
          (open-database     sql:open-database     sql-de-lite-missing)
	  (close-database    sql:close-database    sql-de-lite-missing)
          (for-each-row      sql:for-each-row      sql-de-lite-missing)
	  (fold-rows         sql:fold-rows         sql-de-lite-missing)
          (exec              sql:exec              sql-de-lite-missing)
	  (fetch-value       sql:fetch-value       sql-de-lite-missing)
	  (with-transaction  sql:with-transaction  sql-de-lite-missing)
          (finalize!         sql:finalize!         sql-de-lite-missing)
          (make-busy-timeout sql:make-busy-timeout sql-de-lite-missing)
          (set-busy-handler! sql:set-busy-handler! sql-de-lite-missing)
	  (query             sql:query             sql-de-lite-missing)
	  (sql               sql:sql               sql-de-lite-missing))

(define pg-missing (missing-egg 'pg "postgresql"))
(autoload postgresql
          (connect pg:connect pg-missing)
          (row-for-each pg:row-for-each pg-missing)
          (with-transaction pg:with-transaction pg-missing)
          (query pg:query pg-missing)
          ;;(escape-string pg:escape-string pg-missing)
          (disconnect pg:disconnect pg-missing)
          (connection? pg:connection? pg-missing)
          (row-fold pg:row-fold pg-missing)
          (row-map pg:row-map pg-missing)
          (affected-rows pg:affected-rows pg-missing)
          (result? pg:result? pg-missing))

(define mysql-missing (missing-egg 'mysql "mysql-client"))
(autoload mysql-client 
  (make-mysql-connection mysql:make-connection mysql-missing)
  (mysql-null? mysql:mysql-null? mysql-missing))

(define (open dbtype dbinit)
  (make-db
   dbtype
   (case dbtype
     ((sqlite3)     (sqlite3:open-database (alist-ref 'dbname dbinit)))
     ((sql-de-lite) (sql:open-database (alist-ref 'dbname dbinit)))
     ((pg)          (pg:connect dbinit))
     ((mysql)       (mysql:make-connection (alist-ref 'host dbinit)
					   (alist-ref 'user dbinit)
					   (alist-ref 'password dbinit)
					   (alist-ref 'dbname dbinit)
					   port: (alist-ref 'port dbinit)))
     (else (error "Unsupported dbtype " dbtype)))))

(define (convert dbh)
  (cond
    ((database? dbh)           dbh) 
    ((sqlite3:database? dbh)   (make-db 'sqlite3 dbh))
    ((pg:connection? dbh)      (make-db 'pg dbh))
    ((not mysql:mysql-null?)   (make-db 'mysql dbh))
    (else (error "Unsupported database handle " dbh))))

(define (for-each-row proc dbh stmt . params)
    (let ((dbtype (db-dbtype dbh))
	  (conn    (db-conn dbh)))
      (case dbtype
        ((sqlite3) (sqlite3:for-each-row 
                    (lambda (first . remaining)
                      (let ((tuple (list->vector (cons first remaining))))
                        (proc tuple)))
                    conn
                    (apply sqlparam stmt params)))
	((sql-de-lite)(apply sql:query (sql:for-each-row
					(lambda (row)
					  (proc (list->vector row))))
			     (sql:sql conn stmt)
			     params))
        ((pg) (pg:row-for-each
               (lambda (tuple)
                 (proc (list->vector tuple)))
               (pg:query conn (apply sqlparam stmt params))))
        ((mysql) (let* ((replaced-sql (apply sqlparam stmt params))
                        (fetcher (conn replaced-sql)))
                   (fetcher (lambda (tuple)
                              (proc (list->vector tuple))))))
        (else (error "Unsupported dbtype " dbtype)))))

;; common idiom is to seek a single value, #f if no match
;; NOTE: wish to return first found. Do the set only if not set
(define (get-one dbh stmt . params)
  (let ((dbtype (db-dbtype dbh))
	(conn    (db-conn dbh)))
    (case dbtype
      ((sql-de-lite)
       (apply sql:query sql:fetch-value (sql:sql conn stmt) params))
      (else 
        (let ((res #f))
	  (apply for-each-row
		 (lambda (row)
		   (if (not res)
		       (set! res (vector-ref row 0))))
		 dbh
		 stmt 
		 params)
	  res)))))

;; common idiom is to seek a single value, #f if no match
;; NOTE: wish to return first found. Do the set only if not set
(define (get-one-row dbh stmt . params)
  (let ((res #f))
    (apply for-each-row
	   (lambda (row)
	     (if (not res)
	         (set! res row)))
	   dbh
	   stmt 
	   params)
    res))

;; common idiom is to seek a list of rows, '() if no match
(define (get-rows dbh stmt . params)
  (let ((res '()))
    (apply for-each-row
	   (lambda (row)
	     (set! res (cons row res)))
	   dbh
	   stmt 
	   params)
    (reverse res)))

(define (exec dbh stmt . params)
    (let ((dbtype (db-dbtype dbh))
      	 (conn   (db-conn dbh))
      	 (junk   #f))
          (case dbtype
            ((sqlite3) (apply sqlite3:execute conn stmt params))
            ((sql-de-lite)(apply sql:exec (sql:sql conn stmt) params))
            ((pg) (pg:query conn (apply sqlparam stmt params)))
            ((mysql) (conn (apply sqlparam stmt params)))
            (else (error "Unsupported dbtype " dbtype)))))

(define (with-transaction dbh proc)
  (let ((dbtype (db-dbtype dbh))
  (conn   (db-conn dbh)))
    (case dbtype
      ((sql-de-lite)(sql:with-transaction conn proc))
      ((sqlite3) (sqlite3:with-transaction
                  conn
                  (lambda () (proc))))
      ((pg) (pg:with-transaction
             conn (lambda () (proc))))
      ((mysql) 
        (conn "START TRANSACTION")
        (conn proc)
        (conn "COMMIT"))
      (else (error "Unsupported dbtype " dbtype)))))

(define (prepare dbh stmt)
  (let ((dbtype (db-dbtype dbh))
  (conn   (db-conn dbh)))
    (case dbtype
      ((sql-de-lite) dbh) ;; nop?
      ((sqlite3) (sqlite3:prepare conn stmt))
      ((pg) (exec dbh stmt) (cons (cons dbh (cadr (string-split stmt))) '()))
      ((mysql) (print "WIP"))
      (else (error "Unsupported dbtype" dbtype)))))

(define (fold-row proc init dbh stmt . params) ;; expecting (proc init/prev res)
  (let ((dbtype (db-dbtype dbh))
  (conn   (db-conn dbh)))
    (case dbtype
      ((sql-de-lite) (apply sql:query (sql:fold-rows proc init)
			    (sql:sql conn stmt) params))
      ((sqlite3)     (let ((newproc (lambda (prev . rem)
				      (proc rem prev))))
		       (apply sqlite3:fold-row newproc init conn stmt params))) ;; (fold-row PROC INIT DATABASE SQL . PARAMETERS)
      ((pg)          (pg:row-fold proc init (exec dbh stmt params)))
      ((mysql)       (fold proc '() (get-rows dbh stmt)))
      (else          (error "Unsupported dbtype" dbtype)))))

(define (map-row proc init dbh stmt . params)
  (let ((dbtype (db-dbtype dbh))
  (conn   (db-conn dbh)))
    (case dbtype
      ((sqlite3) (apply sqlite3:map-row proc conn stmt params))
      ((pg) (pg:row-map proc (exec dbh stmt params)))
      ((mysql) (map proc (get-rows dbh stmt)))
      (else (error "Unsupported dbtype" dbtype)))))

(define (prepare-exec stmth . params)
  (if (sqlite3:statement? stmth)
        (apply sqlite3:execute stmth params))
  (if (pair? stmth)
    (let* ((dbh (car (car stmth)))
          (dbtype (db-dbtype dbh))
          (conn   (db-conn dbh))
          (stmth-name (string->symbol (cdr (car stmth)))))
        (apply pg:query conn stmth-name params))))

(define (get-res handle option)
  (if (pg:result? handle)
      (case option
        ((affected-rows) (pg:affected-rows handle)))))
      
(define (close dbh)
  (cond
   ((database? dbh)
    (let ((dbtype (db-dbtype dbh))
 	  (conn   (db-conn dbh)))
      (case dbtype
	((sql-de-lite) (sql:close-database conn))
	((sqlite3)     (sqlite3:finalize! conn)) 
	((pg)          (pg:disconnect conn))
	((mysql)       (void)) ; The mysql-client egg doesn't support closing...
	(else (error "Unsupported dbtype " dbtype)))))
   ((pair? dbh)
    (let ((stmt (conc "DEALLOCATE " (cdr (car dbh)) ";")))
      (exec (car (car dbh)) stmt)))
   ((sqlite3:statement? dbh) ;; do this last so that *IF* it is a proper dbh it will be closed above and the sqlite3:statement? will not be called
    (sqlite3:finalize! dbh))
   
   ))

;;======================================================================
;; D B   M I S C
;;======================================================================

(define (escape-string str)
      (let ((parts (split-string str "'")))
	(string-intersperse parts "''")))
;;      (pg:escape-string val)))

;; convert values to appropriate strings
;;
(define (sqlparam-val->string val)
  (cond
   ((list?   val)(string-intersperse (map conc val) ",")) ;; (a b c) => a,b,c
   ((string? val)(string-append "'" (escape-string val) "'"))
   ((sql-null? val) "NULL")
   ((number? val)(number->string val))
   ((symbol? val)(sqlparam-val->string (symbol->string val)))
   ((boolean? val)
    (if val "TRUE" "FALSE"))  ;; should this be "TRUE" or 1?
                              ;; should this be "FALSE" or 0 or NULL?
   ((vector? val) ;; 'tis a date NB// 5/29/2011 - this is badly borked BUGGY!
    (sqlparam-val->string (time->string (seconds->local-time (current-seconds)))))
   (else
    (error "sqlparam: unknown type for value: " val)
    "")))

;; (sqlparam "INSERT INTO foo(name,age) VALUES(?,?);" "bob" 20)
;; NB// 1. values only!! 
;;      2. terminating semicolon required (used as part of logic)
;;
;; a=? 1 (number) => a=1
;; a=? 1 (string) => a='1'
;; a=? #f         => a=FALSE 
;; a=? a (symbol) => a=a 
;;
(define (sqlparam query . args)
  (let* ((query-parts (string-split query "?"))
         (num-parts    (length query-parts))
         (num-args    (length args)))
    (if (not (= (+ num-args 1) num-parts))
        (error "ERROR, sqlparam: wrong number of arguments or missing semicolon, " num-args " for query " query)
        (if (= num-args 0) query
            (let loop ((section (car query-parts))
                       (tail    (cdr query-parts))
                       (result  "")
                       (arg     (car args))
                       (argtail (cdr args)))
              (let* ((valstr    (sqlparam-val->string arg))
                     (newresult (string-append result section valstr)))
                (if (null? argtail) ;; we are done
                    (string-append newresult (car tail))
                    (loop
                     (car tail)
                     (cdr tail)
                     newresult
                     (car argtail)
                     (cdr argtail)))))))))

;; a poorly written but non-broken split-string
;;
(define (split-string strng delim)
  (if (eq? (string-length strng) 0) (list strng)
      (let loop ((head (make-string 1 (car (string->list strng))))
		 (tail (cdr (string->list strng)))
		 (dest '())
		 (temp ""))
	(cond ((equal? head delim)
	       (set! dest (append dest (list temp)))
	       (set! temp ""))
	      ((null? head) 
	       (set! dest (append dest (list temp))))
	      (else (set! temp (string-append temp head)))) ;; end if
	(cond ((null? tail)
	       (set! dest (append dest (list temp))) dest)
	      (else (loop (make-string 1 (car tail)) (cdr tail) dest temp))))))

(define (database? dbh)
  (if (db? dbh)
    (let ((dbtype (db-dbtype dbh))
    (conn   (db-conn dbh)))
      (case dbtype
        ((sqlite3)     (if (sqlite3:database? conn) #t #f))
	((sql-de-lite) #t) ;; don't know how to test for database
        ((pg) (if (pg:connection? conn) #t #f))
        ((mysql) #t)
        (else (error "Unsupported dbtype " dbtype)))) #f))

;;======================================================================
;; Convienence routines
;;======================================================================

;; make a db from a list of statements or open it if it already exists
(define (mk-db path file stmts)
  (let* ((fname    (conc path "/" file))
	 (dbexists (file-exists? fname))
	 (dbh      (if dbexists (open 'sqlite3 (list (cons 'dbname fname))) #f)))
    (if (not dbexists)
	(begin
	  (system (conc "mkdir -p " path)) ;; create the path
	  (set! dbh (open 'sqlite3 (list (cons 'dbname fname))))
	  (for-each 
	   (lambda (sqry)
	     (exec dbh sqry))
	   stmts)))
    (sqlite3:set-busy-handler!
     (db-conn dbh) (sqlite3:make-busy-timeout 1000000))
    dbh))

(define (now dbh)
  (let ((dbtype (db-dbtype dbh)))
    (case dbtype
      ((sqlite3) "datetime('now')")
      ;; Standard SQL
      (else      "now()"))))

(define (make-pgdatetime)(make-vector 7))
(define (pgdatetime-get-year          vec)    (vector-ref  vec 0))
(define (pgdatetime-get-month         vec)    (vector-ref  vec 1))
(define (pgdatetime-get-day           vec)    (vector-ref  vec 2))
(define (pgdatetime-get-hour          vec)    (vector-ref  vec 3))
(define (pgdatetime-get-minute        vec)    (vector-ref  vec 4))
(define (pgdatetime-get-second        vec)    (vector-ref  vec 5))
(define (pgdatetime-get-microsecond   vec)    (vector-ref  vec 6))
(define (pgdatetime-set-year!         vec val)(vector-set! vec 0 val))
(define (pgdatetime-set-month!        vec val)(vector-set! vec 1 val))
(define (pgdatetime-set-day!          vec val)(vector-set! vec 2 val))
(define (pgdatetime-set-hour!         vec val)(vector-set! vec 3 val))
(define (pgdatetime-set-minute!       vec val)(vector-set! vec 4 val))
(define (pgdatetime-set-second!       vec val)(vector-set! vec 5 val))
(define (pgdatetime-set-microsecond!  vec val)(vector-set! vec 6 val))

;; takes postgres date or timestamp
(define (pg-date->string pgdate)
  (conc (pgdatetime-get-month pgdate) "/"
	(pgdatetime-get-day   pgdate) "/"
	(pgdatetime-get-year  pgdate)))

;; takes postgres date or timestamp
(define (pg-datetime->string pgdate)
  (conc (pgdatetime-get-month pgdate) "/"
        (pgdatetime-get-day   pgdate) "/"
        (pgdatetime-get-year  pgdate) " "
	(pgdatetime-get-hour  pgdate) ":"
	(pgdatetime-get-minute pgdate)`))



;; map to 0 or 1 from a range of values
;;            #f => 0
;;            #t => 1
;;           "0" => 0
;;           "1" => 1
;;         FALSE => 0
;;          TRUE => 1
;; anything else => 1
(define (lazy-bool val)
  (case val
   ((#f) 0)
   ((#t) 1)
   ((0)  0)
   ((1)  1)
   (else
    (cond
     ((string? val)
      (let ((nval (string->number val)))
	(if nval 
	    (lazy-bool nval)
	    (cond
	     ((string=? val "FALSE") 0)
	     ((string=? val "TRUE")  1)
	     (else 1)))))
     ((symbol? val)
      (lazy-bool (symbol->string val)))
     (else 1)))))
)

;; Copyright 2007-2018, Matthew Welland.
;;
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;;
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

;;;; dbi.setup
(standard-extension 'dbi "0.5")

;;; dbi: Minimal gasket to postgresql, sqlite3 and mysql
;;;
;; Copyright (C) 2007-2016 Matt Welland
;; Redistribution and use in source and binary forms, with or without
;; modification, is permitted.
;;
;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
;; DAMAGE.

;; WARNING: This example is basically useless, I'll rewrite it one of these days ....

(require-library margs dbi)

(define help "help me")

(define remargs (args:get-args 
		 (argv)
		 (list "-inf")
		 (list "-h")
		 args:arg-hash
		 0))

;; define DBPATH in setup.scm
(include "setup.scm")

(define (ftf:mk-db)
  (let* ((fname    (conc DBPATH "/ftfplan.db"))
 	 (dbexists (file-exists? fname))
	 (dbh      (if dbexists (dbi:open 'sqlite3 (list (cons 'dbname fname))) #f)))
    (if (not dbexists)
	(begin
	  ;; (print "fullname: " fullname)
	  (system (conc "mkdir -p " DBPATH)) ;; create the path
	  (set! dbh (dbi:open 'sqlite3 (list (cons 'dbname fname))))
	  (for-each 
	   (lambda (sqry)
	     ;; (print sqry)
	     (dbi:exec dbh sqry))
	   ;; types: 0 text, 1 jpg, 2 png, 3 svg, 4 spreadsheet, 5 audio, 6 video :: better specs to come...
	   (list
	    "CREATE TABLE pics     (id INTEGER PRIMARY KEY,name TEXT,dat_id INTEGER,thumb_dat_id INTEGER,created_on INTEGER,owner_id INTEGER);"
	    "CREATE TABLE dats     (id INTEGER PRIMARY KEY,md5sum TEXT,dat BLOB,type INTEGER);"
	     ;; on every modification a new tiddlers entry is created. When displaying the tiddlers do:
	     ;;    select where created_on < somedate order by created_on desc limit 1
	     "CREATE TABLE tiddlers (id INTEGER PRIMARY KEY,wiki_id INTEGER,name TEXT,rev INTEGER,dat_id INTEGER,created_on INTEGER,owner_id INTEGER);"
	     ;; rev and tag only utilized when user sets a tag. All results from a select as above for tiddlers are set to the tag
	     "CREATE TABLE revs     (id INTEGER PRIMARY KEY,tag TEXT);"
	     ;; wikis is here for when postgresql support is added or if a sub wiki is created. 
	     "CREATE TABLE wikis    (id INTEGER PRIMARY KEY,key_name TEXT,title TEXT,created_on INTEGER);"))
             ))
    dbh))

(define db (ftf:mk-db))

(dbi:exec db "INSERT INTO pics (name,owner_id) VALUES ('bob',1);")
(dbi:for-each-row (lambda (row)(print "Name: " (vector-ref row 0) ", owner_id: " (vector-ref row 1)))
   db
   "SELECT name,owner_id FROM pics;")

(declare (uses tasksmod))
;; (declare (uses servermod))
;; (declare (uses testsmod))

(module dbmod
	*
	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18
	srfi-69 format ports srfi-1 matchable stack regex
(import scheme (chicken base) )
(import (prefix sqlite3 sqlite3:) typed-records srfi-18
	srfi-69 format (chicken port) srfi-1 matchable stack regex
	srfi-13 stack s11n
	(prefix base64 base64:)
	(chicken process-context posix)
	(chicken process-context)
	(chicken process) (chicken sort) (chicken file posix) (chicken time)
	(chicken time posix) (chicken pretty-print) (chicken format)
	(chicken random) (chicken pathname) system-information
	z3
	csv csv-xml
	;;csv csv-xml
	directory-utils
	call-with-environment-variables)

(import commonmod)
(import keysmod)
(import files)
(import (chicken file) (chicken condition) (chicken string))
(import tasksmod)
(import odsmod)
;; (import testsmod)
(import (prefix mtargs args:))
(import (prefix mtconfigf configf:))
;; (import servermod)

	tconf
	(let ((test-dirs (tests:get-tests-search-path *configdat*)))
	  (let loop ((hed (car test-dirs))
		     (tal (cdr test-dirs)))
	    ;; Setting MT_LINKTREE here is almost certainly unnecessary. 
	    (let ((tconfig-file (conc hed "/" test-name "/testconfig")))
	      (if (and (common:file-exists? tconfig-file)
		       (file-read-access? tconfig-file))
		       (file-readable? tconfig-file))
		  (let ((link-tree-path (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree"))
			(old-link-tree  (get-environment-variable "MT_LINKTREE")))
		    (if link-tree-path (setenv "MT_LINKTREE" link-tree-path))
		    (if link-tree-path (set-environment-variable! "MT_LINKTREE" link-tree-path))
		    (let ((newtcfg (configf:read-config tconfig-file #f #f))) ;; NOTE: Does NOT run [system ...]
		      (hash-table-set! *testconfigs* test-name newtcfg)
		      (if old-link-tree 
			  (setenv "MT_LINKTREE" old-link-tree)
			  (unsetenv "MT_LINKTREE"))
			  (set-environment-variable! "MT_LINKTREE" old-link-tree)
			  (unset-environment-variable! "MT_LINKTREE"))
		      newtcfg))
		  (if (null? tal)
		      (begin
			(debug:print-error 0 *default-log-port* "No readable testconfig found for " test-name)
			#f)
		      (loop (car tal)(cdr tal))))))))))

;; RA => Returns a db handler; sets the lock if opened in writable mode
;;
;; (define *db-open-mutex* (make-mutex))

(define (db:lock-create-open fname initproc)
  (let* ((parent-dir   (or (pathname-directory fname)(current-directory))) ;; no parent? go local
         (raw-fname    (pathname-file fname))
	 (dir-writable (file-write-access? parent-dir))
	 (dir-writable (file-writable? parent-dir))
	 (file-exists  (common:file-exists? fname))
	 (file-write   (if file-exists
			   (file-write-access? fname)
			   (file-writable? fname)
			   dir-writable )))
    ;; (mutex-lock! *db-open-mutex*) ;; tried this mutex, not clear it helped.
    (if file-write ;; dir-writable
	(condition-case
         (let* ((lockfname   (conc fname ".lock"))
                (readyfname  (conc parent-dir "/.ready-" raw-fname))
                (readyexists (common:file-exists? readyfname)))

							 
               (mtdbmodtime  (if mtdbexists (common:lazy-sqlite-db-modification-time (conc *toppath* "/megatest.db"))   #f))
	        		 (tmpdbmodtime (if dbfexists  (common:lazy-sqlite-db-modification-time tmpdbfname) #f)) 
               (mtdb         (db:open-megatest-db))
               (mtdbpath     (db:dbdat-get-path mtdb))
               (tmpdb        (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db))
               (refndb       (db:open-megatest-db path: dbpath name: "megatest_ref.db"))
               (write-access (file-write-access? mtdbpath))
               (write-access (file-writable? mtdbpath))
	       ;(mtdbmodtime  (if mtdbexists (common:lazy-sqlite-db-modification-time mtdbpath)   #f)) ; moving this before db:open-megatest-db is called. if wal mode is on -WAL and -shm file get created with causing the  tmpdbmodtime timestamp always greater than mtdbmodtime
	       ;(tmpdbmodtime (if dbfexists  (common:lazy-sqlite-db-modification-time tmpdbfname) #f)) 
					;if wal mode is on -WAL and -shm file get created when db:open-megatest-db is called. modtimedelta will always be < 10 so db in tmp not get synced
          ;(tmpdbmodtime (if dbfexists (db:get-last-update-time (car tmpdb)) #f))    
          ;(fmt (file-modification-time tmpdbfname))
	       (modtimedelta (and mtdbmodtime tmpdbmodtime (- mtdbmodtime tmpdbmodtime))))

         (dbpath       (conc  dbdir "/" (or name "megatest.db")))
	 (dbexists     (common:file-exists? dbpath))
	 (db           (db:lock-create-open dbpath
					    (lambda (db)
                                              (db:initialize-main-db db)
					      ;;(db:initialize-run-id-db db)
					      )))
	 (write-access (file-write-access? dbpath)))
	 (write-access (file-writable? dbpath)))
    (debug:print-info 13 *default-log-port* "db:open-megatest-db "dbpath)
    (if (and dbexists (not write-access))
	(set! *db-write-access* #f))
    (cons db dbpath)))

;; sync run to disk if touched
;;

;;
(define (db:repair-db dbdat #!key (numtries 1))
  (let* ((dbpath   (db:dbdat-get-path        dbdat))
	 (dbdir    (pathname-directory       dbpath))
	 (fname    (pathname-strip-directory dbpath)))
    (debug:print-info 0 *default-log-port* "Checking db " dbpath " for errors.")
    (cond
     ((not (file-write-access? dbdir))
     ((not (file-writable? dbdir))
      (debug:print 0 *default-log-port* "WARNING: can't write to " dbdir ", can't fix " fname)
      #f)

     ;; handle special cases, megatest.db and monitor.db
     ;; 
     ;;  NOPE: apply this same approach to all db files
     ;;

    ((not (sqlite3:database? (db:dbdat-get-db fromdb)))
     (debug:print-error 0 *default-log-port* "db:sync-tables called with fromdb not a database " fromdb)
     -3)
    ((not (sqlite3:database? (db:dbdat-get-db todb)))
     (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a database " todb)
     -4)

    ((not (file-write-access? (db:dbdat-get-path todb)))
    ((not (file-writable? (db:dbdat-get-path todb)))
     (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a read-only database " todb)
     -5)
    ((not (null? (let ((readonly-slave-dbs
                        (filter
                         (lambda (dbdat)
                           (not (file-write-access? (db:dbdat-get-path todb))))
                           (not (file-writable? (db:dbdat-get-path todb))))
                         slave-dbs)))
                   (for-each
                    (lambda (bad-dbdat)
                      (debug:print-error
                       0 *default-log-port* "db:sync-tables called with todb not a read-only database " bad-dbdat))
                    readonly-slave-dbs)
                   readonly-slave-dbs))) -6)

	(debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling END" )
	res)
      #f))

#;(define (open-run-close-exception-handling proc idb . params)
  (handle-exceptions
   exn
   (let ((sleep-time (random 30))
   (let ((sleep-time (pseudo-random-integer 30))
	 (err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
     (case err-status
       ((busy)
	(thread-sleep! sleep-time))
       (else
	(debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable.")
	(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))

(define (tdb:get-prev-tol-for-test tdb test-id category variable)
  ;; Finish me?
  (values #f #f #f))


(define (db:csv->test-data dbstruct run-id test-id csvdata)
#;(define (db:csv->test-data dbstruct run-id test-id csvdata)
  (debug:print 4 *default-log-port* "test-id " test-id ", csvdata: " csvdata)
  (db:with-db
   dbstruct #f #f
   (lambda (db)
     (let* ((csvlist (csv->list (make-csv-reader
				 (open-input-string csvdata)
				 '((strip-leading-whitespace? #t)

  (let* ((keysstr  (string-intersperse (map car keypatt-alist) ","))
	 (keyqry   (string-intersperse (map (lambda (p)(conc (car p) " LIKE ? ")) keypatt-alist) " AND "))
	 (numkeys  (length keypatt-alist))
	 (test-ids '())
	 (dbdat    (db:get-db dbstruct))
	 (db       (db:dbdat-get-db dbdat))
	 (windows  (and pathmod (substring-index "\\" pathmod)))
	 (tempdir  (conc "/tmp/" (current-user-name) "/" runspatt "_" (random 10000) "_" (current-process-id)))
	 (tempdir  (conc "/tmp/" (current-user-name) "/" runspatt "_" (pseudo-random-integer 10000) "_" (current-process-id)))
	 (runsheader (append (list "Run Id" "Runname") ; 0 1
			     (map car keypatt-alist)   ; + N = length keypatt-alist
			     (list "Testname"          ; 2
				   "Item Path"         ; 3 
				   "Description"       ; 4 
				   "State"             ; 5 
				   "Status"            ; 6  

			test-name     " "
			item-path     " " ;; has / prepended to deal with toplevel tests
			actual-state  " "
			actual-status " "
			event-time
			))
	 (prev-nbfake-log (get-environment-variable "NBFAKE_LOG")))
    (setenv "NBFAKE_LOG" (conc (cond
    (set-environment-variable! "NBFAKE_LOG" (conc (cond
				((and (directory-exists? test-rundir)
				      (file-write-access? test-rundir))
				      (file-writable? test-rundir))
				 test-rundir)
				((and (directory-exists? *toppath*)
				      (file-write-access? *toppath*))
				      (file-writable? *toppath*))
				 *toppath*)
				(else (conc "/tmp/" (current-user-name))))
			       "/" logname))
    (debug:print-info 0 *default-log-port* "TRIGGERED on " trigger ", running command " fullcmd " output at " (get-environment-variable "NBFAKE_LOG"))
    ;; (call-with-environment-variables
    ;;  `(("NBFAKE_LOG" . ,(conc test-rundir "/" logname)))
    ;;  (lambda ()
    (process-run fullcmd)
    (if prev-nbfake-log
	(setenv "NBFAKE_LOG" prev-nbfake-log)
	(unsetenv "NBFAKE_LOG"))
	(set-environment-variable! "NBFAKE_LOG" prev-nbfake-log)
	(unset-environment-variable! "NBFAKE_LOG"))
    )) ;; ))

(define (mt:process-triggers dbstruct run-id test-id newstate newstatus)
  (if test-id 
      (let* ((test-dat      (db:get-test-info-by-id dbstruct run-id test-id)))
	(if test-dat
	    (let* ((test-rundir   (db:test-get-rundir       test-dat)) ;; ) ;; )

(declare (uses rmtmod))
(declare (uses dbmod))
(declare (uses servermod))

(module dcommonmod
	*
	
(import scheme chicken data-structures extras)
(import scheme chicken.bitwise chicken.pathname chicken.process-context.posix chicken.condition chicken.sort chicken.process chicken.pretty-print  chicken.base chicken.string chicken.time chicken.file.posix chicken.process-context)
(import (prefix sqlite3 sqlite3:)
	posix typed-records srfi-18 srfi-69 format ports srfi-1
	typed-records srfi-18 srfi-69 chicken.format chicken.port srfi-1
	matchable (prefix iup iup:)
	canvas-draw
	;; blindly copied from megamod
	(prefix base64 base64:)
	(prefix dbi dbi:)
	(prefix nanomsg nmsg:)
	;; (prefix nanomsg nmsg:)
	(prefix sqlite3 sqlite3:)
	call-with-environment-variables
	csv
	csv-xml
	data-structures
	;;csv
	;;csv-xml
	;;data-structures
	directory-utils
	dot-locking
	extras
	files
	;;extras
	chicken.file
	chicken.random
	fmt
	format
	chicken.format
	hostinfo
	http-client
	intarweb
	irregex
	chicken.irregex
	matchable
	md5
	message-digest
	pathname-expand
	pkts
	ports
	chicken.port
	posix
	;; queue
	regex
	regex-case
	s11n
	sparse-vectors
	spiffy
	spiffy-directory-listing
	spiffy-request-vars
	sql-de-lite
	srfi-1
	srfi-4
	srfi-13
	srfi-18
	srfi-69
	stack
	stml2
	tcp
	;;tcp
	typed-records
	udp
	;;udp
	uri-common
	z3
	)

(import (prefix mtconfigf configf:))
(import gutilsmod)
(import commonmod)
(import servermod)
(import testsmod)
(import megamod)
(import subrunmod)
(import runsmod)
(import rmtmod)
(import dbmod)
(import canvas-draw)
(import canvas-draw-iup)
(use (prefix iup iup:))
(import (prefix iup iup:))
(import (prefix mtargs args:))

(define *tim* (iup:timer))

;; (use (prefix ulex ulex:))

(include "common_records.scm")

all : module-hierarchy.pdf

deps.data : ../../*scm
	cd ../..;csi -bq utils/deps.scm > docs/code/deps.data

module-hierarchy.dot : preamble.dot deps.data postamble.dot
	cat preamble.dot deps.data postamble.dot > module-hierarchy.dot

module-hierarchy.pdf : module-hierarchy.dot
	dot -Tpdf module-hierarchy.dot -o module-hierarchy.pdf

  node [shape=box,style=filled,fontname="clear",fontsize="10"];

  subgraph cluster_megatest {
    label="megatest";

    rmtmod [label="rmt mod"];
    // httpmod [label="http-transportmod"];
    // commonmod
// archivemod.scm
"commonmod" -> "archivemod";
// clientmod.scm
"commonmod" -> "clientmod";
// configfmod.scm
// subrunmod.scm
"commonmod" -> "subrunmod";
// ezstepsmod.scm
"commonmod" -> "ezstepsmod";
// itemsmod.scm
"commonmod" -> "itemsmod";
// gutilsmod.scm
// template-mod.scm
"sqlite3" -> "template-mod";
"commonmod" -> "template-mod";
// http-transportmod.scm
"commonmod" -> "http-transportmod";
"stml2" -> "http-transportmod";
"apimod" -> "http-transportmod";
"dbmod" -> "http-transportmod";
"testsmod" -> "http-transportmod";
"mtargs" -> "http-transportmod";
"mtconfigf" -> "http-transportmod";
// apimod.scm
"sqlite3" -> "apimod";
"commonmod" -> "apimod";
"dbmod" -> "apimod";
"servermod" -> "apimod";
// launchmod.scm
"sqlite3" -> "launchmod";
"commonmod" -> "launchmod";
// keysmod.scm
"sqlite3" -> "keysmod";
"srfi-13" -> "keysmod";
// testsmod.scm
"sqlite3" -> "testsmod";
"commonmod" -> "testsmod";
"servermod" -> "testsmod";
"itemsmod" -> "testsmod";
"dbmod" -> "testsmod";
// runconfigmod.scm
"commonmod" -> "runconfigmod";
// keysmod.scm
"srfi-13" -> "keysmod";
// launchmod.scm
"commonmod" -> "launchmod";
"mtconfigf" -> "testsmod";
"mtargs" -> "testsmod";
// vgmod.scm
"sqlite3" -> "vgmod";
// clientmod.scm
"sqlite3" -> "clientmod";
"commonmod" -> "clientmod";
// megamod.scm
"mtconfigf" -> "megamod";
"spiffy" -> "megamod";
"stml2" -> "megamod";
"mtargs" -> "megamod";
"commonmod" -> "megamod";
"keysmod" -> "megamod";
"pgdbmod" -> "megamod";
"tasksmod" -> "megamod";
"dbmod" -> "megamod";
"apimod" -> "megamod";
"ducttape-lib" -> "megamod";
"itemsmod" -> "megamod";
"pkts" -> "megamod";
"rmtmod" -> "megamod";
"mtmod" -> "megamod";
"testsmod" -> "megamod";
"servermod" -> "megamod";
"subrunmod" -> "megamod";
"itemsmod" -> "megamod";
"runsmod" -> "megamod";
// odsmod.scm
"commonmod" -> "odsmod";
// envmod.scm
"commonmod" -> "envmod";
// http-transportmod.scm
"commonmod" -> "http-transportmod";
"stml2" -> "http-transportmod";
"apimod" -> "http-transportmod";
"dbmod" -> "http-transportmod";
"testsmod" -> "http-transportmod";
// processmod.scm
// subrunmod.scm
"sqlite3" -> "subrunmod";
"commonmod" -> "subrunmod";
"mtconfigf" -> "subrunmod";
// tasksmod.scm
"sqlite3" -> "tasksmod";
"commonmod" -> "tasksmod";
"mtconfigf" -> "tasksmod";
"pgdbmod" -> "tasksmod";
// dbmod.scm
"sqlite3" -> "dbmod";
"commonmod" -> "dbmod";
"keysmod" -> "dbmod";
"files" -> "dbmod";
"tasksmod" -> "dbmod";
"odsmod" -> "dbmod";
"mtargs" -> "dbmod";
"mtconfigf" -> "dbmod";
// servermod.scm
"sqlite3" -> "servermod";
"commonmod" -> "servermod";
"dbmod" -> "servermod";
"tasksmod" -> "servermod";
"mtargs" -> "servermod";
"mtconfigf" -> "servermod";
// ezstepsmod.scm
"sqlite3" -> "ezstepsmod";
"commonmod" -> "ezstepsmod";
// odsmod.scm
"sqlite3" -> "odsmod";
"commonmod" -> "odsmod";
// mtmod.scm
"sqlite3" -> "mtmod";
"mtargs" -> "mtmod";
"mtconfigf" -> "mtmod";
"commonmod" -> "mtmod";
"dbmod" -> "mtmod";
"pgdbmod" -> "mtmod";
"rmtmod" -> "mtmod";
"servermod" -> "mtmod";
"stml2" -> "mtmod";
"subrunmod" -> "mtmod";
"tasksmod" -> "mtmod";
"testsmod" -> "mtmod";
// pgdbmod.scm
"commonmod" -> "pgdbmod";
// treemod.scm
"iup" -> "treemod";
// itemsmod.scm
"sqlite3" -> "itemsmod";
"commonmod" -> "itemsmod";
// runsmod.scm
"base64" -> "runsmod";
"commonmod" -> "runsmod";
"dbmod" -> "runsmod";
"itemsmod" -> "runsmod";
"mtmod" -> "runsmod";
"pgdbmod" -> "runsmod";
"mtargs" -> "runsmod";
"mtconfigf" -> "runsmod";
"rmtmod" -> "runsmod";
"servermod" -> "runsmod";
"stml2" -> "runsmod";
"subrunmod" -> "runsmod";
"tasksmod" -> "runsmod";
"testsmod" -> "runsmod";
// apimod.scm
// processmod.scm
"commonmod" -> "apimod";
"dbmod" -> "apimod";
"sqlite3" -> "processmod";
"servermod" -> "apimod";
// dbmod.scm
// rmtmod.scm
"commonmod" -> "dbmod";
"keysmod" -> "dbmod";
"files" -> "dbmod";
"sqlite3" -> "rmtmod";
"tasksmod" -> "dbmod";
"odsmod" -> "dbmod";
// dcommonmod.scm
"gutilsmod" -> "dcommonmod";
"commonmod" -> "dcommonmod";
"testsmod" -> "dcommonmod";
"megamod" -> "dcommonmod";
"canvas-draw" -> "dcommonmod";
"canvas-draw-iup" -> "dcommonmod";
// tasksmod.scm
"commonmod" -> "tasksmod";
"pgdbmod" -> "tasksmod";
// template-mod.scm
"commonmod" -> "template-mod";
// servermod.scm
"commonmod" -> "servermod";
"dbmod" -> "servermod";
"tasksmod" -> "servermod";
// treemod.scm
// commonmod.scm
"pkts" -> "commonmod";
// vgmod.scm
// rmtmod.scm
"ulex" -> "rmtmod";
"commonmod" -> "rmtmod";
"itemsmod" -> "rmtmod";
"apimod" -> "rmtmod";
"dbmod" -> "rmtmod";
// commonmod.scm
"sqlite3" -> "commonmod";
"pkts" -> "commonmod";
"mtconfigf" -> "commonmod";
"mtargs" -> "commonmod";
// pgdbmod.scm
"mtconfigf" -> "pgdbmod";
"mtargs" -> "pgdbmod";
"commonmod" -> "pgdbmod";
// envmod.scm
"sqlite3" -> "envmod";
"commonmod" -> "envmod";
// configfmod.scm
"sqlite3" -> "configfmod";
// dcommonmod.scm
"sqlite3" -> "dcommonmod";
"mtconfigf" -> "dcommonmod";
"gutilsmod" -> "dcommonmod";
"commonmod" -> "dcommonmod";
"servermod" -> "dcommonmod";
"testsmod" -> "dcommonmod";
"megamod" -> "dcommonmod";
"subrunmod" -> "dcommonmod";
"runsmod" -> "dcommonmod";
"rmtmod" -> "dcommonmod";
"dbmod" -> "dcommonmod";
"canvas-draw" -> "dcommonmod";
"canvas-draw-iup" -> "dcommonmod";
"iup" -> "dcommonmod";
"mtargs" -> "dcommonmod";
// gutilsmod.scm
"iup" -> "gutilsmod";
"canvas-draw" -> "gutilsmod";
// runconfigmod.scm
"sqlite3" -> "runconfigmod";
"commonmod" -> "runconfigmod";
// archivemod.scm
"sqlite3" -> "archivemod";
"commonmod" -> "archivemod";
    
}
  
}

    
}
  
}

//  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/>.
// 
digraph megatest_code_hierarchy {
  ranksep=0.05;
  // rankdir=LR

  node [shape=box,style=filled,fontname="clear",fontsize="10"];

  subgraph cluster_megatest {
    label="megatest";

    rmtmod [label="rmt mod"];

     current-wwdate
     current-isodate
     *this-exe-dir*
     *this-exe-name*
     *this-exe-fullpath*
     )

  (import scheme chicken extras ports data-structures )
  (use posix regex ansi-escape-sequences test srfi-1 irregex slice srfi-13 rfc3339)
  (import scheme chicken.base chicken.port chicken.process chicken.io chicken.pathname chicken.process-context chicken.time chicken.process chicken.condition chicken.time.posix chicken.process-context.posix chicken.format chicken.file.posix)
  (import regex ansi-escape-sequences test srfi-1 chicken.irregex slice srfi-13 rfc3339)
  ;;scsh-process ;; dropping scsh-process, it was clobbering posix's process and process*
  (use directory-utils uuid-lib filepath srfi-19 ) ; linenoise
  ;;(import directory-utils uuid-lib filepath srfi-19 ) ; linenoise
  (import directory-utils filepath srfi-19 ) ; linenoise

    ;; plugs a hole in posix-extras in latter chicken versions
  (use posix-extras pathname-expand files)
  (import pathname-expand chicken.file chicken.string)
  (define ##sys#expand-home-path pathname-expand)
  (define (realpath x) (resolve-pathname  (pathname-expand (or x "/dev/null")) ))
  (define (realpath x) (print "Path: " x) (normalize-pathname  (pathname-expand (or x "/dev/null")) ))
  ;;(define (realpath x) (pathname-expand (or x "/dev/null")))

  ;; (include "mimetypes.scm") ; provides ext->mimetype
  ;; (include "workweekdate.scm")

  ;; gathered from macosx:
;;   cat /etc/apache2/mime.types | grep -v '^#' | perl -ne 'print "(\"$2\" . \"$1\")\n" if /(\S+)\s+(\S+)/' > mimetypes.scm
;; + manual manipulation

("wmx" . "video/x-ms-wmx")
("wvx" . "video/x-ms-wvx")
("avi" . "video/x-msvideo")
("movie" . "video/x-sgi-movie")
("smv" . "video/x-smv")
("ice" . "x-conference/x-cooltalk")))

(use srfi-19)
(use test)
(import srfi-19)
(import test)
;;(use format)
(use regex)
(import regex)
;(declare (unit wwdate))
;; utility procedures to convert among
;; different ways to express date (wwdate, seconds since epoch, isodate)
;;
;; samples:
;; isodate   -> "2016-01-01"
;; wwdate -> "16ww01.5"

      (let loop ((rest-path-items path-items))
        (if (null? rest-path-items)
            #f
            (let* ((this-dir (car rest-path-items))
                   (next-rest (cdr rest-path-items))
                   (candidate (conc this-dir "/" exe)))
              (if (file-execute-access? candidate)
              (if (file-executable? candidate)
                  candidate
                  (loop next-rest)))))))


  
;;;; define some handy globals
  ;; resolve fullpath to this script or binary.

     (let ( (raw-debug-level (get-environment-variable "DUCTTAPE_DEBUG_LEVEL")) )
       (if raw-debug-level
           (let ((num-debug-level (runs-ok (string->number raw-debug-level))))
             (if (integer? num-debug-level)
                 (begin
                   (let ((new-num-debug-level (- num-debug-level 1)))
                     (if (> new-num-debug-level 0) ;; decrement
                         (setenv "DUCTTAPE_DEBUG_LEVEL" (number->string new-num-debug-level))
                         (unsetenv "DUCTTAPE_DEBUG_LEVEL")))
                         (set-environment-variable! "DUCTTAPE_DEBUG_LEVEL" (number->string new-num-debug-level))
                         (unset-environment-variable! "DUCTTAPE_DEBUG_LEVEL")))
                   num-debug-level) ; it was set and > 0, mode is value
                 (begin
                   (unsetenv "DUCTTAPE_DEBUG_LEVEL") ;; value was invalid, unset it
                   (unset-environment-variable! "DUCTTAPE_DEBUG_LEVEL") ;; value was invalid, unset it
                   #f))) ; value was invalid, mode is f
           #f)))) ; var not set, mode is f


  (define ducttape-debug-mode (if (ducttape-debug-level)  #t  #f))

  ;; ducttape-debug-regex-filter suppresses non-matching debug messages

            " "))
          (pwd (or (get-environment-variable "PWD") "nopwd"))
          (user (or (get-environment-variable "USER") "nouser"))
          (host (or (get-environment-variable "HOST") "nohost")))
      (if logfile
          (begin
            (ducttape-log-file logfile)
            (setenv "DUCTTAPE_LOG_FILE" (ducttape-log-file))))
            (set-environment-variable! "DUCTTAPE_LOG_FILE" (ducttape-log-file))))
      (ducttape-append-logfile 'note (format #f "START - pid=~A ppid=~A argv=(~A) pwd=~A user=~A host=~A" pid ppid argv pwd user host) #t)))         


  ;; log exit code
  (define (set-ducttape-log-exit-handler)
    (let ((orig-exit-handler (exit-handler)))
      (exit-handler 

                    )

    (define (sendmail-proc sendmail-port)
      (define (wl line-str)
        (write-line line-str sendmail-port))

      (define (get-uuid)
	"foo")
        (string-upcase (uuid->string (uuid-generate))))
        ;;(string-upcase (uuid->string (uuid-generate))))

      (let ((mailpart-uuid (get-uuid))
            (mailpart-body-uuid (get-uuid)))
        
        (define (boundary)
          (wl (conc "--" mailpart-uuid)))

  ;; are sure they can coexist.
  (define (ducttape-process-command-line)

    ;; --quiet
    (let ((quiet-opts (skim-cmdline-opts-noarg-by-regex "--?quiet")))
      (if (not (null? quiet-opts))
          (begin
            (setenv "DUCTTAPE_QUIET_MODE" "1")
            (set-environment-variable! "DUCTTAPE_QUIET_MODE" "1")
            (ducttape-quiet-mode "1"))))

    ;; --silent
    (let ((silent-opts (skim-cmdline-opts-noarg-by-regex "--?silent")))
      (if (not (null? silent-opts))
          (begin
            (setenv "DUCTTAPE_SILENT_MODE" "1")
            (set-environment-variable! "DUCTTAPE_SILENT_MODE" "1")
            (ducttape-silent-mode "1"))))

    ;; -color
    (let ((color-opts (skim-cmdline-opts-noarg-by-regex "--?colou?r(ize)?")))
      (if (not (null? color-opts))
          (begin
            (setenv "DUCTTAPE_COLORIZE" "1")
            (set-environment-variable! "DUCTTAPE_COLORIZE" "1")
            (ducttape-color-mode "1"))))

    ;; -nocolor
    (let ((nocolor-opts (skim-cmdline-opts-noarg-by-regex "--?nocolou?r(ize)?")))
      (if (not (null? nocolor-opts))
          (begin
            (unsetenv "DUCTTAPE_COLORIZE" )
            (unset-environment-variable! "DUCTTAPE_COLORIZE" )
            (ducttape-color-mode #f))))

    ;; -logfile
    (let ((logfile-opts (skim-cmdline-opts-withargs-by-regex "--?log(-?file)?")))
      (if (not (null? logfile-opts))
          (begin
            (ducttape-log-file (car (reverse logfile-opts)))
            (setenv "DUCTTAPE_LOG_FILE" (ducttape-log-file)))))
            (set-environment-variable! "DUCTTAPE_LOG_FILE" (ducttape-log-file)))))

    ;; -d -dd -d#
    (let ((debug-opts (skim-cmdline-opts-noarg-by-regex "-d(d*|\\d+)"))
          (initial-debuglevel (if (ducttape-debug-level) (ducttape-debug-level) 0) ))
      (if (not (null? debug-opts))
          (begin
            (ducttape-debug-level
             (let loop ((opts debug-opts) (debuglevel initial-debuglevel))
               (if (null? opts)
                   debuglevel
                   (let*
                       ( (curopt (car opts))
                         (restopts (cdr opts))
                         (ds (string-match "-(d+)" curopt))
                         (dnum (string-match "-d(\\d+)" curopt)))
                     (cond
                      (ds (loop restopts (+ debuglevel (string-length (cadr ds)))))
                      (dnum  (loop restopts (string->number (cadr dnum)))))))))
            (setenv "DUCTTAPE_DEBUG_LEVEL" (number->string (ducttape-debug-level))))))
            (set-environment-variable! "DUCTTAPE_DEBUG_LEVEL" (number->string (ducttape-debug-level))))))


    ;; -dp <pat> / --debug-pattern <pat>
    (let ((debugpat-opts (skim-cmdline-opts-withargs-by-regex "--?(debug-pattern|dp)")))
      (if (not (null? debugpat-opts))
          (begin
            (ducttape-debug-regex-filter (string-join debugpat-opts "|"))
            (setenv "DUCTTAPE_DEBUG_PATTERN" (ducttape-debug-regex-filter)))))) 
            (set-environment-variable! "DUCTTAPE_DEBUG_PATTERN" (ducttape-debug-regex-filter)))))) 


  ;;; following code commented out; side effects not wanted on startup
  ;; immediately activate logfile (will be noop if logfile disabled)
  ;;(ducttape-activate-logfile)
  ;;(set-ducttape-log-exit-handler)
  

;;     (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)))
    (set-environment-variable! 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)

(declare (unit envmod))
(declare (uses commonmod))

(module envmod
	*
	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
(import scheme (chicken base))
(import (prefix sqlite3 sqlite3:) typed-records srfi-18 srfi-69 format (chicken port) srfi-1 matchable)
(import commonmod)
;; (use (prefix ulex ulex:))

(include "common_records.scm")


)

(declare (unit ezstepsmod))
(declare (uses commonmod))

(module ezstepsmod
	*
	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
(import scheme (chicken base))
(import (prefix sqlite3 sqlite3:) typed-records srfi-18 srfi-69 format (chicken port) srfi-1 matchable)
(import commonmod)
;; (use (prefix ulex ulex:))

(include "common_records.scm")


)

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

(require-library iup)
(import (prefix iup iup:))
(use canvas-draw)
(import canvas-draw)

(use srfi-1 regex regex-case srfi-69)
(declare (unit gutilsmod))

(module gutilsmod
  *

(import  scheme chicken data-structures extras srfi-1)
(import  scheme chicken.base chicken.string srfi-1)
(include "gutils-inc.scm")
)

(declare (uses mtargs))
(declare (uses mtconfigf))
(declare (uses testsmod))

(module apimod
	*
	
(import scheme chicken data-structures extras posix files
(import scheme (chicken base) (chicken file)
	srfi-13 srfi-18 spiffy http-client
	spiffy-directory-listing
	spiffy-request-vars tcp
	)
(import commonmod)
(import stml2)
(import apimod)

(declare (unit itemsmod))
(declare (uses commonmod))
(declare (uses mtconfigf))

(module itemsmod
	*
	
(import scheme chicken data-structures extras)
(use (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
(import scheme (chicken base) chicken.pretty-print chicken.string)
(import (prefix sqlite3 sqlite3:) typed-records srfi-18 srfi-69 format (chicken port) srfi-1 matchable)
(import commonmod)
(import(prefix mtconfigf configf:))
;; (use (prefix ulex ulex:))

;; (include "common_records.scm")
;; (include "items-inc.scm")

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

(declare (unit keysmod))

(module keysmod
	*
	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
(import scheme (chicken base) )
(import (prefix sqlite3 sqlite3:) typed-records srfi-18 srfi-69 format (chicken port) srfi-1 matchable)
;; (import commonmod)

;; (use (prefix ulex ulex:))
(import srfi-13)

;; (include "common_records.scm")

(declare (unit launchmod))

(declare (uses commonmod))

(module launchmod
	*
	
(import scheme chicken data-structures extras files)
(import (prefix sqlite3 sqlite3:) posix typed-records
	srfi-18 srfi-69 format ports srfi-1 matchable
(import scheme chicken.base chicken.file)
(import (prefix sqlite3 sqlite3:) typed-records
	srfi-18 srfi-69 chicken.format chicken.port srfi-1 matchable
	z3 (prefix base64 base64:) regex
	call-with-environment-variables csv)
	call-with-environment-variables)
(import commonmod)

)

(declare (uses subrunmod))
(declare (uses itemsmod))
(declare (uses runsmod))

(module megamod
	*
	
(import scheme chicken data-structures extras)
(use 
(import scheme chicken.base)
(import 
 (prefix base64 base64:)
 (prefix dbi dbi:)
 (prefix nanomsg nmsg:)
;; (prefix nanomsg nmsg:)
 (prefix sqlite3 sqlite3:)
 call-with-environment-variables
 csv
 csv-xml
 data-structures
 ;;csv
 ;;csv-xml
 ;;data-structures
 directory-utils
 dot-locking
 extras
 files
 ;;extras
 chicken.file
 chicken.condition 
 chicken.process-context 
 chicken.process-context.posix 
 chicken.process
 chicken.random
 chicken.string
 fmt
 format
 chicken.format
 system-information
 hostinfo
 http-client
 intarweb
 irregex
 chicken.irregex
 matchable
 md5
 message-digest
 pathname-expand
 ;; pkts
 ports
 chicken.port
 posix
 ;; queue
 regex
 regex-case
 s11n
 sparse-vectors
 spiffy
 spiffy-directory-listing
 spiffy-request-vars
 sql-de-lite
 srfi-1
 srfi-4
 srfi-13
 srfi-18
 srfi-69
 stack
 tcp
 ;;tcp
 typed-records
 udp
 ;;udp
 uri-common
 z3
 )

(import (prefix mtconfigf configf:))
(define read-config configf:read-config)
(define find-and-read-config configf:find-and-read-config)

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

;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)

(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:)
     readline apropos json http-client directory-utils typed-records
     http-client srfi-18 extras format)
(import (prefix sqlite3 sqlite3:) srfi-1 regex regex-case srfi-69 (prefix base64 base64:)
     breadline apropos json http-client directory-utils typed-records
     http-client srfi-18 chicken.format tcp6)

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

(declare (uses mtargs))
(declare (uses mtconfigf))

	    ;; (exit)
	    ;; EOF

	    (repl))
	   (else
	    (begin
	      (set! *db* dbstruct)
	      (import extras) ;; might not be needed
	      ;; (import csi)
	      (import readline)
	      (import breadline)
	      (import apropos)
	      (import dbmod)
	      (import rmtmod)
	      (import commonmod)
	      ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...

	      (if *use-new-readline*

     usage
     get-args
     print-args
     any-defined?
     help
     )

(import scheme chicken data-structures extras posix ports files)
(use srfi-69 srfi-1)
(import scheme (chicken base) (chicken port) (chicken file) (chicken process-context))
(import srfi-69 srfi-1)

(define arg-hash (make-hash-table))
(define help "")

(define (get-arg arg . default)
  (if (null? default)
      (hash-table-ref/default arg-hash arg #f)

	 get-eval-string
         squelch-debug-prints
	 ;; misc
	 realpath
	 find-chicken-lib
         )

(import scheme chicken data-structures extras ports files)
(use posix typed-records srfi-18 pathname-expand posix-extras)
(use regex regex-case srfi-69 srfi-1 directory-utils extras srfi-13 )
(use srfi-69)
(import posix)
(import scheme (chicken base) (chicken string) (chicken file) (chicken port))
(import typed-records srfi-18 pathname-expand)
(import regex regex-case srfi-69 srfi-1 directory-utils srfi-13 )
(import (chicken io) (chicken condition) (chicken process-context))
(import (chicken process) (chicken pathname) (chicken pretty-print) (chicken time))
(import srfi-69 (chicken platform) (chicken sort))

;; stub debug printers overridden by set-debug-printers
(define (debug:print n e . args)
  (apply print args))
(define (debug:print-info n e . args)
  (apply print "INFO: " args))
(define (debug:print-error n e . args)
  (apply print "ERROR: " args))

;;(import (prefix mtdebug debug:))
;;(define args:any? args:any-defined?) ;; cannot name it any? in mtargs module


;; FROM common.scm
;;
;; this plugs a hole in posix-extras in recent chicken versions > 4.9)
(let-values (( (chicken-release-number chicken-major-version)
               (apply values
                      (map string->number
                           (take
                            (string-split (chicken-version) ".")
                            2)))))
  (if (or (> chicken-release-number 4)
	  (and (eq? 4 chicken-release-number) (> chicken-major-version 9)))
      (define ##sys#expand-home-path pathname-expand)))
;;;(let-values (( (chicken-release-number chicken-major-version)
;;;               (apply values
;;;                      (map string->number
;;;                           (take
;;;                            (string-split (chicken-version) ".")
;;;                            2)))))
;;;  (if (or (> chicken-release-number 4)
;;;	  (and (eq? 4 chicken-release-number) (> chicken-major-version 9)))
;;;      (define ##sys#expand-home-path pathname-expand)))


 ;;(define (set-verbosity v)(debug:set-verbosity v))

 (define *default-log-port* (current-error-port))

 (define (debug:print-error n . args) ;;; n available to end-users but ignored for

  (if (substring-index ":" key) ;; variables containing : are for internal use and cannot be environment variables.
      (debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\"")
      (if (and (string? val)
	       (string? key))
	  (handle-exceptions
	      exn
	      (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val)
	    (setenv key val))
	    (set-environment-variable! key val))
	  (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val))))

;; accept an alist or hash table containing envvar/env value pairs (value of #f causes unset) 
;;   execute thunk in context of environment modified as per this list
;;   restore env to prior state then return value of eval'd thunk.
;;   ** this is not thread safe **
(define (with-env-vars delta-env-alist-or-hash-table thunk)
  (let* ((delta-env-alist (if (hash-table? delta-env-alist-or-hash-table)
                              (hash-table->alist delta-env-alist-or-hash-table)
                              delta-env-alist-or-hash-table))
         (restore-thunks
          (filter
           identity
           (map (lambda (env-pair)
                  (let* ((env-var     (car env-pair))
                         (new-val     (let ((tmp (cdr env-pair)))
                                        (if (list? tmp) (car tmp) tmp)))
                         (current-val (get-environment-variable env-var))
                         (restore-thunk
                          (cond
                           ((not current-val) (lambda () (unsetenv env-var)))
                           ((not current-val) (lambda () (unset-environment-variable! env-var)))
                           ((not (string? new-val)) #f)
                           ((eq? current-val new-val) #f)
                           (else 
                            (lambda () (setenv env-var current-val))))))
                            (lambda () (set-environment-variable! env-var current-val))))))
                    ;;(when (not (string? new-val))
                    ;;    (debug:print 0 *default-log-port* " PROBLEM: not a string: "new-val"\n from env-alist:\n"delta-env-alist)
                    ;;    (pp delta-env-alist)
                    ;;    (exit 1))
                        
                    
                    (cond
                     ((not new-val)  ;; modify env here
                      (unsetenv env-var))
                      (unset-environment-variable! env-var))
                     ((string? new-val)
                      (setenv env-var new-val)))
                      (set-environment-variable! env-var new-val)))
                    restore-thunk))
                delta-env-alist))))
    (let ((rv (thunk)))
      (for-each (lambda (x) (x)) restore-thunks) ;; restore env to original state
      rv)))

(define (cmd-run->list cmd #!key (delta-env-alist-or-hash-table '()))

				       (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
					     curr-section-name #f #f)))
	       (configf:script-rx ( x include-script params);; handle-exceptions
                                  ;;    exn
                                  ;;    (begin
                                  ;;      (debug:print '(0 2 9) #f "INFO: include from script " include-script " failed.")
                                  ;;      (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
                                  (if (and (safe-file-exists? include-script)(file-execute-access? include-script))
                                  (if (and (safe-file-exists? include-script)(file-executable? include-script))
                                      (let* ((local-allow-system  (calc-allow-system allow-system curr-section-name sections))
                                             (env-delta  (cfgdat->env-alist curr-section-name res local-allow-system))
                                             (new-inp-port
                                              (with-env-vars
                                               env-delta
                                               (lambda ()
                                                 (open-input-pipe (conc include-script " " params))))))

;;
(define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f)(set-fields #f)(keep-filenames #f))
  (let* ((curr-dir   (current-directory))
         (configinfo (find-config fname toppath: given-toppath))
	 (toppath    (car configinfo))
	 (configfile (cadr configinfo)))
    (if toppath (change-directory toppath)) 
    (if (and toppath pathenvvar)(setenv pathenvvar toppath))
    (if (and toppath pathenvvar)(set-environment-variable! pathenvvar toppath))
    (let ((configdat  (if configfile 
			  (read-config configfile #f #t environ-patt: environ-patt
				       post-section-procs: (if set-fields (list (cons "^fields$" set-fields)   ) '())
				       #f
                                       keep-filenames: keep-filenames))))
      (if toppath (change-directory curr-dir))
      (list configdat toppath configfile fname))))

;; reads a refdb into an assoc array of assoc arrays
;;   returns (list dat msg)
(define (read-refdb refdb-path)
  (let ((sheets-file  (conc refdb-path "/sheet-names.cfg")))
    (if (not (safe-file-exists? sheets-file))
	(list #f (conc "ERROR: no refdb found at " refdb-path))
	(if (not (file-read-access? sheets-file))
	(if (not (file-readable? sheets-file))
	    (list #f (conc "ERROR: refdb file not readable at " refdb-path))
	    (let* ((sheets (with-input-from-file sheets-file
			     (lambda ()
			       (let loop ((inl (read-line))
					  (res '()))
				 (if (eof-object? inl)
				     (reverse res)

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

;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)

(use srfi-1 posix srfi-69 readline ;;  regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras)
   srfi-19  srfi-18 extras format pkts regex regex-case
(import srfi-1 srfi-69 breadline ;;  regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras)
   srfi-19  srfi-18 chicken.format pkts regex regex-case
     (prefix dbi dbi:)
     )

;; (declare (uses common))
;; (declare (uses megatest-version))
;; (declare (uses margs))
;; (declare (uses configf))

    (begin
      (print help)
      (exit)))

(if (or (args:get-arg "-repl")
	(args:get-arg "-load"))
    (begin
      (import extras) ;; might not be needed
      ;; (import csi)
      (import readline)
      (import breadline)
      (import apropos)
      ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
      
      (install-history-file (get-environment-variable "HOME") ".mtutil_history") ;;  [homedir] [filename] [nlines])
      (current-input-port (make-readline-port "mtutil> "))
      (if (args:get-arg "-repl")
	  (repl)

(declare (uses subrunmod))
(declare (uses tasksmod))
(declare (uses testsmod))

(module mtmod
	*
	
(import scheme chicken data-structures extras posix ports files)
(import scheme chicken.base chicken.port chicken.file chicken.string)

(use (prefix sqlite3 sqlite3:)
(import (prefix sqlite3 sqlite3:)
     srfi-69 regex srfi-18 srfi-13 srfi-1
     call-with-environment-variables z3 (prefix base64 base64:)
     typed-records
     csv directory-utils)
     directory-utils)

(import	(prefix mtargs args:))
(import (prefix mtconfigf configf:))
(import	commonmod)
(import	dbmod)
(import	pgdbmod)
(import	rmtmod)

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

;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)

(use srfi-1 posix srfi-69 readline ;;  regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras)
   srfi-19  srfi-18 extras format pkts regex regex-case
(import srfi-1 srfi-69 breadline ;;  regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras)
   srfi-19  srfi-18 chicken.format pkts regex regex-case
     (prefix dbi dbi:)
     nanomsg)

;; (declare (uses common))
;; (declare (uses megatest-version))
;; (declare (uses margs))

    (begin
      (stml:main #f)
      (exit)))

(if (or (args:get-arg "-repl")
	(args:get-arg "-load"))
    (begin
      (import extras) ;; might not be needed
      ;; (import csi)
      (import readline)
      (import breadline)
      (import apropos)
      ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
      
      (install-history-file (get-environment-variable "HOME") ".mtutil_history") ;;  [homedir] [filename] [nlines])
      (current-input-port (make-readline-port "mtutil> "))
      (if (args:get-arg "-repl")
	  (repl)

;; This is from the perl world, a hash of hashes is a super easy way to keep a handle on
;; lots of disparate data
;;

(module mutils
    *

  (import chicken scheme
  (import (chicken  base) (chicken io) scheme
	  ;; data-structures posix
	  srfi-1
	  ;; srfi-13
	  srfi-69
	  ;; ports
	  extras
	  regex
	  )

(define (mutils:hierhash-ref hh . keys)
  (if (null? keys)
      #f
      (let loop ((ht   hh)

      (if (eof-object? l)
	  (reverse res)
	  (if (or (string-match comment l)
		  (string-match blank l))
	      (loop (read-line fh) res)
	      (loop (read-line fh) (cons l res)))))))

(use sparse-vectors)
(import sparse-vectors)

;; this is a simple two dimensional sparse array

;; ONLY TWO DIMENSIONS!!! SEE ARRAY-LIB IF YOUR NEEDS ARE GREATER!!
;;
(define (mutils:make-sparse-array)
  (let ((a (make-sparse-vector)))

(declare (unit odsmod))
(declare (uses commonmod))

(module odsmod
	*
	
(import scheme chicken data-structures extras csv-xml regex)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69
	format ports srfi-1 matchable srfi-13)
(import scheme (chicken base) (chicken string) (chicken port) (chicken io) (chicken file) regex)
(import (prefix sqlite3 sqlite3:) typed-records srfi-18 srfi-69
	format (chicken port) (chicken process) srfi-1 matchable srfi-13)
(import commonmod)
;; (use (prefix ulex ulex:))

(define ods:dirs
  '("Configurations2"
    "Configurations2/toolpanel"
    "Configurations2/menubar"

((license "BSD")
 (category os)
 (author "The CHICKEN team")
 (components (extension pathname-expand)))

;; -*-scheme-*-
((synopsis "Pathname expansion")
 (license "BSD")
 (category os)
 (doc-from-wiki)
 ;; No tests; this is very hard to do in a cross-platform way without
 ;; writing a reimplementation of the functionality in our tests...
 (author "The CHICKEN team"))

;;; Pathname expansion, to replace the deprecated core functionality.
;
; Copyright (c) 2014, The CHICKEN Team
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without
; modification, are permitted provided that the following conditions
; are met:
;
;   Redistributions of source code must retain the above copyright
;   notice, this list of conditions and the following disclaimer.
;
;   Redistributions in binary form must reproduce the above copyright
;   notice, this list of conditions and the following disclaimer in
;   the documentation and/or other materials provided with the
;   distribution.
;
;   Neither the name of the author nor the names of its contributors
;   may be used to endorse or promote products derived from this
;   software without specific prior written permission.
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
; OF THE POSSIBILITY OF SUCH DAMAGE.

(module pathname-expand
    (pathname-expand)

(import (chicken base) (chicken pathname) (chicken condition) (chicken platform) scheme)
(import (chicken fixnum) (chicken process-context) (chicken process-context posix))
(import srfi-13 (chicken file) )

;; Expand pathname starting with "~", and/or apply base directory to
;; relative pathname
;
; Inspired by Gambit's "path-expand" procedure.

(define pathname-expand
  (let* ((home
          ;; Effective uid might be changed at runtime so this has to
          ;; be a lambda, but we could try to cache the result on uid.
          (lambda ()
            (cond-expand
              ((and windows (not cygwin))
               (or (get-environment-variable "USERPROFILE")
                   (get-environment-variable "HOME")
                   "."))
              (else
               (let ((info (user-information (current-effective-user-id))))
                 (list-ref info 5))))))
         (slash
          (cond-expand
            ((and windows (not cygwin)) '(#\\ #\/))
            (else '(#\/))))
         (ts (string-append "~" (string (car slash))))
         (tts (string-append "~" ts)))
    (lambda (path #!optional (base (current-directory)))
      (if (absolute-pathname? path)
          path
          (let ((len (string-length path)))
            (cond
             ((or (string=? "~~" path)
                  (and (fx>= len 3) (string=? tts (substring path 0 3))))
              ;; Repository-path
              (let ((rp (repository-path)))
                (if rp
                    (string-append rp (substring path 2 len))
                    (signal
                     (make-composite-condition
                      (make-property-condition
                       'exn 'location 'pathname-expand
                       'message "No repository path defined"
                       'arguments (list path))
                      (make-property-condition 'pathname-expand)
                      (make-property-condition 'repository-path))))))
             ((or (string=? "~" path)
                  (and (fx> len 2) (string=? ts (substring path 0 2))))
              ;; Current user's home dir
              (string-append (home) (substring path 1 len)))
             ((and (fx> len 0) (char=? #\~ (string-ref path 0)))
              ;; Arbitrary user's home dir
              (let ((rest (substring path 1 len)))
                (if (and (fx> len 1) (memq (string-ref path 1) slash))
                    (string-append (home) rest)
                    (let* ((p (string-index path (lambda (c) (memq c slash))))
                           (user (substring path 1 (or p len)))
                           (info (user-information user)))
                      (if info
                          (let ((dir (list-ref info 5)))
                            (if p
                                (make-pathname dir (substring path p))
                                dir))
                          (signal
                           (make-composite-condition
                            (make-property-condition
                             'exn 'location 'pathname-expand
                             'message "Cannot expand homedir for user"
                             'arguments (list path))
                            (make-property-condition 'pathname-expand)
                            (make-property-condition 'username))))))))
             (else (make-pathname base path))))))))

)

;; -*-scheme-*-
(standard-extension 'pathname-expand 0.1)

(declare (uses mtconfigf))
(declare (uses commonmod))
(declare (uses mtargs))

(module pgdbmod
	*
	
(import scheme chicken data-structures extras files)
(use posix
(import scheme (chicken base) (chicken file) (chicken string) (chicken sort) (chicken condition) (chicken string))
(import 
     (prefix dbi dbi:)
     srfi-69 srfi-1 typed-records)

(import (prefix mtconfigf configf:))
(import	(prefix mtargs    args:))
(import	commonmod)

pktdb-pktspec

;; utility procs
increment-string ;; used to get indexes for strings in ref pkts
make-report      ;; make a .dot file 
)

(import (chicken base) scheme (chicken process) (chicken time posix) (chicken io) (chicken file))
(import chicken scheme data-structures posix srfi-1 regex srfi-13 srfi-69 ports extras)
(use crypt sha1 message-digest (prefix dbi dbi:) typed-records)
(import chicken.process-context.posix (chicken string) (chicken time) (chicken sort) (chicken file posix) (chicken condition) srfi-1 regex srfi-13 srfi-69 (chicken port) )
(import crypt sha1 message-digest (prefix dbi dbi:) typed-records)

;;======================================================================
;; DATA MANIPULATION UTILS
;;======================================================================

(define-inline (unescape-data data)
  (string-translate* data '(("\\n" . "\n") ("\\\\" . "\\"))))

     (for-each
      (lambda (pktsdir) ;; look at all
	(cond
	 ((not (file-exists? pktsdir))
	  (print "ERROR: packets directory " pktsdir " does not exist."))
	 ((not (directory? pktsdir))
	  (print "ERROR: packets directory path " pktsdir " is not a directory."))
	 ((not (file-read-access? pktsdir))
	 ((not (file-readable? pktsdir))
	  (print "ERROR: packets directory path " pktsdir " is not readable."))
	 (else
	  ;; (print "INFO: Loading packets found in " pktsdir)
	  (let ((pkts (glob (conc pktsdir "/*.pkt"))))
	    (for-each
	     (lambda (pkt)
	       (let* ((uuid    (cadr (string-match ".*/([0-9a-f]+).pkt" pkt)))

	 (exists   (common:file-exists? fname))
	 (db       (if avail 
		       (sqlite3:open-database fname)
		       (begin
			 (system (conc "rm -f " fname))
			 (sqlite3:open-database fname))))
	 (handler  (sqlite3:make-busy-timeout 136000))
	 (canwrite (file-write-access? fname)))
	 (canwrite (file-writable? fname)))
	 ;; (db-init  (lambda ()
	 ;;             (sqlite3:execute 
	 ;;              db
	 ;;              "CREATE TABLE IF NOT EXISTS ports (
         ;;                 port INTEGER PRIMARY KEY,
         ;;                 state TEXT DEFAULT 'not-used',
         ;;                 fail_count INTEGER DEFAULT 0,

  (let* ((lowport (let ((val (configf:lookup *configdat* "server" "lowport")))
		    (if (and val 
			     (string->number val))
			(string->number val)
			32768)))
	 (portnum (or (portlogger:get-prev-used-port db)
		      (+ lowport ;; top of registered ports is 49152 but lets use ports in the registered range
			 (random (- 64000 lowport))))))
			 (pseudo-random-integer (- 64000 lowport))))))
    (handle-exceptions
     exn
     (begin
       (debug:print 0 *default-log-port* "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db")
       (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
       (debug:print 5 *default-log-port* "exn=" (condition->list exn))
       (print-call-chain (current-error-port))

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

(declare (unit processmod))

(module processmod
	*
	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69
	format ports srfi-1 matchable regex directory-utils)
(import scheme (chicken base) )
(import (prefix sqlite3 sqlite3:) typed-records srfi-18 srfi-69
	format (chicken port) srfi-1 matchable regex directory-utils)

;;======================================================================
;; supporting functions
;;======================================================================

)

(declare (uses dbmod))
(declare (uses itemsmod))
(declare (uses ulex))

(module rmtmod
	*
	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
(import scheme chicken.base chicken.time chicken.string chicken.condition chicken.sort chicken.file chicken.random)
(import (prefix sqlite3 sqlite3:) typed-records srfi-18 srfi-69 chicken.format chicken.port srfi-1 matchable)

(import (prefix ulex ulex:))

(import commonmod)
(import itemsmod)
(import apimod)
(import dbmod)

;; (include "rmt-inc.scm")

;;
;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!!
;;

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

			#f)))
	  (if cinfo
	      cinfo
	      (if (server:check-if-running areapath)
		  (client:setup areapath)
		  #f))))

;; return the handle struct for sending queries to a specific database
;;  - initializes the connection object if this is the first access
;;    - finds the "captain" and asks who to talk to for the given dbfname
;;    - establishes the connection to the current dbowner
;;
(define (rmt:connect alldat dbfname dbtype)
  (let* ((ulexdat    (or (alldat-ulexdat alldat)
			 (rmt:setup-ulex alldat))))
    (ulex:connect ulexdat dbfname dbtype)))
(define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id

;; setup the remote calls
(define (rmt:setup-ulex alldat)
  (let* ((new-ulexdat (ulex:setup))) ;; establish connection to ulex
    (alldat-ulexdat-set! alldat new-ulexdat)
    (let ((udata (alldat-ulexdat alldat)))
      ;; register all needed procs
      (ulex:register-handler udata 'ping common:get-full-version)
      (ulex:register-handler udata 'login common:get-full-version) ;; force setup of the connection
      new-ulexdat)))

;; set up a connection to the current owner of the dbfile associated with rid
;; then send the query to that dbfile owner and wait for a response.
;;
(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected
  (let* ((alldat   *alldat*)
	 (areapath (alldat-areapath alldat))
	 (dbtype   (if (or (not rid)(< rid 1)) ;; this is the criteria for "main.db"
		       'main 'runs))
	 (dbfname  (if (eq? dbtype 'main)
		       "main.db"
		       (conc rid ".db")))
	 (dbfile   (conc areapath "/.db/" dbfname))
	 (ulexconn (rmt:connect alldat dbfname dbtype)))  
  (rmt:open-qry-close-locally cmd 0 params))
    (rmt:open-qry-close-locally cmd 0 params)))

;;   
;; ;; #;(common:telemetry-log (conc "rmt:"(->string cmd))
;; ;; #;(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected
;; ;; 
;; ;; #;(common:telemetry-log (conc "rmt:"(->string cmd))
;; ;; payload: `((rid . ,rid)
;; ;; (params . ,params)))

    (mutex-unlock! *db-stats-mutex*)
    res))

(define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5))
  (let* ((qry-is-write   (not (member cmd api:read-only-queries)))
	 (db-file-path   (db:dbfile-path)) ;;  0))
	 (dbstruct-local (db:setup #t))  ;; make-dbr:dbstruct path:  dbdir local: #t)))
	 (read-only      (not (file-write-access? db-file-path)))
	 (read-only      (not (file-writable? db-file-path)))
	 (start          (current-milliseconds))
	 (resdat         (if (not (and read-only qry-is-write))
			     (let ((v (api:execute-requests dbstruct-local (vector (symbol->string cmd) params))))
			       (handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong..
				exn               ;;  This is an attempt to detect that situation and recover gracefully
				(begin
				  (debug:print 0 *default-log-port* "ERROR: bad data from server " v " message: "  ((condition-property-accessor 'exn 'message) exn))

	 (duration       (- (current-milliseconds) start)))
    (if (and read-only qry-is-write)
        (debug:print 0 *default-log-port* "ERROR: attempt to write to read-only database ignored. cmd=" cmd))
    (if (not success)
	(if (> remretries 0)
	    (begin
	      (debug:print-error 0 *default-log-port* "local query failed. Trying again.")
	      (thread-sleep! (/ (random 5000) 1000)) ;; some random delay 
	      (thread-sleep! (/ (pseudo-random-integer 5000) 1000)) ;; some random delay 
	      (rmt:open-qry-close-locally cmd run-id params remretries: (- remretries 1)))
	    (begin
	      (debug:print-error 0 *default-log-port* "too many retries in rmt:open-qry-close-locally, giving up")
	      #f))
	(begin
	  ;; (rmt:update-db-stats run-id cmd params duration)
	  ;; mark this run as dirty if this was a write, the watchdog is responsible for syncing it

	       remote-ro-mode-checked-set!            remote-ro-mode-checked)

(define (rmtmod:calc-ro-mode runremote *toppath*)
  (if (and runremote
	   (remote-ro-mode-checked runremote))
      (remote-ro-mode runremote)
      (let* ((dbfile  (conc *toppath* "/megatest.db"))
	     (ro-mode (not (file-write-access? dbfile)))) ;; TODO: use dbstruct or runremote to figure this out in future
	     (ro-mode (not (file-writable? dbfile)))) ;; TODO: use dbstruct or runremote to figure this out in future
	(if runremote
	    (begin
	      (remote-ro-mode-set! runremote ro-mode)
	      (remote-ro-mode-checked-set! runremote #t)
	      ro-mode)
	    ro-mode))))

(declare (unit runconfigmod))
(declare (uses commonmod))

(module runconfigmod
	*
	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
(import scheme (chicken base) )
(import (prefix sqlite3 sqlite3:) typed-records srfi-18 srfi-69 format (chicken port) srfi-1 matchable)
(import commonmod)
;; (use (prefix ulex ulex:))

(include "common_records.scm")


)

(declare (uses tasksmod))
(declare (uses testsmod))
(declare (uses itemsmod))

(module runsmod
	*
	
(import scheme chicken data-structures extras ports files)

(use (prefix base64 base64:)
(import scheme chicken.base chicken.random chicken.port chicken.file chicken.string)
(import chicken.time chicken.condition chicken.process chicken.process-context.posix chicken.process-context)
(import system-information chicken.process.signal chicken.sort chicken.file.posix chicken.io chicken.time.posix chicken.pretty-print)
(import chicken.pathname) 
(import (prefix base64 base64:)
     (prefix sqlite3 sqlite3:)
     call-with-environment-variables
     csv
     ;;csv
     directory-utils
     format
     matchable
     message-digest
     md5
     ports
     chicken.port
     posix
     regex
     srfi-1
     srfi-1
     srfi-13
     srfi-18
     srfi-18
     srfi-69

  hed tal reg reruns  test-record
  test-name item-path jobgroup
  waitons testmode  newtal itemmaps prereqs-not-met)

(define (set-item-env-vars itemdat)
  (for-each (lambda (item)
	      (debug:print 2 *default-log-port* "setenv " (car item) " " (cadr item))
	      (setenv (car item) (cadr item)))
	      (set-environment-variable! (car item) (cadr item)))
	    itemdat))

;; Every time can-run-more-tests is called increment the delay
;;
;; NOTE: We run this server-side!! Do not use this global except in the runs:can-run-more-tests routine
;;
(define *last-num-running-tests* 0)

(define (runs:run-tests target runname test-patts user flags #!key (run-count 1)) ;; test-names
  (let* ((keys               (keys:config-get-fields *configdat*))
	 (keyvals            (keys:target->keyval keys target))
	 (run-id             (rmt:register-run keyvals runname "new" "n/a" user (args:get-arg "-contour")))  ;;  test-name)))
	 ;; (deferred          '()) ;; delay running these since they have a waiton clause
	 (runconfigf         (conc  *toppath* "/runconfigs.config"))
         (dbfile             (conc  *toppath* "/megatest.db"))
         (readonly-mode      (not (file-write-access? dbfile)))
         (readonly-mode      (not (file-writable? dbfile)))
	 (test-records       (make-hash-table))
	 ;; need to process runconfigs before generating these lists
	 (all-tests-registry #f)  ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names
	 (all-test-names     #f)  ;; (hash-table-keys all-tests-registry))
	 (test-names         #f)  ;; Generated by a call to (tests:filter-test-names all-test-names test-patts))
	 (required-tests     #f)  ;; Put fully qualified test/testpath names in this list to be done
         (waitors-upon       (make-hash-table)) ;; given a test, return list of tests waiting upon this test.

    ;;======================================================================
    
    (if (not (null? test-names)) ;; BEGIN test-names loop
	(let loop ((hed (car test-names))   ;; NOTE: This is the main loop that iterates over the test-names
		   (tal (cdr test-names)))         ;; 'return-procs tells the config reader to prep running system but return a proc
          (debug:print-info 4 *default-log-port* "\n\ntestpatt elaboration loop => hed="hed " tal="tal" test-patts="test-patts" test-names="test-names)
	  (change-directory *toppath*) ;; PLEASE OPTIMIZE ME!!! I think this should be a no-op but there are several places where change-directories could be happening.
	  (setenv "MT_TEST_NAME" hed) ;; 
	  (set-environment-variable! "MT_TEST_NAME" hed) ;; 
	  (let*-values (((waitons waitors config) (tests:get-waitons hed all-tests-registry))

			;; NOTE: Have the config - can extract [waitons] section
			
                        ((hed-mode)
                         (let ((m (configf:lookup config "requirements" "mode")))
                           (if m (map string->symbol (string-split m)) '(normal))))

     ;;       - prereqs are completed and passed (we could consider removing "and passed" -- it would change behavior from current)          
    ((or (null? prereqs-not-met)
	  (and (member 'toplevel testmode)
	       (null? non-completed)))
      (debug:print-info 4 *default-log-port* "cond branch - "  "ei-2")
      (debug:print-info 4 *default-log-port* "runs:expand-items: (or (null? prereqs-not-met) (and (member 'toplevel testmode)(null? non-completed)))")
      (let ((test-name (tests:testqueue-get-testname test-record)))
	(setenv "MT_TEST_NAME" test-name) ;; 
	(setenv "MT_RUNNAME"   runname)
	(set-environment-variable! "MT_TEST_NAME" test-name) ;; 
	(set-environment-variable! "MT_RUNNAME"   runname)
	(runs:set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process
	(let ((items-list (items:get-items-from-config tconfig)))
	  (if (list? items-list)
	      (begin
		(if (null? items-list)
		    (let ((test-id   (rmt:get-test-id run-id test-name ""))
			  (num-items (rmt:test-toplevel-num-items run-id test-name)))

     (lambda (vardat)
       (let ((var (car vardat))
	     (val (cdr vardat)))
	 (if (not (equal? (get-environment-variable var) val))
	     (handle-exceptions
	      exn
	      (debug:print-error 0 *default-log-port* "Failed to set " var " to " val)
	      (setenv var val)))))
	      (set-environment-variable! var val)))))
     all-vars)
        ))

;;======================================================================
;; END OF NEW STUFF
;;======================================================================

	 (state-status (if (string? new-state-status) (string-split new-state-status ",") '(#f #f)))
	 (rp-mutex     (make-mutex))
	 (bup-mutex    (make-mutex))
         (keep-records (args:get-arg "-keep-records"))) ;; used in conjunction with -remove-runs to keep the records, TODO: consolidate this with "mode".

    (let* ((write-access-actions '(remove-runs set-state-status archive run-wait kill-runs))
           (dbfile             (conc  *toppath* "/megatest.db"))
           (readonly-mode      (not (file-write-access? dbfile))))
           (readonly-mode      (not (file-writable? dbfile))))
      (when (and readonly-mode
                 (member action write-access-actions))
        (debug:print-error 0 *default-log-port* "megatest.db is readonly.  Cannot proceed with action ["action"] in which write-access isrequired .")
        (exit 1)))
    
    (debug:print-info 4 *default-log-port* "runs:operate-on => Header: " header " action: " action " new-state-status: " new-state-status)
    (if (> 2 (length state-status))

			    #t)
			  (process-signal pid signal/int)
			  (thread-sleep! 5)
			  (if (process:alive? pid)
			      (process-signal pid signal/kill)))))
		   ;;  (call-with-environment-variables
		   (let ((old-targethost (getenv "TARGETHOST")))
		     (setenv "TARGETHOST" hostname)
		     (setenv "TARGETHOST_LOGF" "server-kills.log")
		     (set-environment-variable! "TARGETHOST" hostname)
		     (set-environment-variable! "TARGETHOST_LOGF" "server-kills.log")
		     (system (conc "nbfake kill " pid))
		     (if old-targethost (setenv "TARGETHOST" old-targethost))
		     (unsetenv "TARGETHOST")
		     (unsetenv "TARGETHOST_LOGF"))))
		     (if old-targethost (set-environment-variable! "TARGETHOST" old-targethost))
		     (unset-environment-variable! "TARGETHOST")
		     (unset-environment-variable! "TARGETHOST_LOGF"))))
	     (debug:print-error 0 *default-log-port* "no record or improper record for " target "/" run-name " in tasks_queue in main.db"))))
     records)))

(define (task:get-run-times)
   (let* ( 
           (run-patt (if (args:get-arg "-run-patt")
                        (args:get-arg "-run-patt")

	 (maxload (if force-maxload
		      maxload-in
		      (max maxload-in 0.5))) ;; so maxload must be greater than 0.5 for now BUG - FIXME?
	 (first   (car loadavg))
	 (next    (cadr loadavg))
	 (adjload (* maxload (max 1 numcpus))) ;; possible bug where numcpus (or could be maxload) is zero, crude fallback is to at least use 1
	 (loadjmp (- first next))
         (adjwait (min (+ 300 (random 10)) (abs (* (+ (random 10)(/ (- 1000 count) 10) waitdelay) (- first adjload) ))  ))) ;; add some randomness to the time to break any alignment where netbatch dumps many jobs to machines simultaneously
         (adjwait (min (+ 300 (pseudo-random-integer 10)) (abs (* (+ (pseudo-random-integer 10)(/ (- 1000 count) 10) waitdelay) (- first adjload) ))  ))) ;; add some randomness to the time to break any alignment where netbatch dumps many jobs to machines simultaneously
    (debug:print-info 1 *default-log-port* "Checking cpuload on " (or remote-host "localhost") ", maxload: " maxload
		      ", load: " first ", adjload: " adjload ", loadjmp: " loadjmp)
    (cond
     ((and (> first adjload)
	   (> count 0))
      (debug:print-info 0 *default-log-port* "server start delayed " adjwait " seconds due to load " first " exceeding max of " adjload " on server " (or remote-host (get-host-name)) " (normalized load-limit: " maxload ") " (if msg msg ""))
      (thread-sleep! adjwait)

;; Do NOT check if not on homehost!
;;
(define (common:exit-on-version-changed)
  (if (common:on-homehost?)
      (if (common:api-changed?)
	  (let* ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config"))
                (dbfile  (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.db"))
                (read-only (not (file-write-access? dbfile)))
                (read-only (not (file-writable? dbfile)))
                (dbstruct (db:setup #t)))
	    (debug:print 0 *default-log-port*
			 "WARNING: Version mismatch!\n"
			 "   expected: " (common:version-signature) "\n"
			 "   got:      " (common:get-last-run-version))
            (cond
             ((get-environment-variable "MT_SKIP_DB_MIGRATE") #t)

  (let* ((ns            (server:get-num-servers))
	 (servers       (server:get-best (server:get-list areapath))))
    ;; (print "servers: " servers " ns: " ns)
    (if (or (and servers
		 (null? servers))
	    (not servers)
	    (and (list? servers)
		 (< (length servers) (random ns)))) ;; somewhere between 0 and numservers
		 (< (length servers) (pseudo-random-integer ns)))) ;; somewhere between 0 and numservers
        #f
        (let loop ((hed (car servers))
                   (tal (cdr servers)))
          (let ((res (server:check-server hed)))
            (if res
                res
                (if (null? tal)

    (if (and target-host 
	     ;; look at target host, is it host.domain.tld or ip address and does it 
	     ;; match current ip or hostname
	     (not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host))
	     (not (equal? curr-ip target-host)))
	(begin
	  (debug:print-info 0 *default-log-port* "Starting server on " target-host ", logfile is " logfile)
	  (setenv "TARGETHOST" target-host)))
	  (set-environment-variable! "TARGETHOST" target-host)))
      
    (setenv "TARGETHOST_LOGF" logfile)
    (thread-sleep! (/ (random 5000) 1000)) ;; add about a random (up to 5 seconds) initial delay. It seems pretty common that many running tests request a server at the same time
    (set-environment-variable! "TARGETHOST_LOGF" logfile)
    (thread-sleep! (/ (pseudo-random-integer 5000) 1000)) ;; add about a random (up to 5 seconds) initial delay. It seems pretty common that many running tests request a server at the same time
    (common:wait-for-normalized-load load-limit " delaying server start due to load" target-host) ;; do not try starting servers on an already overloaded machine, just wait forever
    (system (conc "nbfake " cmdln))
    (unsetenv "TARGETHOST_LOGF")
    (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST"))
    (unset-environment-variable! "TARGETHOST_LOGF")
    (if (get-environment-variable "TARGETHOST")(unset-environment-variable! "TARGETHOST"))
    (thread-join! log-rotate)
    (pop-directory)))

;; kind start up of servers, wait 40 seconds before allowing another server for a given
;; run-id to be launched
#;(define (server:kind-run areapath)
  (if (not (server:check-if-running areapath)) ;; why try if there is already a server running?
      (let* ((last-run-dat (hash-table-ref/default *server-kind-run* areapath '(0 0))) ;; callnum, whenrun
	     (call-num     (car last-run-dat))
	     (when-run     (cadr last-run-dat))
	     (run-delay    (+ (case call-num
				((0)    0)
				((1)   20)
				((2)  300)
				(else 600))
			      (random 5)))   ;; add a small random number just in case a lot of jobs hit the work hosts simultaneously
			      (pseudo-random-integer 5)))   ;; add a small random number just in case a lot of jobs hit the work hosts simultaneously
	     (lock-file    (conc areapath "/logs/server-start.lock")))
	(if	(> (- (current-seconds) when-run) run-delay)
		(begin
		  (common:simple-file-lock-and-wait lock-file expire-time: 15)
		  (server:run areapath)
		  (thread-sleep! 2) ;; don't release the lock for at least a few seconds
		  (common:simple-file-release-lock lock-file)))

		(if (> my-start-time (handle-exceptions
					 exn
					 0
				       (file-modification-time lockf)))
		    ;; we started since current re-gen in flight, delay a little and try again
		    (begin
		      (debug:print-info 1 *default-log-port* "Waiting to update " outputfilename ", another test currently updating it")
		      (thread-sleep! (+ 5 (random 5))) ;; delay between 5 and 10 seconds
		      (thread-sleep! (+ 5 (pseudo-random-integer 5))) ;; delay between 5 and 10 seconds
		      (loop (common:simple-file-lock lockf))))))))))

(define (tests:generate-html-summary-for-iterated-test run-id test-id test-name outputfilename)
  (let ((counts              (make-hash-table))
	(statecounts         (make-hash-table))
	(outtxt              "")
	(tot                 0)

						      '()
						      (lambda (x p)
							(let* ((targ-path (string-intersperse p "/"))
                                                               (full-path (conc linktree "/" targ-path))
                                                               (run-name  (car (reverse p))))
                                                          (if (and (common:file-exists? full-path)
                                                                   (directory?   full-path)
                                                                   (file-write-access? full-path))
                                                                   (file-writable? full-path))
                                                              (s:a run-name 'href (conc targ-path "/run-summary.html"))
                                                              (begin
                                                                (debug:print 0 *default-log-port* "INFO: Can't create " targ-path "/run-summary.html")
                                                                (conc run-name " (Not able to create summary at " targ-path ")")))))))))))
          (close-output-port oup)
	  (common:simple-file-release-lock lockfile)
               

                                           path-parts))
                                       test-dats))
                    (tests-htree (common:list->htree tests-tree-dat))
                    (html-dir    (conc linktree "/" (string-intersperse run-dir "/")))
                    (html-path   (conc html-dir "/run-summary.html"))
                    (oup         (if (and (common:file-exists? html-dir)
                                          (directory?   html-dir)
                                          (file-write-access? html-dir))
                                          (file-writable? html-dir))
                                     (open-output-file  html-path)
                                     #f)))
               ;; (print "run-dir: " run-dir ", tests-tree-dat: " tests-tree-dat)
               (if oup
                   (begin
                     (s:output-new
                      oup

                                                                          (alt-file  (conc full-targ "/megatest-rollup-" test-name ".html"))
                                                                          (html-file (if (common:file-exists? alt-file)
                                                                                         alt-file
                                                                                         std-file))
                                                                          (run-name  (car (reverse p))))
                                                                     (if (and (not (common:file-exists? full-targ))
                                                                              (directory? full-targ)
                                                                              (file-write-access? full-targ))
                                                                              (file-writable? full-targ))
                                                                         (tests:summarize-test 
                                                                          run-id 
                                                                          (rmt:get-test-id run-id test-name item-path)))
                                                                     (if (common:file-exists? full-targ)
                                                                         (s:a run-name 'href html-file)
                                                                         (begin
                                                                           (debug:print 0 *default-log-port* "ERROR: can't access " full-targ)

;; summarize test in to a file test-summary.html in the test directory
;;
(define (tests:summarize-test run-id test-id)
  (let* ((test-dat  (rmt:get-test-info-by-id run-id test-id))
	 (out-dir   (db:test-get-rundir test-dat))
	 (out-file  (conc out-dir "/test-summary.html")))
    ;; first verify we are able to write the output file
    (if (not (file-write-access? out-dir))
    (if (not (file-writable? out-dir))
	(debug:print 0 *default-log-port* "ERROR: cannot write test-summary.html to " out-dir)
	(let* (;; (steps-dat (rmt:get-steps-for-test run-id test-id))
	       (test-name (db:test-get-testname test-dat))
	       (item-path (db:test-get-item-path test-dat))
	       (full-name (db:test-make-full-name test-name item-path))
	       (oup       (open-output-file out-file))
	       (status    (db:test-get-status   test-dat))

    (if enccmd
	(common:read-encoded-string enccmd)
	'())))

;; return (conc status ": " comment) from the final section so that
;;   the comment can be set in the step record in launch.scm
;;
(define (launch:load-logpro-dat run-id test-id stepname)
#;(define (launch:load-logpro-dat run-id test-id stepname)
  (let ((cname (conc stepname ".dat")))
    (if (common:file-exists? cname)
	(let* ((dat  (configf:read-config cname #f #f))
	       (csvr (db:logpro-dat->csv dat stepname))
	       (csvt (let-values (((fmt-cell fmt-record fmt-csv) (make-format ",")))
		       (fmt-csv (map list->csv-record csvr))))
	       (status (configf:lookup dat "final" "exit-status"))

    
    (let ((exinfo (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2))
	  (logfna (if logpro-used (conc stepname ".html") ""))
	  (comment #f))
      (if logpro-used
	  (let ((datfile (conc stepname ".dat")))
	    ;; load the .dat file into the test_data table if it exists
	    (if (common:file-exists? datfile)
		(set! comment (launch:load-logpro-dat run-id test-id stepname)))
	    ;;(if (common:file-exists? datfile)
	;;	(set! comment (launch:load-logpro-dat run-id test-id stepname)))
	    (rmt:test-set-log! run-id test-id (conc stepname ".html"))))
      (rmt:teststep-set-status! run-id test-id stepname "end" exinfo comment logfna))
    ;; set the test final status
    (let* ((process-exit-status (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2))
	   (this-step-status (cond
			      ((and (eq? process-exit-status 2) logpro-used) 'warn)   ;; logpro 2 = warnings
			      ((and (eq? process-exit-status 3) logpro-used) 'check)  ;; logpro 3 = check

			     (prevstep #f))
                    (debug:print-info 0 *default-log-port* "Processing ezstep \"" (string-intersperse ezstep " ") "\"")
		    ;; check exit-info (vector-ref exit-info 1)
		    (if (launch:einf-exit-status exit-info) ;; (vector-ref exit-info 1)
			(let ((logpro-used (launch:runstep ezstep run-id test-id exit-info m tal testconfig))
			      (stepname    (car ezstep)))
			  ;; if logpro-used read in the stepname.dat file
			  (if (and logpro-used (common:file-exists? (conc stepname ".dat")))
			      (launch:load-logpro-dat run-id test-id stepname))
			  ;;(if (and logpro-used (common:file-exists? (conc stepname ".dat")))
			  ;;    (launch:load-logpro-dat run-id test-id stepname))
			  (if (steprun-good? logpro-used (launch:einf-exit-code exit-info))
			      (if (not (null? tal))
				  (loop (car tal) (cdr tal) stepname))
			      (debug:print 0 *default-log-port* "WARNING: step " (car ezstep) " failed. Stopping")))
			(debug:print 0 *default-log-port* "WARNING: a prior step failed, stopping at " ezstep)))))))))

(define (launch:monitor-job run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m work-area runtlim misc-flags)

  (let* ((target    (or intarget 
			(common:args-get-target)
			(get-environment-variable "MT_TARGET")))
	 (keys      (if inkeys    inkeys    (rmt:get-keys)))
	 (keyvals   (if inkeyvals inkeyvals (keys:target->keyval keys target)))
	 (vals      (hash-table-ref/default *env-vars-by-run-id* run-id #f))
	 (link-tree (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree")))
    (if testname (setenv "MT_TEST_NAME" testname))
    (if itempath (setenv "MT_ITEMPATH"  itempath))
    (if testname (set-environment-variable! "MT_TEST_NAME" testname))
    (if itempath (set-environment-variable! "MT_ITEMPATH"  itempath))

    ;; get the info from the db and put it in the cache
    (if link-tree
	(setenv "MT_LINKTREE" link-tree)
	(set-environment-variable! "MT_LINKTREE" link-tree)
	(debug:print-error 0 *default-log-port* "linktree not set, should be set in megatest.config in [setup] section."))
    (if (not vals)
	(let ((ht (make-hash-table)))
	  (hash-table-set! *env-vars-by-run-id* run-id ht)
	  (set! vals ht)
	  (for-each
	   (lambda (key)
	     (hash-table-set! vals (car key) (cadr key)))
	   keyvals)))
    ;; from the cached data set the vars
    
    (hash-table-for-each
     vals
     (lambda (key val)
       (debug:print 2 *default-log-port* "setenv " key " " val)
       (safe-setenv key val)))
    ;;(bb-check-path msg: "runs:set-megatest-env-vars block 1")
    ;;(BB> "*env-vars-by-run-id*/runid("run-id" vals="(hash-table->alist vals))

    (if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target))
    (if (not (get-environment-variable "MT_TARGET"))(set-environment-variable! "MT_TARGET" target))
    ;; we had a case where there was an exception generated by the hash-table-ref
    ;; due to *configdat* being #f Adding a handle and exit
    (let fatal-loop ((count 0)) 
      (handle-exceptions
	  exn
	  (let ((call-chain (get-call-chain))
		(msg        ((condition-property-accessor 'exn 'message) exn)))

              (thread-sleep! 2) ;; assuming nfs lag.
              (launch:setup force-reread: #t))
          (alist->env-vars (hash-table-ref/default *configdat* "env-override" '())))) ;;;; environment is tainted HERE in this let block.
    ;;(bb-check-path msg: "runs:set-megatest-env-vars block 2")
    ;; Lets use this as an opportunity to put MT_RUNNAME in the environment
    (let ((runname  (if inrunname inrunname (rmt:get-run-name-from-id run-id))))
      (if runname
	  (setenv "MT_RUNNAME" runname)
	  (set-environment-variable! "MT_RUNNAME" runname)
	  (debug:print-error 0 *default-log-port* "no value for runname for id " run-id)))
    (setenv "MT_RUN_AREA_HOME" *toppath*)
    (set-environment-variable! "MT_RUN_AREA_HOME" *toppath*)
    ;; if a testname and itempath are available set the remaining appropriate variables
    (if testname (setenv "MT_TEST_NAME" testname))
    (if itempath (setenv "MT_ITEMPATH"  itempath))
    (if testname (set-environment-variable! "MT_TEST_NAME" testname))
    (if itempath (set-environment-variable! "MT_ITEMPATH"  itempath))
    ;;(bb-check-path msg: "runs:set-megatest-env-vars block 3")
    (if (and testname link-tree)
	(setenv "MT_TEST_RUN_DIR" (conc (getenv "MT_LINKTREE")  "/"
	(set-environment-variable! "MT_TEST_RUN_DIR" (conc (getenv "MT_LINKTREE")  "/"
					(getenv "MT_TARGET")    "/"
					(getenv "MT_RUNNAME")   "/"
					(getenv "MT_TEST_NAME")
					(if (and itempath
						 (not (equal? itempath "")))
					    (conc "/" itempath)
					    ""))))))

(define (launch:execute encoded-cmd)
  (let* ((cmdinfo    (common:read-encoded-string encoded-cmd))
	 (tconfigreg #f))
    (setenv "MT_CMDINFO" encoded-cmd)
    (set-environment-variable! "MT_CMDINFO" encoded-cmd)
    ;;(bb-check-path msg: "launch:execute incoming")
    (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed)
	;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1))
	(let* ((testpath  (assoc/default 'testpath  cmdinfo))  ;; testpath is the test spec area
	       (top-path  (assoc/default 'toppath   cmdinfo))
	       (work-area (assoc/default 'work-area cmdinfo))  ;; work-area is the test run area
	       (test-name (assoc/default 'test-name cmdinfo))

	       (keyvals   #f)
	       (fullrunscript (if (not runscript)
                                  #f
                                  (if (substring-index "/" runscript)
                                      runscript ;; use unadultered if contains slashes
                                      (let ((fulln (conc work-area "/" runscript)))
	                                  (if (and (common:file-exists? fulln)
                                                   (file-execute-access? fulln))
                                                   (file-executable? fulln))
                                              fulln
                                              runscript))))) ;; assume it is on the path
               (check-work-area           (lambda ()
                                            ;; NFS might not have propagated the directory meta data to the run host - give it time if needed
                                            (let loop ((count 0))
                                              (if (or (common:directory-exists? work-area)
                                                      (> count 10))

                                                    (debug:print 0 *default-log-port* "INFO: test data from " testpath " not copied properly or filesystem problems causing data to not be found. Re-running the copy command.")
                                                    (debug:print 0 *default-log-port* "INFO: missing files from " work-area ": " (string-intersperse bad-files ", "))
                                                    (launch:test-copy testpath work-area))))
                                            ;; one more time, change to the work-area directory
                                            (change-directory work-area)))
	       ) ;; let*

	  (if contour (setenv "MT_CONTOUR" contour))
	  (if contour (set-environment-variable! "MT_CONTOUR" contour))
	  
	  ;; immediated set some key variables from CMDINFO data, yes, these will be set again below ...
	  ;;
	  (setenv "MT_TESTSUITENAME" areaname)
	  (setenv "MT_RUN_AREA_HOME" top-path)
	  (set-environment-variable! "MT_TESTSUITENAME" areaname)
	  (set-environment-variable! "MT_RUN_AREA_HOME" top-path)
	  (set! *toppath* top-path)
          (change-directory *toppath*) ;; temporarily switch to the run area home
	  (setenv "MT_TEST_RUN_DIR"  work-area)
	  (set-environment-variable! "MT_TEST_RUN_DIR"  work-area)

	  (launch:setup) ;; should be properly in the run area home now

	  (if contour (setenv "MT_CONTOUR" contour))
	  (if contour (set-environment-variable! "MT_CONTOUR" contour))
	  
	  ;; immediated set some key variables from CMDINFO data, yes, these will be set again below ...
	  ;;
	  (setenv "MT_TESTSUITENAME" areaname)
	  (setenv "MT_RUN_AREA_HOME" top-path)
	  (set-environment-variable! "MT_TESTSUITENAME" areaname)
	  (set-environment-variable! "MT_RUN_AREA_HOME" top-path)
	  (set! *toppath* top-path)
          (change-directory *toppath*) ;; temporarily switch to the run area home
	  (setenv "MT_TEST_RUN_DIR"  work-area)
	  (set-environment-variable! "MT_TEST_RUN_DIR"  work-area)

	  (launch:setup) ;; should be properly in the run area home now
          
	  (set! tconfigreg (tests:get-all)) ;; mapping of testname => test source path
	  (let ((sighand (lambda (signum)
			   ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting
			   (if (eq? signum signal/stop)

		(debug:print 4 *default-log-port* "varpairs: " varpairs)
		(map (lambda (varpair)
		       (let ((varval (string-split varpair "=")))
			 (if (eq? (length varval) 2)
			     (let ((var (car varval))
				   (val (cadr varval)))
			       (debug:print 1 *default-log-port* "Adding pre-var/val " var " = " val " to the environment")
			       (setenv var val)))))
			       (set-environment-variable! var val)))))
		     varpairs)))
          ;;(bb-check-path msg: "launch:execute post block 2")
	  (for-each
	   (lambda (varval)
	     (let ((var (car varval))
		   (val (cadr varval)))
	       (if val
		   (setenv var val)
		   (set-environment-variable! var val)
		   (begin
		     (debug:print-error 0 *default-log-port* "required variable " var " does not have a valid value. Exiting")
		     (exit)))))
	     (list 
	      (list  "MT_TEST_RUN_DIR" work-area)
	      (list  "MT_TEST_NAME" test-name)
	      (list  "MT_ITEM_INFO" (conc itemdat))
	      (list  "MT_ITEMPATH"  item-path)
	      (list  "MT_RUNNAME"   runname)
	      (list  "MT_MEGATEST"  megatest)
	      (list  "MT_TARGET"    target)
	      (list  "MT_LINKTREE"  (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree"))
	      (list  "MT_TESTSUITENAME" (common:get-testsuite-name))))
          ;;(bb-check-path msg: "launch:execute post block 3")

	  (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path)))
	  (if mt-bindir-path (set-environment-variable! "PATH" (conc (getenv "PATH") ":" mt-bindir-path)))
          ;;(bb-check-path msg: "launch:execute post block 4")
	  ;; (change-directory top-path)
	  ;; Can setup as client for server mode now
	  ;; (client:setup)

	  
	  ;; environment overrides are done *before* the remaining critical envars.
	  (alist->env-vars env-ovrd)
          ;;(bb-check-path msg: "launch:execute post block 41")
	  (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals)
          ;;(bb-check-path msg: "launch:execute post block 42")
	  (set-item-env-vars itemdat)
          ;;(bb-check-path msg: "launch:execute post block 43")
          (let ((blacklist (configf:lookup *configdat* "setup" "blacklistvars")))
            (if blacklist
		(let ((vars (string-split blacklist)))
		  (save-environment-as-files "megatest" ignorevars: vars)
		  (for-each (lambda (var)
			      (unsetenv var))
			      (unset-environment-variable! var))
			    vars))
                (save-environment-as-files "megatest")))
          ;;(bb-check-path msg: "launch:execute post block 44")
	  ;; open-run-close not needed for test-set-meta-info
	  ;; (tests:set-full-meta-info #f test-id run-id 0 work-area)
	  ;; (tests:set-full-meta-info test-id run-id 0 work-area)
	  (tests:set-full-meta-info #f test-id run-id 0 work-area 10)

	  ;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here

	  (if (args:get-arg "-xterm")
	      (set! fullrunscript "xterm")
	      (if (and fullrunscript 
		       (common:file-exists? fullrunscript)
		       (not (file-execute-access? fullrunscript)))
		       (not (file-executable? fullrunscript)))
		  (system (conc "chmod ug+x " fullrunscript))))

	  ;; We are about to actually kick off the test
	  ;; so this is a good place to remove the records for 
	  ;; any previous runs
	  ;; (db:test-remove-steps db run-id testname itemdat)
	  ;; now is also a good time to write the .testconfig file
	  (let* ((tconfig-fname   (conc work-area "/.testconfig"))
		 (tconfig-tmpfile (conc tconfig-fname ".tmp"))
		 (tconfig         (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t))) ;; 'return-procs)))
	    (configf:write-alist tconfig tconfig-tmpfile)
	    (file-move tconfig-tmpfile tconfig-fname #t))
	    (move-file tconfig-tmpfile tconfig-fname #t))
	  ;; 
	  (let* ((m            (make-mutex))
		 (kill-job?    #f)
		 (exit-info    (make-launch:einf pid: #t exit-status: #t exit-code: #t rollup-status: 0)) ;; pid exit-status exit-code (i.e. process was successfully run) rollup-status
		 (job-thread   #f)
		 ;; (keep-going   #t)
		 (misc-flags   (let ((ht (make-hash-table)))

		  (set! *configinfo* first-pass)
		  (set! *toppath*    (or toppath (cadr first-pass))) ;; use the gathered data unless already have it
		  (set! toppath      *toppath*)
		  (if (not *toppath*)
		      (begin
			(debug:print-error 0 *default-log-port* "you are not in a megatest area!")
			(exit 1)))
		  (setenv "MT_RUN_AREA_HOME" *toppath*)
		  (set-environment-variable! "MT_RUN_AREA_HOME" *toppath*)
		  ;; the seed read is done, now read runconfigs, cache it then read megatest.config one more time and cache it
		  (let* ((keys         (rmt:get-keys))
			 (key-vals     (keys:target->keyval keys target))
			 (linktree     (common:get-linktree)) ;; (or (getenv "MT_LINKTREE")(if *configdat* (configf:lookup *configdat* "setup" "linktree") #f)))
					;     (if *configdat*
					; 	   (configf:lookup *configdat* "setup" "linktree")
					; 	   (conc *toppath* "/lt"))))
			 (second-pass  (configf:find-and-read-config
					mtconfig
					environ-patt: "env-override"
					given-toppath: toppath
					pathenvvar: "MT_RUN_AREA_HOME"))
			 (runconfigdat (begin     ;; this read of the runconfigs will see any adjustments made by re-reading megatest.config
					 (for-each (lambda (kt)
						     (setenv (car kt) (cadr kt)))
						     (set-environment-variable! (car kt) (cadr kt)))
						   key-vals)
					 (configf:read-config (conc toppath "/runconfigs.config") *runconfigdat* #t ;; consider using runconfig:read some day ...
						      sections: sections)))
                         (cachefiles   (launch:get-cache-file-paths areapath toppath target mtconfig))
                         (mtcachef     (car cachefiles))
                         (rccachef     (cdr cachefiles)))
                    ;;  trap exception due to stale NFS handle -- Error: (open-output-file) cannot open file - Stale NFS file handle: "/p/fdk/gwa/lefkowit/mtTesting/qa/primbeqa/links/p1222/11/PDK_r1.1.1/prim/clean/pcell_testgen/.runconfigs.cfg-1.6427-7d1e789cb3f62f9cde719a4865bb51b3c17ea853" - ticket 220546342

			(create-symbolic-link linktree tlink)))))
	      (begin
		(debug:print-error 0 *default-log-port* "linktree not defined in [setup] section of megatest.config")
		)))
	(if (and *toppath*
		 (directory-exists? *toppath*))
	    (begin
	      (setenv "MT_RUN_AREA_HOME" *toppath*)
	      (setenv "MT_TESTSUITENAME" (common:get-testsuite-name)))
	      (set-environment-variable! "MT_RUN_AREA_HOME" *toppath*)
	      (set-environment-variable! "MT_TESTSUITENAME" (common:get-testsuite-name)))
	    (begin
	      (debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area.")
	      (set! *toppath* #f) ;; force it to be false so we return #f
	      #f))
	
        ;; one more attempt to cache the configs for future reading
        (let* ((cachefiles   (launch:get-cache-file-paths areapath toppath target mtconfig))

              )
          (if (and rccachef mtcachef *runconfigdat* *configdat*)
              (set! *configstatus* 'fulldata)))

	;; if have -append-config then read and append here
	(let ((cfname (args:get-arg "-append-config")))
	  (if (and cfname
		   (file-read-access? cfname))
		   (file-readable? cfname))
	      (configf:read-config cfname *configdat* #t))) ;; values are added to the hash, no need to do anything special.
	*toppath*)))

(define (get-best-disk confdat testconfig)
  (let* ((disks   (or (and testconfig (hash-table-ref/default testconfig "disks" #f))
		      (hash-table-ref/default confdat "disks" #f)))
	 (minspace (let ((m (configf:lookup confdat "setup" "minspace")))

  (let* ((rundir (if (and (getenv "MT_LINKTREE")(getenv "MT_TARGET")(getenv "MT_RUNNAME"))
		     (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME"))
		     #f))
	 (cfgf   (if rundir (conc rundir "/.runconfig." megatest-version "-" megatest-fossil-hash) #f)))
    (if (and cfgf
	     (common:file-exists? cfgf)
	     (file-write-access? cfgf)
	     (file-writable? cfgf)
	     (common:use-cache?))
	(configf:read-alist cfgf)
	(let* ((keys   (rmt:get-keys))
	       (target (common:args-get-target))
	       (key-vals (if target (keys:target->keyval keys target) #f))
	       (sections (if target (list "default" target) #f))
	       (data     (begin
			   (setenv "MT_RUN_AREA_HOME" *toppath*)
			   (set-environment-variable! "MT_RUN_AREA_HOME" *toppath*)
			   (if key-vals
			       (for-each (lambda (kt)
					   (setenv (car kt) (cadr kt)))
					   (set-environment-variable! (car kt) (cadr kt)))
					 key-vals))
			   ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections))))
                           (runconfig:read (conc *toppath* "/runconfigs.config") target #f))))
	  (if (and rundir ;; have all needed variabless
		   (directory-exists? rundir)
		   (file-write-access? rundir))
		   (file-writable? rundir))
	      (begin
                (if (not (common:in-running-test?))
                    (configf:write-alist data cfgf))
		;; force re-read of megatest.config - this resolves circular references between megatest.config
		(launch:setup force-reread: #t)
		;; (launch:cache-config) ;; there are two independent config cache locations, turning this one off for now. MRW.
		)) ;; we can safely cache megatest.config since we have a valid runconfig

(use z3)
(use base64)
(import z3)
(import chicken.port chicken.process-context chicken.pretty-print base64)

(let* ((env-str        (with-output-to-string (lambda () (pp (get-environment-variables)))))
       (zipped-env-str (z3:encode-buffer env-str))
       (b64-env-str    (base64-encode zipped-env-str)))
  (print b64-env-str))

(declare (uses mtconfigf))
(declare (uses mtargs))
(declare (uses tasksmod))

(module servermod
	*
	
(import scheme chicken data-structures extras files)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18
	srfi-69 format ports srfi-1 matchable
(import scheme (chicken base) (chicken file) (chicken condition))
(import (prefix sqlite3 sqlite3:) typed-records srfi-18
	srfi-69 format (chicken port) srfi-1 matchable
	directory-utils md5 message-digest regex
	chicken.file.posix chicken.io chicken.sort chicken.time chicken.string
	chicken.process chicken.process-context chicken.process-context.posix
	chicken.random system-information 
	stack)
(import commonmod)
(import dbmod)
(import tasksmod)
(import (prefix mtargs args:))
(import (prefix mtconfigf configf:))

          (delete-file* (common:get-sync-lock-filepath))
          )
	 
	 ;; clear out junk records
	 ;;
	 ((dejunk)
	  (db:delay-if-busy mtdb) ;; ok to delay on mtdb
	  (when (file-write-access? (db:dbdat-get-path mtdb)) (db:clean-up mtdb))
	  (when (file-writable? (db:dbdat-get-path mtdb)) (db:clean-up mtdb))
	  (db:clean-up tmpdb)
	  (db:clean-up refndb))

	 ;; sync runs, test_meta etc.
	 ;;
	 ((old2new)
	  (set! data-synced

  (let ((fname-rx    (regexp "^(|.*/)server-(\\d+)-(\\S+).log$"))
	(day-seconds (* 24 60 60)))
    ;; if the directory exists continue to get the list
    ;; otherwise attempt to create the logs dir and then
    ;; continue
    (if (if (directory-exists? (conc areapath "/logs"))
	    '()
	    (if (file-write-access? areapath)
	    (if (file-writable? areapath)
		(begin
		  (condition-case
		      (create-directory (conc areapath "/logs") #t)
		    (exn (i/o file)(debug:print 0 *default-log-port* "ERROR: Cannot create directory at " (conc areapath "/logs")))
		    (exn ()(debug:print 0 *default-log-port* "ERROR: Unknown error attemtping to get server list.")))
		  (directory-exists? (conc areapath "/logs")))
		'()))

				;; (print "start-time: " start-time " mod-time: " mod-time)
				(and start-time mod-time
				     (> (- now start-time) 0)    ;; been running at least 0 seconds
				     (< (- now mod-time)   16)   ;; still alive - file touched in last 16 seconds
				     (< (- now start-time)       
					(+ (- (string->number (or (configf:lookup *configdat* "server" "runtime") "3600"))
					      180)
					   (random 360))) ;; under one hour running time +/- 180
					   (pseudo-random-integer 360))) ;; under one hour running time +/- 180
				     ))
			      #f))
			srvlst)
		(lambda (a b)
		  (< (list-ref a 3)
		     (list-ref b 3))))))
    (if (> (length slst) nums)

	#f)))

(define (server:get-rand-best areapath)
  (let ((srvrs (server:get-best (server:get-list areapath))))
    (if (and (list? srvrs)
	     (not (null? srvrs)))
	(let* ((len (length srvrs))
	       (idx (random len)))
	       (idx (pseudo-random-integer len)))
	  (list-ref srvrs idx))
	#f)))


(define (server:record->url servr)
  (match-let (((mod-time host port start-time pid)
	       servr))

	(begin
	  (print "[database]\nlocation /some/path\n\n Is missing from the config file!")
	  (exit 1)))
    (if (and path
	     (directory? path)
	     (file-read-access? path))
	(let* ((dbpath    (conc path "/spublish.db"))
	       (writeable (file-write-access? dbpath))
	       (writeable (file-writable? dbpath))
	       (dbexists  (file-exists? dbpath)))
	  (handle-exceptions
	   exn
	   (begin
	     (debug:print 2 *default-log-port* "ERROR: problem accessing db " dbpath
			  ((condition-property-accessor 'exn 'message) exn))
	     (exit 1))

;;   <http://www.netscape.com/newsref/std/cookie_spec.html>

;; (declare (unit cookie))

(module cookie
    *

(import chicken scheme data-structures extras srfi-13 ports posix)
(import (chicken base) scheme queues srfi-13 (chicken port) (chicken io)(chicken file) (chicken format) (chicken string) (chicken time posix))
  
(require-extension srfi-1 srfi-13 srfi-14 regex)
;; (use  srfi-1 srfi-13 srfi-14 regex)
;; (declare (export parse-cookie-string construct-cookie-string))

;; #>
;; #include <time.h>

;; stml is a list of html strings

;; (declare (unit stml))

(module stml2
    *

(import chicken scheme data-structures extras srfi-13 ports posix srfi-69 files srfi-1) 
(import (chicken random) (chicken base) (chicken string) (chicken time) scheme queues srfi-13 (chicken port) (chicken io) (chicken file) srfi-69 srfi-1 (chicken condition) (chicken time posix) (chicken process-context posix) (chicken pathname) (chicken blob) (chicken format) (chicken process) (chicken process-context)) 

(import cookie)
(use (prefix dbi dbi:) (prefix crypt c:) typed-records)
(import (prefix dbi dbi:) (prefix crypt c:) typed-records)

;; (declare (uses misc-stml))
(use regex)
(import regex)

;; The (usually global) sdat contains everything about the session
;;
(defstruct sdat
  ;; database
  (dbtype 'pg)
  (dbinit #f)

;; to obscure and indirect database ids use one time keys
;;
;;  (s:get-key 'n 1)     => "n99e1882" n=number 99e is the week number since 1970, remainder is random
;;  (s:key->val "n1882") => 1
;;
;;  first letter is a type: n=number, s=string, b=boolean
(define (s:get-key key-type val)
  (let ((mkrandstr (lambda (innum)(number->string (random innum) 16)))
  (let ((mkrandstr (lambda (innum)(number->string (pseudo-random-integer innum) 16)))
	(week      (number->string (quotient (current-seconds) (* 7 24 60 60)) 16)))
    (let loop ((siz 1000)
	       (key (conc key-type week (mkrandstr 100)))
	       (num 0))
      (if (s:session-var-get key) ;; have a collision
	  (loop (cond                 ;; in the unlikey event we have trouble getting a new var, keep increasing the size of the number
		 ((< num 50)  100)

#;(define session:valid-chars "abcdefghijklmnopqrstuvwxyz0123456789") ;; cookies are case insensitive.
#;(define session:num-valid-chars (string-length session:valid-chars))

#;(define (session:get-nth-char nth)
  (substring session:valid-chars nth  (+ nth 1)))

#;(define (session:get-rand-char)
  (session:get-nth-char (random session:num-valid-chars)))
  (session:get-nth-char (pseudo-random-integer session:num-valid-chars)))

#;(define (session:make-rand-string len)
  (let loop ((res "")
             (n   1))
    (if (> n len) res
        (loop (string-append res (session:get-rand-char))
              (+ n 1)))))

;; maybe replace above make-rand-string with this someday?
;;
#;(define (session:generic-make-rand-string len seed-string)
  (let ((num-chars (string-length seed-string)))
    (let loop ((res "")
	       (n   1))
      (let ((char-num (random num-chars)))
      (let ((char-num (pseudo-random-integer num-chars)))
	(if (> n len) res
	    (loop (string-append res (substring seed-string char-num (+ char-num 1)))
		  (+ n 1)))))))

;; Rely on crypt egg's default settings being secure enough, accept
;; backwards-compatible OpenSSL crypt passwords too.
;;

(define session:valid-chars "abcdefghijklmnopqrstuvwxyz0123456789") ;; cookies are case insensitive.
(define session:num-valid-chars (string-length session:valid-chars))

(define (session:get-nth-char nth)
  (substring session:valid-chars nth  (+ nth 1)))

(define (session:get-rand-char)
  (session:get-nth-char (random session:num-valid-chars)))
  (session:get-nth-char (pseudo-random-integer session:num-valid-chars)))

(define (session:make-rand-string len)
  (let loop ((res "")
             (n   1))
    (if (> n len) res
        (loop (string-append res (session:get-rand-char))
              (+ n 1)))))

;; maybe replace above make-rand-string with this someday?
;;
(define (session:generic-make-rand-string len seed-string)
  (let ((num-chars (string-length seed-string)))
    (let loop ((res "")
	       (n   1))
      (let ((char-num (random num-chars)))
      (let ((char-num (pseudo-random-integer num-chars)))
	(if (> n len) res
	    (loop (string-append res (substring seed-string char-num (+ char-num 1)))
		  (+ n 1)))))))


;;======================================================================
;; P A R A M S

      (if debugmode (session:log self "session:setup dbfname=" dbfname ", dbtype=" dbtype ", dbinit=" dbinit))
      (if (eq? dbtype 'sqlite3)
	  ;; The 'auto method will distribute dbs across the disk using hash
	  ;; of user host and user. TODO
	  ;; (if (eq? dbfname 'auto) ;; This is the auto assignment of a db based on hash of IP
	  (let ((dbpath (pathname-directory dbfname)))  ;; do a couple sanity checks here to make setting up easier
	    (if debugmode (session:log self "INFO: setting up for sqlite3 db access to " dbfname))
	    (if (not (file-write-access? dbpath))
	    (if (not (file-writable? dbpath))
		(session:log self "WARNING: Cannot write to " dbpath)
		(if debugmode (session:log self "INFO: " dbpath " is writeable")))
	    (if (file-exists? dbfname)
		(begin
		  ;; (session:log self "setting dbexists to #t")
		  (set! dbexists #t))))
	  (if debugmode (session:log self "INFO: setting up for pg db access to account info " dbinit)))