Megatest

            cookie.scm mutils.scm mtargs.scm apimod.scm			\
            configfmod.scm commonmod.scm dbmod.scm rmtmod.scm		\
            debugprint.scm mtver.scm csv-xml.scm servermod.scm		\
            hostinfo.scm adjutant.scm processmod.scm testsmod.scm	\
            itemsmod.scm keysmod.scm mtmod.scm rmtmod.scm		\
            tasksmod.scm pgdb.scm launchmod.scm runsmod.scm		\
            portloggermod.scm archivemod.scm ezstepsmod.scm		\
            subrunmod.scm bigmod.scm testsmod.scm
            subrunmod.scm bigmod.scm testsmod.scm vgmod.scm


GUISRCF = dashboard-context-menu.scm dashboard-tests.scm		\
          dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm	\
          dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm
          vg.scm

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

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

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

%.import.o : %.import.scm
	csc $(CSCOPTS) -unit $*.import -c $*.import.scm -o $*.import.o

mofiles/%.o : %.scm
	@mkdir -p mofiles
	csc $(CSCOPTS) -J -c $< -o mofiles/$*.o

# module dependencies
mofiles/apimod.o : mofiles/commonmod.o
mofiles/apimod.o : mofiles/servermod.o
mofiles/apimod.o : mofiles/tasksmod.o
mofiles/archivemod.o : mofiles/launchmod.o
mofiles/archivemod.o : mofiles/servermod.o
mofiles/bigmod.o : mofiles/configfmod.o
mofiles/bigmod.o : mofiles/dbmod.o
mofiles/bigmod.o : mofiles/rmtmod.o
# mofiles/clientmod.o : mofiles/servermod.o
# mofiles/clientmod.o : mofiles/servermod.oibpq-dev
mofiles/commonmod.o : megatest-fossil-hash.scm
mofiles/commonmod.o : mofiles/configfmod.o
mofiles/commonmod.o : mofiles/debugprint.o
mofiles/commonmod.o : mofiles/hostinfo.o
mofiles/commonmod.o : mofiles/itemsmod.o
mofiles/commonmod.o : mofiles/keysmod.o
mofiles/commonmod.o : mofiles/mtargs.o
mofiles/commonmod.o : mofiles/mtver.o
mofiles/commonmod.o : mofiles/processmod.o
mofiles/configfmod.o : mofiles/keysmod.o
mofiles/dbimod.o : mofiles/autoload.o
mofiles/dbmod.o : mofiles/commonmod.o
mofiles/dbmod.o : mofiles/csv-xml.o
mofiles/dbmod.o : mofiles/keysmod.o
mofiles/dbmod.o : mofiles/mtmod.o
mofiles/ezstepsmod.o : mofiles/rmtmod.o
mofiles/ezstepsmod.o : mofiles/subrunmod.o
mofiles/itemsmod.o  : mofiles/commonmod.o
mofiles/keysmod.o : mofiles/debugprint.o
mofiles/launchmod.o : mofiles/bigmod.o
mofiles/launchmod.o : mofiles/ezstepsmod.o
mofiles/launchmod.o : mofiles/rmtmod.o mofiles/servermod.o
mofiles/mtmod.o : mofiles/debugprint.o
mofiles/portloggermod.o : mofiles/tasksmod.o
mofiles/rmtmod.o : mofiles/apimod.o

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

$(PREFIX)/bin/.$(ARCHSTR) : 
	mkdir -p $(PREFIX)/bin/.$(ARCHSTR)
	mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib

test: tests/tests.scm
	cd tests;csi -I .. -b -n tests.scm

    get-run-info
    get-run-status
    get-run-state
    get-run-stats
    get-run-times
    get-targets
    get-target
    ;; register-run
    get-tests-tags
    get-test-times
    get-tests-for-run
    get-tests-for-run-state-status
    get-test-id
    get-tests-for-runs-mindata
    get-tests-for-run-mindata

    ((get-keys-write)                        (db:get-keys dbstruct)) ;; force a dummy "write" query to force server; for debug in -repl
    
    ;; SERVERS
    ;; ((start-server)                    (apply server:kind-run params))
    ((kill-server)                       (set! *server-run* #f))
    ((get-server)                        (api:start-server dbstruct params))
    ((register-server)                   (apply db:register-server dbstruct params) );; dbstruct host port servkey pid ipaddr dbpath)
    ((deregister-server)                 (apply db:deregister-server dbstruct params) );; dbstruct host port servkey pid ipaddr dbpath)
    ((get-count-servers)                 (apply db:get-count-servers dbstruct params))

    ;; TESTS

    ;;((test-set-state-status-by-id)     (apply mt:test-set-state-status-by-id dbstruct params))
    ;;BB - commented out above because it was calling below, eventually, incorrectly (dbstruct passed to mt:test-set-state-status-by-id, which previosly did more, but now only passes thru to db:set-state-status-and-roll-up-items.
    ((test-set-state-status-by-id)

    ((set-state-status-and-roll-up-items) (apply db:set-state-status-and-roll-up-items dbstruct params))
    ((set-state-status-and-roll-up-run) (apply db:set-state-status-and-roll-up-run dbstruct params)) 
    ((top-test-set-per-pf-counts)      (apply db:top-test-set-per-pf-counts dbstruct params))
    ((test-set-archive-block-id)       (apply db:test-set-archive-block-id dbstruct params))

    ;; RUNS
    ((register-run)                 (apply db:register-run dbstruct params))
    ((insert-run)                   (apply db:insert-run dbstruct params))
    ((set-tests-state-status)       (apply db:set-tests-state-status dbstruct params))
    ((delete-run)                   (apply db:delete-run dbstruct params))
    ((lock/unlock-run)              (apply db:lock/unlock-run dbstruct params))
    ((update-run-event_time)        (apply db:update-run-event_time dbstruct params))
    ((update-run-stats)             (apply db:update-run-stats dbstruct params))
    ((set-var)                      (apply db:set-var dbstruct params))
    ((inc-var)                      (apply db:inc-var dbstruct params))

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

;; NB// Runs on the server as part of the server loop
;;
(define (api:process-request dbstruct indat) ;; the $ is the request vars proc
  (let* ((cmd-in  (alist-ref 'cmd indat)) ;; ($ 'cmd))
	 (cmd     (if (string? cmd-in)(string->symbol cmd-in) cmd-in))
	 (params  (alist-ref 'params indat))
         (key     (alist-ref 'key indat))    ;; TODO - add this back
	 (doprint (apply common:low-noise-print 10 params))
	 )
    (debug:print 0 *default-log-port* "cmd:" cmd " with params " params ", key " key)
    (if doprint (debug:print 0 *default-log-port* "cmd: " cmd " with params: " params ", key: " key))
    (case cmd-in
      ((ping) #t)
      ;; ((quit) (exit))
      (else
       (if (equal? key *my-signature*) ;; TODO - get real key involved
	   (begin
	     (set! *api-process-request-count* (+ *api-process-request-count* 1))
	     (let* ((res (api:execute-requests dbstruct cmd params))) 
	       (debug:print 0 *default-log-port* "res:" res)
	       (if doprint (debug:print 0 *default-log-port* "res:" res))
	       #;(if (not success)
	       (debug:print 0 *default-log-port* "ERROR: success flag is #f for " cmd " with params " params))
	       (if (> *api-process-request-count* *max-api-process-requests*)
		   (set! *max-api-process-requests* *api-process-request-count*))
	       (set! *api-process-request-count* (- *api-process-request-count* 1))
	       #;(sexpr->string res)
	       res))
	   (begin
	     (debug:print 0 *default-log-port*   "Server refused to process request. Sever id mismatch. recived " key " expected:  " *my-signature* ".\nOther arguments recived: cmd=" cmd " params = " params) 
	     (conc "Server refused to process request server signature mismatch: " key ", " *my-signature*)))))))

)

	 (linktree       (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")))
	 (archiver       (let ((s (configf:lookup *configdat* "archive" "archiver")))
			   (if s (string->symbol s) 'bup)))
	 (archiver-cmd   (case archiver
			   ((tar) "tar cfj ARCHIVE_NAME.tar.bz2 ")
			   ((7z)  " 7z u -t7z -m0=lzma -mx=9 -mfb=64 -md=32m -ms=on ARCHIVE_NAME.7z ")
			   (else #f)))
         (src-archive-linktree (rmt:get-var "src-archive-linktree"))  
         (src-archive-linktree (rmt:get-var run-id "src-archive-linktree"))  
	 (print-prefix      "Running: ") ;; change to #f to turn off printing
	 (preclean-spec  (configf:get-section *configdat* "archive-preclean")))

     (if (or (not src-archive-linktree) (not (equal? src-archive-linktree linktree)))      
         (rmt:set-var "src-archive-linktree"  linktree))
    ;;     (tests:match patt testname itempath)
    

       ;'dejunk
       ;'adj-testids
       'old2new
       )
      (debug:print-info 1 *default-log-port* "dropping triggers to update linktree") 
      (rmt:drop-all-triggers)
    (let* ((linktree       (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")))
	  (src-archive-linktree (rmt:get-var "src-archive-linktree")))
	  (src-archive-linktree (rmt:get-var #f "src-archive-linktree")))
        (if (not (equal? src-archive-linktree linktree))
           (rmt:update-tesdata-on-repilcate-db src-archive-linktree linktree))
              (debug:print-info 1 *default-log-port* "creating triggers after updating linktree")   
       (rmt:create-all-triggers)
))  

(define (archive:ls->list  bup-exe archive-dir internal-path)

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

build-essential
libnanomsg-dev
libpq-dev
libsqlite3-dev
sqlite3

if [[ -z $PREFIX ]];then
  echo "PREFIX required"
  exit
fi

echo "Put iup, im and cd .a and .so files in PREFIX/lib"
echo "  1. get opensrc fossil from https://www.kiatoa.com/fossils/opensrc"
echo "  2. list the unversioned files and export the cd, im and iup lib for your kernel (try uname -a for the kernel number) 4.15 ==> 415_64"
echo "  3. untar iup, im and cp tars into a clean working dir and then copy:"
echo "     cp *.a *.so $PREFIX/lib"
echo "     cp include/*.h $PREFIX/include"
echo "  4. run the chicken-install like this:"

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

cd megatest/dbi;chicken-install

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

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

;; (use srfi-1 data-structures posix regex-case (prefix base64 base64:)
;;      format dot-locking csv-xml z3 udp ;; sql-de-lite
;;      hostinfo md5 message-digest typed-records directory-utils stack
;;      matchable regex posix (srfi 18) extras ;; tcp 
;;      (prefix nanomsg nmsg:)
;;      (prefix sqlite3 sqlite3:)
;;      pkts (prefix dbi dbi:)
;;      )
;; 
;; (declare (unit common))
;; ;; (declare (uses commonmod))
;; ;; (import commonmod)
;; 
;; (include "common_records.scm")


;; (require-library margs)
;; (include "margs.scm")

;; (define old-exit exit)
;; 
;; (define (exit . code)
;;   (if (null? code)
;;       (old-exit)
;;       (old-exit code)))

(declare (uses processmod))
(declare (uses mtargs))
(declare (uses configfmod))
(declare (uses hostinfo))
(declare (uses keysmod))

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

(module commonmod
	*
	
(import scheme
	chicken.base
	chicken.condition

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

;;======================================================================
;; CONTENTS
;;
;;  config file utils

;;
(defstruct runs:gendat inc-results inc-results-last-update inc-results-fmt run-info runname target)


(define *bdat* #f) ;; the one and only (someday) global?

(defstruct bdat
  (home                   (getenv "HOME"))
  (user                   (getenv "USER"))
  (home                   (get-environment-variable "HOME"))
  (user                   (get-environment-variable "USER"))
  (watchdog               #f)
  (time-to-exit           #f)
  (task-db                #f)
  (target                 #f)
  (this-exe-fullpath      #f)
  (this-exe-dir           #f)
  (this-exe-name          #f)

    ;; set up signal handlers
    (set-signal-handler! signal/int  std-signal-handler)  ;; ^C
    (set-signal-handler! signal/term std-signal-handler)
    ;; (set-signal-handler! signal/stop std-signal-handler)  ;; ^Z NO, do NOT handle ^Z!
    bdat))

  
;; (define home (getenv "HOME"))
;; (define user (getenv "USER"))
;; (define home (get-environment-variable "HOME"))
;; (define user (get-environment-variable "USER"))
(define keys:config-get-fields common:get-fields)

;; Globals
;;
;;(define  *server-loop-heart-beat* (current-seconds))
;; (define *watchdog* #f)
;; A hash table that can be accessed by #{scheme ...} calls in
;; config files. Allows communicating between confgs
;;
(define *user-hash-data* (make-hash-table))

(define *db-keys* #f)

(define *pkts-info*    (make-hash-table)) ;; store stuff like the last parent here
(define *configinfo*   #f)   ;; raw results from setup, includes toppath and table from megatest.config
(define *runconfigdat* #f)   ;; run configs data
;; (define *configdat*    #f)   ;; megatest.config data ==> moved to configfmod
(define *configdat*    #f)   ;; megatest.config data ==> moved to configfmod
(define *configstatus* #f)   ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done
(define *toppath*      #f)
(define *already-seen-runconfig-info* #f)

(define *test-meta-updated* (make-hash-table))
(define *globalexitstatus*  0) ;; attempt to work around possible thread issues
(define *passnum*           0) ;; when running track calls to run-tests or similar

(define *home-host*         #f)
;; (define *total-non-write-delay* 0)
(define *heartbeat-mutex*   (make-mutex))
(define *api-process-request-count* 0)
(define *max-api-process-requests* 0)
(define *server-overloaded*  #f)
(define *writes-total-delay*  0)
(define *unclean-shutdown*  #t) ;; flag to clear on clean shutdown

;; client
(define *rmt-mutex*         (make-mutex))     ;; remote access calls mutex 

;; RPC transport
(define *rpc:listener*      #f)

;; KEY info
;; (define *target*            (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN
(define *keys*              (make-hash-table)) ;; cache the keys here
(define *keyvals*           (make-hash-table))
(define *toptest-paths*     (make-hash-table)) ;; cache toptest path settings here
(define *test-paths*        (make-hash-table)) ;; cache test-id to test run paths here
(define *test-ids*          (make-hash-table)) ;; cache run-id, testname, and item-path => test-id

                  (cons var (get-environment-variable var))))
              variables)))
    (dynamic-wind
        (lambda () (void))
        (lambda ()
;;           (use posix)
          (for-each (lambda (var-value)
                      (setenv (car var-value) (cdr var-value)))
                      (set-environment-variable! (car var-value) (cdr var-value)))
            variables)
          (thunk))
        (lambda ()
          (for-each (lambda (var-value)
                      (let ((var (car var-value))
                            (value (cdr var-value)))
                        (if value
                            (setenv var value)
                            (unsetenv var))))
                            (set-environment-variable! var value)
                            (unset-environment-variable! var))))
            pre-existing-variables)))))
     
;; dot-locking egg seems not to work, using this for now
;; if lock is older than expire-time then remove it and try again
;; to get the lock
;;
(define (common:simple-file-lock fname #!key (expire-time 300))

    (if (> (- currtime lasttime) waitval)
	(begin
	  (hash-table-set! *common:denoise* key currtime)
	  #t)
	#f)))

(define (common:get-megatest-exe)
  (or (getenv "MT_MEGATEST") "megatest"))
  (or (get-environment-variable "MT_MEGATEST") "megatest"))

(define (common:read-encoded-string instr)
  (handle-exceptions
   exn
   (handle-exceptions
    exn
    (begin

(define (assoc/default key lst . default)
  (let ((res (assoc key lst)))
    (if res (cadr res)(if (null? default) #f (car default)))))

(define (common:get-area-name)
  (or (configf:lookup *configdat* "setup" "area-name") ;; megatest is a flexible tool, testsuite is too limiting a description.
      (configf:lookup *configdat* "setup" "testsuite" )
      (getenv "MT_TESTSUITE_NAME")
      (get-environment-variable "MT_TESTSUITE_NAME")
      (pathname-file (or (if (string? *toppath* )
			     (pathname-file *toppath*)
			     #f)
			 (common:get-toppath #f)))
      "please-set-setup-area-name")) ;; (pathname-file (current-directory)))))

;;======================================================================
;; safe getting of toppath
(define (common:get-toppath areapath)
  (or *toppath*
      (if areapath
	  (begin
	    (set! *toppath* areapath)
	    (setenv "MT_RUN_AREA_HOME" areapath)
	    (set-environment-variable! "MT_RUN_AREA_HOME" areapath)
	    areapath)
	  #f)
      (if (getenv "MT_RUN_AREA_HOME")
      (if (get-environment-variable "MT_RUN_AREA_HOME")
	  (begin
	    (set! *toppath* (getenv "MT_RUN_AREA_HOME"))
	    (set! *toppath* (get-environment-variable "MT_RUN_AREA_HOME"))
	    *toppath*)
	  #f)
      ;; last resort, look for megatest.config
      (let loop ((thepath (realpath ".")))
	(if (file-exists? (conc thepath "/megatest.config"))
	    thepath
	    (if (equal? thepath "/")

	(target-patt (args:get-arg "-target")))
    (if target-patt
	(filter (lambda (x)
		  (patt-list-match x target-patt))
		targs)
	targs)))

;;======================================================================
;; Lookup a value in runconfigs based on -reqtarg or -target
;; 
(define (runconfigs-get config var)
  (let ((targ (common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET"))))
    (if targ
	(or (configf:lookup config targ var)
	    (configf:lookup config "default" var))
	(configf:lookup config "default" var))))

(define (common:args-get-state)
  (or (args:get-arg "-state")(args:get-arg ":state")))

(define (common:args-get-status)
  (or (args:get-arg "-status")(args:get-arg ":status")))

(define (common:args-get-testpatt rconf)
  (let* ((target        (common:args-get-target))
  (let* (;; (tagexpr       (args:get-arg "-tagexpr"))
	 ;; (tagexpr       (args:get-arg "-tagexpr"))
         ;; (tags-testpatt (if tagexpr (string-join (runs:get-tests-matching-tags tagexpr) ",") #f))
         (testpatt-key  (or (args:get-arg "-modepatt") (args:get-arg "--modepatt") "TESTPATT"))
         (args-testpatt (or (args:get-arg "-testpatt") (args:get-arg "-runtests") "%"))
         (rtestpatt     (if rconf (runconfigs-get rconf testpatt-key) #f)))
         (rtestpatt     (if rconf (runconfigs-get rconf target testpatt-key) #f)))
    (cond
     ((or (args:get-arg "--modepatt") (args:get-arg "-modepatt")) ;; modepatt is a forced setting, when set it MUST refer to an existing PATT in the runconfig
      (if rconf
	  (let* ((patts-from-mode-patt	  (runconfigs-get rconf testpatt-key)))
	  (let* ((patts-from-mode-patt	  (runconfigs-get rconf target testpatt-key)))
	    (debug:print-info 0 *default-log-port* "modepatt defined is: "testpatt-key" runconfigs values for  " testpatt-key " "  patts-from-mode-patt)
	    patts-from-mode-patt)
	  (begin
	    (debug:print-info 0 *default-log-port* " modepatt defined is: "testpatt-key" runconfigs values for  " testpatt-key) ;;  " " patts-from-mode-patt)
	    #f)))     ;; We do NOT fall back to "%"
     ;; (tags-testpatt
     ;;  (debug:print-info 0 *default-log-port* "-tagexpr "tagexpr" selects testpatt "tags-testpatt)

      #f)
   (if (and (directory-exists? path-string)
            (file-writable? path-string))
       path-string
       #f)))

(define (common:get-linktree)
  (or (getenv "MT_LINKTREE")
  (or (get-environment-variable "MT_LINKTREE")
      (if *configdat*
	  (configf:lookup *configdat* "setup" "linktree")
	  #f)
      (if (or *toppath* (getenv "MT_RUN_AREA_HOME"))
	  (conc (or *toppath* (getenv "MT_RUN_AREA_HOME")) "/lt")
      (if (or *toppath* (get-environment-variable "MT_RUN_AREA_HOME"))
	  (conc (or *toppath* (get-environment-variable "MT_RUN_AREA_HOME")) "/lt")
	  #f)
      (let* ((tp (common:get-toppath #f))
	     (lt (conc tp "/lt")))
	(if (not tp)(debug:print 0 *default-log-port* "WARNING: cannot calculate best path for linktree, using " lt))
	lt)))

(define (common:args-get-runname)
  (let ((res (or (args:get-arg "-runname")
		 (args:get-arg ":runname")
		 (getenv "MT_RUNNAME"))))
    ;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ...
		 (get-environment-variable "MT_RUNNAME"))))
    ;; (if res (set-environment-variable! "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ...
    res))

(define (common:args-get-target #!key (split #f)(exit-if-bad #f))
  (let* ((keys    (if (hash-table? *configdat*) (common:get-fields *configdat*) '()))
	 (numkeys (length keys))
	 (target  (or (args:get-arg "-reqtarg")
		      (args:get-arg "-target")
		      (getenv "MT_TARGET")))
		      (get-environment-variable "MT_TARGET")))
	 (tlist   (if target (string-split target "/" #t) '()))
	 (valid   (if target
		      (or (null? keys) ;; probably don't know our keys yet
			  (and (not (null? tlist))
			       (eq? numkeys (length tlist))
			       (null? (filter string-null? tlist))))
		      #f)))

	      #f)
	    #f))))

;;======================================================================
;; looking only (at least for now) at the MT_ variables craft the full testname
;;
(define (common:get-full-test-name)
  (if (getenv "MT_TEST_NAME")
      (if (and (getenv "MT_ITEMPATH")
               (not (equal? (getenv "MT_ITEMPATH") "")))
          (getenv "MT_TEST_NAME")
          (conc (getenv "MT_TEST_NAME") "/" (getenv "MT_ITEMPATH")))
  (if (get-environment-variable "MT_TEST_NAME")
      (if (and (get-environment-variable "MT_ITEMPATH")
               (not (equal? (get-environment-variable "MT_ITEMPATH") "")))
          (get-environment-variable "MT_TEST_NAME")
          (conc (get-environment-variable "MT_TEST_NAME") "/" (get-environment-variable "MT_ITEMPATH")))
      #f))

;;======================================================================
;; do we honor the caches of the config files?
;;
(define (common:use-cache?)
  (let ((res #t)) ;; priority by order of evaluation
    (if *configdat* ;; sillyness here. can't use setup/use-cache to know if we can use the cached files!
	(if (equal? (configf:lookup *configdat* "setup" "use-cache") "no")
	    (set! res #f)
	    (if (equal? (configf:lookup *configdat* "setup" "use-cache") "yes")
		(set! res #t))))
    (if (args:get-arg "-no-cache")(set! res #f)) ;; overrides setting in "setup"
    (if (getenv "MT_USE_CACHE")
	(if (equal? (getenv "MT_USE_CACHE") "yes")
    (if (get-environment-variable "MT_USE_CACHE")
	(if (equal? (get-environment-variable "MT_USE_CACHE") "yes")
	    (set! res #t)
	    (if (equal? (getenv "MT_USE_CACHE") "no")
	    (if (equal? (get-environment-variable "MT_USE_CACHE") "no")
		(set! res #f))))    ;; overrides -no-cache switch
    res))
  
;;======================================================================
;; force use of server?
;;
(define (common:force-server?)

;; server process management
;;======================================================================

;; no elegance here ...
;;
(define (tasks:kill-server hostname pid #!key (kill-switch ""))
  (debug:print-info 0 *default-log-port* "Attempting to kill server process " pid " on host " hostname)
  (setenv "TARGETHOST" hostname)
  (set-environment-variable! "TARGETHOST" hostname)
  (let* ((logdir (if (directory-exists? "logs")
                    "logs/"
                    ""))
         (logfile (if logdir (conc "logs/server-"pid"-"hostname".log") #f))
         (gzfile  (if logfile (conc logfile ".gz"))))
    (setenv "TARGETHOST_LOGF" (conc logdir "server-kills.log"))
    (set-environment-variable! "TARGETHOST_LOGF" (conc logdir "server-kills.log"))

    (system (conc "nbfake kill "kill-switch" "pid))

    (when logfile
      (thread-sleep! 0.5)
      (if (file-exists? gzfile) (delete-file gzfile))
      (system (conc "gzip " logfile))
      
      (unsetenv "TARGETHOST_LOGF")
      (unsetenv "TARGETHOST"))))
      (unset-environment-variable! "TARGETHOST_LOGF")
      (unset-environment-variable! "TARGETHOST"))))

(define (server:get-logs-list area-path)
  (let* (;; (server-logs-cmd  (conc "grep -iL exiting " area-path "/logs/server-*-*.log"))
	 ;; (server-logs   (string-split (string-chomp (with-input-from-pipe server-logs-cmd read-string))))
	 (server-logs      (glob (conc area-path"/logs/server-*-*.log")))
	 )
    server-logs))

	(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))) (bdat-orig-env *bdat*)) 
    (for-each (lambda (x) (unset-environment-variable! (car x)))             current-env)
    (for-each (lambda (x) (set-environment-variable! (car x) (cdr x))) (bdat-orig-env *bdat*)) 
    (let ((rv (cond
               ((string? proc)(system proc))
               (proc          (proc)))))
      (for-each (lambda (x) (unsetenv (car x))) (bdat-orig-env *bdat*))
      (for-each (lambda (x) (setenv (car x) (cdr x))) current-env)
      (for-each (lambda (x) (unset-environment-variable! (car x))) (bdat-orig-env *bdat*))
      (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))

(define (common:run-a-command cmd #!key (with-vars #f) (with-orig-env #f))
  (let* ((pre-cmd  (dtests:get-pre-command))
         (post-cmd (dtests:get-post-command))
         (fullcmd  (if (or pre-cmd post-cmd)
                       (conc pre-cmd cmd post-cmd)

	  (cond
	   ((string? res) res) ;;; FIX THE ROOT CAUSE HERE ....
	   ((null? res)   #f)
	   ((string? (cdr res)) (cdr res))  ;; it is a pair
	   ((string? (cadr res))(cadr res)) ;; it is a list
	   (else cadr res))))))

;; return items given config
;;
(define (tests:get-items tconfig)
  (let ((items      (hash-table-ref/default tconfig "items" #f)) ;; items 4
	(itemstable (hash-table-ref/default tconfig "itemstable" #f))) 
    ;; if either items or items table is a proc return it so test running
    ;; process can know to call items:get-items-from-config
    ;; if either is a list and none is a proc go ahead and call get-items
    ;; otherwise return #f - this is not an iterated test
    (cond
     ((procedure? items)      
      (debug:print-info 4 *default-log-port* "items is a procedure, will calc later")
      items)            ;; calc later
     ((procedure? itemstable)
      (debug:print-info 4 *default-log-port* "itemstable is a procedure, will calc later")
      itemstable)       ;; calc later
     ((filter (lambda (x)
		(let ((val (car x)))
		  (if (procedure? val) val #f)))
	      (append (if (list? items) items '())
		      (if (list? itemstable) itemstable '())))
      'have-procedure)
     ((or (list? items)(list? itemstable)) ;; calc now
      (debug:print-info 4 *default-log-port* "items and itemstable are lists, calc now\n"
			"    items: " items " itemstable: " itemstable)
      (items:get-items-from-config tconfig))
     (else #f))))                           ;; not iterated

(define (tests:get-tests-search-path cfgdat)
  (let ((paths (let ((section (if cfgdat
				  (configf:get-section cfgdat "tests-paths")
				  #f)))
		 (if section
		     (map cadr section)
		     '()))))

;; timeout is hms string: 1h 5m 3s, default is 10 minutes
;;
(define (server:expiration-timeout)
  (let ((tmo (configf:lookup *configdat* "server" "timeout")))
    (if (and (string? tmo)
	     (common:hms-string->seconds tmo)) ;; BUG: hms-string->seconds is broken, if given "10" returns 0. Also, it doesn't belong in this logic unless the string->number is changed below
        (* 3600 (string->number tmo))
	600))) ;; default is ten minutes
	60))) ;; default is one minute

(define (runs:get-mt-env-alist run-id runname target testname itempath)
  ;;(bb-check-path msg: "runs:set-megatest-env-vars entry")
  `(("MT_TEST_NAME"     . ,testname)
    
    ("MT_ITEMPATH"      . ,itempath)

(declare (unit configfmod))
(declare (uses mtargs))
(declare (uses debugprint))
(declare (uses keysmod))

(module configfmod
	*
	(
	 common:get-fields
	 common:nice-path
	 common:read-link-f
	 common:with-env-vars
	 configf:config->ini
	 configf:alist->config
	 configf:assoc-safe-add
	 configf:config->alist
	 configf:find-and-read-config
	 configf:get-section
	 configf:lookup
	 configf:lookup-number
	 configf:map-all-hier-alist
	 configf:read-alist
	 configf:read-config
	 configf:read-refdb
	 configf:section-var-set!
	 configf:section-vars
	 configf:set-section-var
	 configf:var-is?
	 configf:write-alist
	 configf:write-config
	 find-config
	 nice-path
	 process:cmd-run->list
	 runconfig:read
	 runconfigs-get
	 safe-setenv
	 configf:eval-string-in-environment
	)
	
(import scheme

	chicken.base
	chicken.condition
	chicken.file
	chicken.io
	chicken.pathname
	chicken.port
	chicken.pretty-print
	chicken.process
	chicken.process-context
	chicken.process-context.posix
	chicken.sort
	chicken.string
	chicken.time
	chicken.eval
	
	debugprint
	(prefix mtargs args:)

	srfi-69
	stack
	typed-records
	z3
	
	)

(define *configdat*    #f) 

(define getenv get-environment-variable)
(define setenv set-environment-variable!)
(define unsetenv unset-environment-variable!)

;;======================================================================
;; move debug stuff to separate module then put these back where they belong
;;======================================================================

    (configf:read-config fname ht #t environ-patt: environ-patt sections: (if target (list "default" target) #f))))

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

;; convert to param?
(define configf:std-imports "") ;;(import configfmod commonmod)")

(define configf:std-imports "(import configfmod commonmod)")
(define (configf:process-one matchdat l ht allow-system env-to-use linenum)
  (let* ((prestr  (list-ref matchdat 1))
	 (cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv
	 (cmd     (list-ref matchdat 3))
	 (quotedcmd (conc "\""cmd"\""))
	 (poststr (list-ref matchdat 4))
	 (result  #f)
	 (start-time (current-seconds))
	 (cmdsym  (string->symbol cmdtype))
	 (fullcmd
	  (if (member cmdsym '(scheme scm))
	      `(eval-needed
		 ,(conc  configf:std-imports
			  "(import chicken.process-context.posix chicken.process-context)"
			  "(define setenv set-environment-variable)"
			  (conc "(lambda (ht)" cmd ")")))
	      (case cmdsym
		((system)     `(noeval-needed  ,(conc (configf:system ht quotedcmd))))
		((shell sh)   `(noeval-needed  ,(conc (string-translate (shell quotedcmd) "\n" " "))))
		((realpath rp)`(noeval-needed  ,(conc (common:nice-path quotedcmd))))
		((getenv gv)  `(noeval-needed  ,(conc (get-environment-variable cmd))))
		;; ((mtrah)      (conc (or *toppath* (get-environment-variable \"MT_RUN_AREA_HOME\"))))
		((get g)   
		 (match
		  (string-split cmd)
		  ((sect var)(configf:lookup ht sect var))
		  (else
		   (debug:print-error 0 *default-log-port* "#{get ...} used with only one parameter, \"" cmd "\", two needed.")
		   '(bad-param ,(conc "#{get ...} used with only one parameter, \"" cmd "\", two needed.")))))
		((runconfigs-get rget) `(noeval-needed ,(runconfigs-get ht quotedcmd))) ;; (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
		(else `(#f ,(conc "cmd: " cmd " not recognised")))))))
    (match
     fullcmd
     (('eval-needed newres)
      (handle-exceptions
	 exn
	 (begin
	   (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\", fullcmd="fullcmd", exn=" exn)
	   (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
	   ;; (print "exn=" (condition->list exn))
	   (set! result (conc "#{( " cmdtype ") " cmd "}, full expansion: " fullcmd)))
	 (if (or allow-system
		 (not (member cmdtype '("system" "shell" "sh"))))
	     (with-input-from-string newres
	       (lambda ()
		 (set! result (if env-to-use
				  ((eval (read) env-to-use) ht)
				  ((eval (read)) ht)
				  ))))
	     (set! result (conc "#{(" cmdtype ") "  cmd "}")))))
     (('noeval-needed newres)(set! result newres))
     ((#f errres)
      (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\".")))
    ;; we process as a result
    (let ((delta (- (current-seconds) start-time)))
      (debug:print-info (if (> delta 2) 0 9) *default-log-port* "for line \"" l "\"\n command:  " cmd " took " delta " seconds to run with output:\n   " result))
    (conc prestr result poststr)))
	      
(define (configf:process-line l ht allow-system env-to-use #!key (linenum #f))
  (let loop ((res l))
    (if (string? res)
	(let ((matchdat (string-search configf:var-expand-regex res)))
	  (if matchdat
	      (let ((result (configf:process-one matchdat l ht allow-system env-to-use linenum)))
		(loop result))
	      res))
	  res)))

(define (configf:process-line-old l ht allow-system env-to-use #!key (linenum #f))
  (let loop ((res l))
    (if (string? res)
	(let ((matchdat (string-search configf:var-expand-regex res)))
	  (if matchdat
	      (let* ((prestr  (list-ref matchdat 1))
		     (cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv
		     (cmd     (list-ref matchdat 3))
		     (poststr (list-ref matchdat 4))
		     (result  #f)
		     (start-time (current-seconds))
		     (cmdsym  (string->symbol cmdtype))
		     (fullcmd
		      (conc  configf:std-imports
			     "(import chicken.process-context.posix)"
			     "(define setenv set-environment-variable)"
			     (case cmdsym
			       ((scheme scm) (conc "(lambda (ht)" cmd ")"))
			       ((system)     (conc "(lambda (ht)(configf:system ht \"" cmd "\"))"))
			       ((shell sh)   (conc "(lambda (ht)(string-translate (shell \""  cmd "\") \"\n\" \" \"))"))
			       ((realpath rp)(conc "(lambda (ht)(common:nice-path \"" cmd "\"))"))
			       ((getenv gv)  (conc "(lambda (ht)(get-environment-variable \"" cmd "\"))"))
			       ((mtrah)      (conc "(lambda (ht)"

		     (if (> delta 2)
			 (debug:print-info 0 *default-log-port* "for line \"" l "\"\n command:  " cmd " took " delta " seconds to run with output:\n   " result)
			 (debug:print-info 9 *default-log-port* "for line \"" l "\"\n command:  " cmd " took " delta " seconds to run with output:\n   " result)))))
		(loop (conc prestr result poststr)))
	      res))
	res)))

;;======================================================================
;; Lookup a value in runconfigs based on -reqtarg or -target
;; 
(define (runconfigs-get config target var)
  (let ((targ target #;(common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET"))))
    (if targ
	(or (configf:lookup config targ var)
	    (configf:lookup config "default" var))
	(configf:lookup config "default" var))))
  


;; pathenvvar will set the named var to the path of the config
(define (configf:find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f)(env-to-use #f))
  (let* ((curr-dir   (current-directory))
         (configinfo (find-config fname toppath: given-toppath))
	 (toppath    (car configinfo))
	 (configfile (cadr configinfo))
	 (set-fields (lambda (curr-section next-section ht path)

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

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

(module dashboard-context-menu
	*

(use format fmt)
(import format fmt)
(require-library iup)
(import (prefix iup iup:))

(use canvas-draw)
(import canvas-draw)

(import scheme
	srfi-1
	chicken.base
	chicken.condition
	chicken.port
	chicken.file.posix
	chicken.pathname
	chicken.process
	chicken.process-context
	chicken.string
(use srfi-1 posix regex regex-case srfi-69)
(use (prefix sqlite3 sqlite3:))
	regex regex-case srfi-69
	(prefix sqlite3 sqlite3:))

(declare (unit dashboard-context-menu))
(declare (uses common))
(declare (uses db))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses dbmod))
(declare (uses gutils))
(declare (uses rmt))
(declare (uses ezsteps))
(declare (uses rmtmod))
(declare (uses ezstepsmod))
;; (declare (uses sdb))
;; (declare (uses filedb))
(declare (uses subrun))
(declare (uses subrunmod))
(declare (uses debugprint))

(import commonmod
	dbmod
	rmtmod
	ezstepsmod
	subrunmod
	debugprint
	configfmod
	)

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

(define (dboard:launch-testpanel run-id test-id)
  (let* ((dboardexe (common:find-local-megatest "dashboard"))
         (cmd (conc dboardexe
                    " -test " run-id "," test-id

;; item5  custom show test-patt (%test-patt%):echo "%test-patt%"
;; item6  custom show test-run-dir (%test-run-dir%):echo "%test-run-dir%"
;; item7  custom show run-area-home (%run-area-home%):echo "%run-area-home%"
;; item8  custom show megatest root (%mt-root%):echo "%mt-root%"
;; item9  custom ls :  ls -lrt
;; item10 custom see $MT_RUN_AREA_HOME (not yet implemented) :  echo $MT_RUN_AREA_HOME

(define (dashboard:custom-menu-items  run-id test-id target run-name test-name testpatt item-test-path test-info)
(define (dashboard:custom-menu-items  bdat run-id test-id target run-name test-name testpatt item-test-path test-info)
  (let* ((vars (configf:section-vars *configdat* "custom-context-menu-items"))
         (item-path (db:test-get-item-path test-info))
	 ;; (bdat-this-exe-dir-set! bdat (pathname-directory fullp))
         (mt-root (pathname-directory  (pathname-directory *common:this-exe-dir* ))))
         (mt-root (pathname-directory  (pathname-directory (bdat-this-exe-dir bdat)))))
    (filter-map
     (lambda (var)
       (let* ((val (configf:lookup *configdat* "custom-context-menu-items" var))
              (m   (string-match "^\\s*([^:]+?)\\s*:\\s*(.*?)\\s*$" val)))
         (if m
             (let* ((menu-item-text-raw (list-ref m 1))
                    (command-line-raw   (list-ref m 2))

                              (begin
                                ;;(BB> "gonna eval it!")
                                (eval (with-input-from-string (cadr scheme-match) read)))))
                           (common:run-a-command command-line with-vars: #t))))))))
             #f)))
     vars)))

(define (dashboard:context-menu  run-id test-id target runname test-name testpatt item-test-path test-info)
(define (dashboard:context-menu bdat run-id test-id target runname test-name testpatt item-test-path test-info)
  (let* ((run-menu-items
          (dashboard:run-menu-items  run-id test-id target runname test-name testpatt item-test-path test-info))
         (test-menu-items
          (dashboard:test-menu-items  run-id test-id target runname test-name testpatt item-test-path test-info))
         (custom-menu-items
          (dashboard:custom-menu-items run-id test-id target runname test-name testpatt item-test-path test-info))
          (dashboard:custom-menu-items bdat run-id test-id target runname test-name testpatt item-test-path test-info))
         (toplevel-menu-items
          (dashboard:toplevel-menu-items  run-id test-id target runname test-name testpatt item-test-path test-info))
         )
    (apply iup:menu
           `(,@toplevel-menu-items
             ,(iup:menu-item
              "Run"
              (apply iup:menu run-menu-items))
             ,(iup:menu-item
              "Test"
              (apply iup:menu test-menu-items))
             ,@custom-menu-items))))

)

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

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

(use format)
(import format)
(require-library iup)
(import (prefix iup iup:))

(use canvas-draw)
(import canvas-draw)

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

(declare (unit dashboard-guimonitor))
(declare (uses common))
(declare (uses keys))
(declare (uses db))
(declare (uses tasks))
(declare (uses commonmod))
(declare (uses keysmod))
(declare (uses dbmod))
(declare (uses tasksmod))
(declare (uses debugprint))

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

(import
 commonmod
 keysmod
 dbmod
 tasksmod
 debugprint
 )

(define (control-panel db tdb keys)
  (let* ((var-params (make-hash-table)) ;; register all the widgets here for querying on run, rollup, remove?
	 (key-params (make-hash-table))
	 (monitordat '()) ;; list of monitor records
	 (keyentries (iup:frame 
		      #:title "Keys"

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

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

(use format fmt)
(import format fmt)
(require-library iup)
(import (prefix iup iup:))

(use canvas-draw)
(import canvas-draw)

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

(declare (unit dashboard-tests))
(declare (uses common))
(declare (uses db))
(declare (uses commonmod))
(declare (uses dbmod))
(declare (uses gutils))
(declare (uses rmt))
(declare (uses ezsteps))
(declare (uses rmtmod))
(declare (uses ezstepsmod))
;; (declare (uses sdb))
;; (declare (uses filedb))
(declare (uses subrun))
(declare (uses subrunmod))
(declare (uses debugprint))

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

(import
 commonmod
 dbmod
 rmtmod
 ezstepsmod
 subrunmod
 debugprint
 )

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

(define *dashboard-comment-share-slot* #f)

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

(use format)
(import format)

(declare (uses ducttape-lib))
(declare (uses bigmod))
(declare (uses debugprint))
(require-library iup)

(import (prefix iup iup:))
(import canvas-draw)

(use canvas-draw)
(import canvas-draw-iup)
(use ducttape-lib)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors) ;; defstruct
(import (prefix sqlite3 sqlite3:))
;; (import canvas-draw-iup)

(import ducttape-lib
	bigmod)

(import (prefix sqlite3 sqlite3:)
	srfi-1
	chicken.file.posix
	chicken.string
	chicken.process-context
	regex regex-case srfi-69
	typed-records
	sparse-vectors)

(declare (uses common))
(declare (uses margs))
(declare (uses keys))
(declare (uses items))
(declare (uses db))
(declare (uses configf))
(declare (uses process))
(declare (uses launch))
(declare (uses runs))
(declare (uses dashboard-tests))
(declare (uses dashboard-guimonitor))
(declare (uses tree))
(declare (uses dcommon))
(declare (uses dashboard-context-menu))
(declare (uses vg))
(declare (uses subrun))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses dashboard-context-menu))
(declare (uses dashboard-guimonitor))
(declare (uses dashboard-tests))
(declare (uses dbmod))
(declare (uses dcommon))
(declare (uses itemsmod))
(declare (uses launchmod))
(declare (uses mtmod))
(declare (uses mtargs))
(declare (uses mtver))
(declare (uses processmod))
(declare (uses runsmod))
(declare (uses subrunmod))
(declare (uses tree))
(declare (uses vgmod))
(declare (uses bigmod.import))
(declare (uses debugprint.import))
;; (declare (uses dashboard-main))
(declare (uses mt))

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

(import
 commonmod
 configfmod
 dbmod
 debugprint
 itemsmod
 launchmod
 (prefix mtargs args:)
 mtmod
 mtver
 processmod
 runsmod
 subrunmod
 vgmod
 dashboard-context-menu)

(define help (conc 
	      "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
  version " megatest-version "
  license GPL, Copyright (C) Matt Welland 2012-2017

Usage: dashboard [options]
  -h                    : this help

			"-repl"
                        "-rh5.11" ;; fix to allow running on rh5.11
			"-:p"     ;; ignore the built in chicken profiling switch
			)
		 args:arg-hash
		 0))

(make-and-init-bigdata)
;; check for MT_* environment variables and exit if found
(if (not (args:get-arg "-test"))
    (begin
      (display "Checking for MT_ vars: ")
      (for-each (lambda (var)
		  (display " ")(display var)
		  (if (get-environment-variable var)

;; first check for the switch
;;
(if (or (args:get-arg "-rh5.11")
	(configf:lookup *configdat* "dashboard" "no-detachbox")
        (not (file-exists? "/etc/os-release")))
    (set! iup:detachbox iup:vbox))

(if (not (common:on-homehost?))
#;(if (not (common:on-homehost?))
    (begin
      (debug:print 0 *default-log-port* "WARNING: Current policy requires running dashboard on homehost: " (common:get-homehost))))
    
;; RA => Might require revert for filters 
;; create a watch dog to move changes from lt/.db/*.db to megatest.db
;;
;;;(if (file-write-access? (conc *toppath* "/megatest.db"))

                             (cond
                              ((member #\1 status-chars) ;; 1 is left mouse button
                               (dboard:launch-testpanel run-id test-id))
                              
                              ((member #\2 status-chars) ;; 2 is middle mouse button
                               
                               (debug:print-info 13 *default-log-port* "mmb- test-name="test-name" testpatt="testpatt)
                               (iup:show (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu
                               (iup:show (dashboard:context-menu *bdat* run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu
                                         #:x 'mouse
                                         #:y 'mouse
                                         #:modal? "NO")
                               )
                              (else
                               (debug:print-info 13 *default-log-port* "unhandled status in run-summary-click-cb.  Doing right click action. (status is corrupted on Brandon's ubuntu host - bad/buggy  iup install??" )
                               (iup:show (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu
                               (iup:show (dashboard:context-menu *bdat* run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu
                                         #:x 'mouse
                                         #:y 'mouse
                                         #:modal? "NO")
                               )
                              )
                            
                             )) "runs-summary-click-callback"))))

								     "%"
								     tpatt))
							       "%")))
                                              (item-path (db:test-get-item-path (rmt:get-test-info-by-id run-id test-id)))
                                              (item-test-path (conc test-name "/" (if (equal? item-path "")
									"%" 
									item-path))))
					 (iup:show (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu
					 (iup:show (dashboard:context-menu *bdat* run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu
						   #:x 'mouse
						   #:y 'mouse
						   #:modal? "NO")
					 ;; (print "got here")
					 ))
				   (if (eq? pressed 0)
				       (let* ((toolpath (car (argv)))

  (db          #f)    ;; should rename this to oddb for on disk db
  (inmem       #f)
  (last-sync   0)
  (last-write  (current-seconds))
  (run-id      #f)
  (fname       #f))
  
;; Returns the dbdat for a particular run-id from dbstruct
;; Returns the dbdat for a particular dbfile inside the area
;;
(define (dbr:dbstruct-get-dbdat v run-id)
  (hash-table-ref/default (dbr:dbstruct-dbdats v) run-id #f))
(define (dbr:dbstruct-get-dbdat dbstruct dbfile)
  (hash-table-ref/default (dbr:dbstruct-dbdats dbstruct) dbfile #f))

(define (dbr:dbstruct-dbdat-put! v run-id db)
  (hash-table-set! (dbr:dbstruct-dbdats v) run-id db))
(define (dbr:dbstruct-dbdat-put! dbstruct dbfile db)
  (hash-table-set! (dbr:dbstruct-dbdats dbstruct) dbfile db))

(define (db:run-id->first-num run-id)
  (let* ((s (number->string run-id))
	 (l (string-length s)))
    (substring s (- l 1) l)))

;; 1234 => 4/1234.db

;;    if run-id => get run specific db
;;    if #f     => get main.db
;;    if db already open - return inmem
;;    if db not open, open inmem, rundb and sync then return inmem
;;    inuse gets set automatically for rundb's
;;
(define (db:get-dbdat dbstruct apath dbfile)
  (let ((dbdat (dbr:dbstruct-get-dbdat dbstruct dbfile))) ;; run-id)))
  (let ((dbdat (dbr:dbstruct-get-dbdat dbstruct dbfile)))
    (if dbdat
	dbdat
	(let* (;; (dbfile   (db:run-id->path apath run-id))
	       (newdbdat (db:open-dbdat apath dbfile db:initialize-db)))
	(let* ((newdbdat (db:open-dbdat apath dbfile db:initialize-db)))
	  (dbr:dbstruct-dbdat-put! dbstruct dbfile newdbdat)
	  newdbdat))))

;; get the inmem db for actual db operations
;;
(define (db:get-inmem dbstruct apath dbfile)
  (dbr:dbdat-inmem (db:get-dbdat dbstruct apath dbfile)))

;; get the handle for the on-disk db
;;
(define (db:get-ddb dbstruct apath dbfile)
  (dbr:dbdat-db (db:get-dbdat dbstruct apath dbfile)))

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

;; open the disk database file
;; NOTE: May need to add locking to file create process here
;; returns an sqlite3 database handle
;;
(define (db:open-run-db dbfile dbinit-proc)
  (let* ((parent-dir (pathname-directory dbfile)))
    (if (not (directory-exists? parent-dir))
	(create-directory parent-dir #t))
    (let* ((exists  (file-exists? dbfile))
	   (db      (sqlite3:open-database dbfile))
	   (handler (sqlite3:make-busy-timeout 3600)))
      (sqlite3:set-busy-handler! db handler)
      (db:set-sync db)
      ;; (db:set-sync db) ;; we don't mind that this is slow?
      (if (not exists)
	  (dbinit-proc db))
      db)))
    
;; open and initialize the inmem db
;; NOTE: Does NOT sync in the data from the disk db
;;
(define (db:open-inmem-db dbinit-proc)
  (let* ((db      (sqlite3:open-database ":memory:"))
	 (handler (sqlite3:make-busy-timeout 3600)))
    (sqlite3:set-busy-handler! db handler)
    (dbinit-proc db) ;; NOTE: inmem must always be initialized (db:initialize-db db)
    db))

;; ;; for debugging we have a local mode. these routines support that mode
;; (define *dbcache* (make-hash-table))
;; 
;; (define (db:cache-get-dbstruct rid apath)
;;   (let* ((dbname (db:run-id->dbname rid))
;; 	 (dbfile (db:dbname->path apath dbname)))
;;     (or (hash-table-ref/default *dbcache* dbfile #f)
;; 	(let* ((dbstruct (db:setup dbfile))) ;; (db:open-dbdat apath dbfile db:initialize-db)))
;; 	  (hash-table-set! *dbcache* dbfile dbstruct)
;; 	  dbstruct))))
;; 
;; (define (db:finalize-all-cache-dbstruct)
;;   #f)
;; 	  

;; get and initalize dbstruct for a given run-id
;;
;;  - uses db:initialize-db to create the schema
;;
;; Make the dbstruct, call for main db at least once
;; sync disk db to inmem
;;
;; called in http-transport and replicated in rmt.scm for *local* access. 
;;
(define (db:setup run-id)
(define (db:setup db-file) ;; run-id)
  (assert *toppath* "FATAL: db:setup called before toppath is available.")
  (let* ((dbstruct (or *dbstruct-db* (make-dbr:dbstruct)))
  (let* ((dbstruct (or *dbstruct-db* (make-dbr:dbstruct))))
	 (db-file  (db:run-id->path *toppath* run-id)))
    (db:get-dbdat dbstruct *toppath* db-file)
    (if (not *dbstruct-db*)(set! *dbstruct-db* dbstruct))
    dbstruct))

;;======================================================================
;; setting/getting a lock on the db for only one server per db
;;

  (db:with-lock-db dbfile
		(lambda (dbh dbfile)
		  (db:get-iam-server-lock dbh dbfile))))

(define (db:with-lock-db dbfile proc)
  (let* ((dbh (db:open-run-db dbfile db:initialize-db))
	 (res (proc dbh dbfile)))
    (sqlite3:finalize! dbh)
    ;; (sqlite3:finalize! dbh)
    res))

;; called before db is open?
;;
(define (db:get-iam-server-lock dbh dbfname)
  (sqlite3:with-transaction
   dbh

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

;; NOTE: touched logic is disabled/not done
;; sync run to disk if touched
;;
(define (db:sync-inmem->disk dbstruct apath dbfile #!key (force-sync #f))
  #f) ;; disabled
  (let* ((dbdat       (db:get-dbdat dbstruct apath dbfile))
	 (db          (dbr:dbdat-db dbdat))
	 (inmem       (dbr:dbdat-inmem dbdat))
	 (start-t     (current-seconds))
	 (last-update (dbr:dbdat-last-write dbdat))
	 (last-sync   (dbr:dbdat-last-sync dbdat)))
    (debug:print-info 4 *default-log-port* "Syncing for dbfile: " dbfile)
    (mutex-lock! *db-multi-sync-mutex*)
    (let* ((update_info (cons (if force-sync 0 last-update) "last_update"))
    	   (need-sync   (or force-sync (>= last-update last-sync))))
       (if need-sync
	  (db:sync-tables (db:sync-all-tables-list) update_info inmem db)
	  (debug:print 0 *default-log-port* "Skipping sync as nothing touched.")))
    (dbr:dbdat-last-sync-set! dbdat start-t)
    (mutex-unlock! *db-multi-sync-mutex*)))
;;   (let* ((dbdat       (db:get-dbdat dbstruct apath dbfile))
;; 	 (dbfullname  (conc apath "/" dbfile))
;; 	 (db          (db:open-run-db dbfullname db:initialize-db)) ;; (dbr:dbdat-db dbdat))
;; 	 (inmem       (dbr:dbdat-inmem dbdat))
;; 	 (start-t     (current-seconds))
;; 	 (last-update (dbr:dbdat-last-write dbdat))
;; 	 (last-sync   (dbr:dbdat-last-sync dbdat)))
;;     (debug:print-info 0 *default-log-port* "Syncing for dbfile: "dbfile", last-update: "last-update", last-sync: "last-sync)
;;     (mutex-lock! *db-multi-sync-mutex*)
;;     (let* ((update_info (cons "last_update" (if force-sync 0 last-update))) ;;  "last_update"))
;;     	   (need-sync   (or force-sync (>= last-update last-sync))))
;;       (if need-sync
;; 	  (begin
;; 	    (db:sync-tables (db:sync-all-tables-list) update_info inmem db)
;; 	    (dbr:dbdat-last-sync-set! dbdat start-t))
;; 	  (debug:print 0 *default-log-port* "Skipping sync as nothing touched.")))
;;     (sqlite3:finalize! db)
;;     (mutex-unlock! *db-multi-sync-mutex*)))

;; TODO: Add final sync to this
;;
(define (db:safely-close-sqlite3-db db stmt-cache #!key (try-num 3))
#;(define (db:safely-close-sqlite3-db db stmt-cache #!key (try-num 3))
  (if (<= try-num 0)
      #f
      (handle-exceptions
	  exn
	(begin
	  (print "Attempt to safely close sqlite3 db failed. Trying again. exn=" exn)
	  (thread-sleep! 3)
	  (sqlite3:interrupt! db)
	  (db:safely-close-sqlite3-db db stmt-cache try-num: (- try-num 1)))
	(if (sqlite3:database? db)
	    (let* ((stmts (and stmt-cache (hash-table-ref/default stmt-cache db #f))))
	      (if stmts (map sqlite3:finalize! (hash-table-values stmts)))
	      (sqlite3:finalize! db)
	      #t)
	    #f))))

;; close all opened run-id dbs
(define (db:close-all dbstruct)
#;(define (db:close-all dbstruct)
  (assert (dbr:dbstruct? dbstruct) "FATAL: db:close-all called with dbstruct not set up.")
  (handle-exceptions
   exn
   (begin
     (debug:print 0 *default-log-port* "WARNING: Finalizing failed, "  ((condition-property-accessor 'exn 'message) exn) ", note - exn=" exn)
     (print-call-chain *default-log-port*))
   ;; (db:sync-touched dbstruct 0 force-sync: #t) ;; NO. Do not do this here. Instead we rely on a server to be started when there are writes, even if the server itself is not going to be used as a server.

	   (sqlite3:execute "DELETE FROM servers WHERE state LIKE 'defunct%';"))
	  (else
	   (sqlite3:execute db "vacuum;")))
	 
	 (sqlite3:finalize! db)
	 #t))))))

;; last-update is *always* a pair ( fieldname|#f . last-update-seconds|#f)
(define (db:sync-one-table fromdb todb tabledat last-update numrecs)
  (assert (pair? last-update) "FATAL: last-update must always be a pair.")
  (let* ((tablename        (car tabledat))
	 (fields           (cdr tabledat))
	 (has-last-update  (member "last_update" fields))
	 (use-last-update  (cond
			    ((and has-last-update
				  (member "last_update" fields))
	 (last-update-field (or (car last-update)
				(if has-last-update
				    "last_update"
			     #t) ;; if given a number, just use it for all fields
			    ((number? last-update) #f) ;; if not matched first entry then ignore last-update for this table
			    ((and (pair? last-update)
				  (member (car last-update)    ;; last-update field name
					  (map car fields)))
			     #t)
			    (last-update
			     (debug:print 0 *default-log-port* "ERROR: parameter last-update for db:sync-tables must be a pair or a number, received: " last-update);; found in fields
			     #f)
			    (else
			     #f)))
				    #f)))
	 (last-update-value (if use-last-update ;; no need to check for has-last-update - it is already accounted for
				(if (number? last-update)
				    last-update
				    (cdr last-update))
	 (has-field         (member last-update-field fields))
	 (last-update-value (cdr last-update))
				#f))
	 (last-update-field (if use-last-update
	 (use-last-update   (and has-field last-update-field last-update-value))
				(if (number? last-update)
				    "last_update"
				    (car last-update))
				#f))
	 (num-fields (length fields))
	 (field->num (make-hash-table))
	 (num->field (apply vector (map car fields))) ;; BBHERE
	 (full-sel   (conc "SELECT " (string-intersperse (map car fields) ",") 
			   " FROM " tablename (if use-last-update ;; apply last-update criteria
						  (conc " WHERE " last-update-field " >= " last-update-value)
						  "")

			   (not (equal? (vector-ref fromrow i)(vector-ref curr i))))
		       (set! same #f))
		   (if (and same
			    (< i (- num-fields 1)))
		       (loop (+ i 1))))
		 (if (not same)
		     (begin
		       (debug:print 0 *default-log-port* "applying data "fromrow"to table "tablename", numrecs="numrecs)
		       (apply sqlite3:execute stmth (vector->list fromrow))
		       (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0)))))))
	     fromdat-lst))))
       fromdats)
      (sqlite3:finalize! stmth)
      (if (member "last_update" field-names)
	  (db:create-trigger db tablename)))))

;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) )
;; db's are sqlite3 handles
;;
;; if last-update specified ("field-name" . time-in-seconds)
;;    then sync only records where field-name >= time-in-seconds
;;    IFF field-name exists
;;
(define (db:sync-tables tbls last-update fromdb todb)

  (assert (pair? last-update) "FATAL: last-update must always be a pair")
  ;; NOTE: I'm moving all the checking OUT of this routine. Check for read/write access, existance, etc
  ;;       BEFORE calling this sync
  
  (let ((stmts       (make-hash-table)) ;; table-field => stmt
	(all-stmts   '())              ;; ( ( stmt1 value1 ) ( stml2 value2 ))
	(numrecs     (make-hash-table))
	(start-time  (current-milliseconds))

      (if should-print (debug:print 3 *default-log-port* "INFO: db sync, total run time " runtime " ms"))
      (for-each 
       (lambda (dat)
	 (let ((tblname (car dat))
	       (count   (cdr dat)))
	   (set! tot-count (+ tot-count count))
	   (if (> count 0)
	       (if should-print (debug:print 0 *default-log-port* (format #f "    ~10a ~5a" tblname count))))))
	       (if should-print (debug:print 0 *default-log-port* "   "tblname" "count))))) ;; (format #f "    ~10a ~5a" tblname count))))))
       (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b))))))
    tot-count))

(define (db:patch-schema-rundb frundb)
  ;;
  ;; remove this some time after September 2016 (added in version v1.6031
  ;;

	   (list "update_test_data_trigger"  "CREATE TRIGGER  IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data
                             FOR EACH ROW
                               BEGIN 
                                 UPDATE test_data SET last_update=(strftime('%s','now'))
                                   WHERE id=old.id;
                               END;" )))

(define (db:create-all-triggers dbstruct)
(define (db:create-all-triggers dbstruct run-id)
(db:with-db
   dbstruct #f #f
   dbstruct run-id #f
   (lambda (db)
(db:create-triggers db))))

(define (db:create-triggers db)
    (for-each (lambda (key)
              (sqlite3:execute db (cadr key)))
          db:trigger-list))

(define (db:drop-all-triggers dbstruct)
(define (db:drop-all-triggers dbstruct run-id)
  (db:with-db
   dbstruct #f #f
   dbstruct run-id #f
   (lambda (db)
     (db:drop-triggers db))))

(define (db:is-trigger-dropped db tbl-name)
  (let* ((trigger-name (if (equal? tbl-name "test_steps")
			   "update_teststeps_trigger" 
                           (conc "update_" tbl-name "_trigger")))

	 (toplevels   '())
	 (deadtime-str (configf:lookup *configdat* "setup" "deadtime"))
	 (deadtime     (if (and deadtime-str
				(string->number deadtime-str))
			   (string->number deadtime-str)
			   72000))) ;; twenty hours
    (db:with-db
     dbstruct #f #f
     dbstruct run-id #f
     (lambda (db)
       (if (number? ovr-deadtime)(set! deadtime ovr-deadtime))
       
       ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes
       ;;
       ;; HOWEVER: this code in run:test seems to work fine
       ;;              (> (- (current-seconds)(+ (db:test-get-event_time testdat)

         (running-deadtime-default (+ server-start-allowance (* 2 launch-monitor-period)))
         (running-deadtime (or deadtime-trim running-deadtime-default)) ;; two minutes (30 seconds between updates, this leaves 3x grace period)
         )
    (debug:print-info 4  *default-log-port* "running-deadtime = " running-deadtime)
    (debug:print-info 4  *default-log-port* "deadtime-trim = " deadtime-trim)

    (db:with-db 
     dbstruct #f #f
     dbstruct run-id #f
     (lambda (db)
       (let* ((stmth1 (db:get-cache-stmth
		       dbstruct db
		       "SELECT id,rundir,uname,testname,item_path,event_time,run_duration FROM tests 
                           WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?)
                                          AND state IN ('RUNNING');"))
	      (stmth2 (db:get-cache-stmth

		 ;; MATT: Moving this to rmt.scm - call right after calling find-and-mark-complete
		 ;; (launch:end-of-run-check run-id)
		 )))))))

;; BUG: Probably broken - does not explicitly use run-id in the query
;;
(define (db:top-test-set-per-pf-counts dbstruct run-id test-name)
  (db:general-call dbstruct 'top-test-set-per-pf-counts (list test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name)))
  (db:general-call dbstruct 'top-test-set-per-pf-counts run-id (list test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name)))

;; Clean out old junk and vacuum the database
;;
;; Ultimately do something like this:
;;
;; 1. Look at test records either deleted or part of deleted run:
;;    a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown'

;;     ;; (db:delay-if-busy dbdat)
;;     (sqlite3:execute db "VACUUM;")
;;     dead-runs))

;;======================================================================
;; M E T A   G E T   A N D   S E T   V A R S
;;======================================================================

   
;; returns number if string->number is successful, string otherwise
;; also updates *global-delta*
;;
(define (db:get-var dbstruct var)
(define (db:get-var dbstruct run-id var)
  (let* ((res      #f))
    (db:with-db
     dbstruct #f #f
     dbstruct run-id #f
     (lambda (db)
       (sqlite3:for-each-row
        (lambda (val)
          (set! res val))
        db
        "SELECT val FROM metadat WHERE var=?;" var)
       ;; convert to number if can
       (if (string? res)
           (let ((valnum (string->number res)))
             (if valnum (set! res valnum))))
       res))))

(define (db:inc-var dbstruct var)
  (db:with-db dbstruct #f #t 
(define (db:inc-var dbstruct run-id var)
  (db:with-db dbstruct run-id #t 
	      (lambda (db)
		(sqlite3:execute db "UPDATE metadat SET val=val+1 WHERE var=?;" var))))

(define (db:dec-var dbstruct var)
  (db:with-db dbstruct #f #t 
(define (db:dec-var dbstruct run-id var)
  (db:with-db dbstruct run-id #t 
	      (lambda (db)
		(sqlite3:execute db "UPDATE metadat SET val=val-1 WHERE var=?;" var))))

;; This was part of db:get-var. It was used to estimate the load on
;; the database files.
;;
;; scale by 10, average with current value.
;;     (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms)
;; 						 (if throttle throttle 0.01)))
;; 			    2))
;;     (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit
;; 	(begin
;; 	  (debug:print-info 4 *default-log-port* "launch throttle factor=" *global-delta*)
;; 	  (set! *last-global-delta-printed* *global-delta*)))

(define (db:set-var dbstruct var val)
  (db:with-db dbstruct #f #t 
(define (db:set-var dbstruct run-id var val)
  (db:with-db dbstruct run-id #t 
	      (lambda (db)
		(sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val))))

(define (db:add-var dbstruct var val)
  (db:with-db dbstruct #f #t 
(define (db:add-var dbstruct run-id var val)
  (db:with-db dbstruct run-id #t 
	      (lambda (db)
		(sqlite3:execute db "UPDATE metadat SET val=val+? WHERE var=?;" val var))))

(define (db:del-var dbstruct var)
  (db:with-db dbstruct #f #t 
(define (db:del-var dbstruct run-id var)
  (db:with-db dbstruct run-id #t 
	      (lambda (db)
		(sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var))))

;;======================================================================
;; no-sync.db - small bits of data to be shared between servers
;;======================================================================

			  (string->number res)
			  #f)))
          (if newres
              newres
              res))
        res)))

(define (db:no-sync-close-db db stmt-cache)
#;(define (db:no-sync-close-db db stmt-cache)
  (db:safely-close-sqlite3-db db stmt-cache))

;; transaction protected lock aquisition
;; either:
;;    fails    returns  (#f . lock-creation-time)
;;    succeeds (returns (#t . lock-creation-time)
;; use (db:no-sync-del! db keyname) to release the lock

    (debug:print 2 *default-log-port* "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run")
    (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and"
	(db:with-db
	 dbstruct #f #f
	 (lambda (db)
	   (let ((res #f))
	     (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time,contour" comma keystr ") VALUES (?,?,?,?,strftime('%s','now'),?" comma valslots ");")
		    allvals)
	     (apply sqlite3:for-each-row 
		    (lambda (id)
		      (set! res id))
		    db
		    (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");")))
		      qry)
		    qryvals)
	     (sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res)
	     res))) 
	(begin
	  (debug:print-error 0 *default-log-port* "Called without all necessary keys")
	  #f))))

;; register a run with the db
;;
(define (db:insert-run dbstruct run-id keyvals runname state status user contour-in)
  (let* ((keys      (map car keyvals))
	 (keystr    (keys->keystr keys))
	 (contour   (or contour-in ""))  ;; empty string to force no hierarcy and be backwards compatible.
	 (comma     (if (> (length keys) 0) "," ""))
	 (andstr    (if (> (length keys) 0) " AND " ""))
	 (valslots  (keys->valslots keys)) ;; ?,?,? ...
	 (allvals   (append (list runname state status user contour) (map cadr keyvals)))
	 (qryvals   (append (list runname) (map cadr keyvals)))
	 (key=?str  (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND ")))
    (debug:print 3 *default-log-port* "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str)
    (debug:print 2 *default-log-port* "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run")
    (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and"
	(db:with-db
	 dbstruct run-id #f
	 (lambda (db)
	   (let ((res #f))
	     (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (id,runname,state,status,owner,event_time,contour" comma keystr ") VALUES (?,?,?,?,?,strftime('%s','now'),?" comma valslots ");")
		    run-id
		    allvals)
	     (apply sqlite3:for-each-row 
		    (lambda (id)
		      (set! res id))
		    db
		    (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");")))
		      qry)

;; Update run_stats for given run_id
;; input data is a list (state status count)
;;
(define (db:update-run-stats dbstruct run-id stats)
  ;; (mutex-lock! *db-transaction-mutex*)
  (db:with-db
   dbstruct
   #f
   run-id
   #f

   (lambda (db)
     ;; remove previous data
     
     (let* ((stmt1 (sqlite3:prepare db "DELETE FROM run_stats WHERE run_id=? AND state=? AND status=?;"))
	    (stmt2 (sqlite3:prepare db "INSERT INTO run_stats (run_id,state,status,count) VALUES (?,?,?,?);"))

	 (db:get-all-run-ids dbstruct)))
    res))

;; Convert calling routines to get list of run-ids and loop, do not use the get-tests-for-runs
;;

(define (db:delete-test-records dbstruct run-id test-id)
  (db:general-call dbstruct 'delete-test-step-records (list test-id))
  (db:general-call dbstruct 'delete-test-data-records (list test-id))
  (db:general-call dbstruct 'delete-test-step-records run-id (list test-id))
  (db:general-call dbstruct 'delete-test-data-records run-id (list test-id))
  (db:with-db
   dbstruct #f #f
   dbstruct run-id #f
   (lambda (db)
     (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id))))

;; 
(define (db:delete-old-deleted-test-records dbstruct)
  (let ((targtime (- (current-seconds)
		     (or (configf:lookup-number *configdat* "setup" "keep-deleted-records")

	       (mt:process-triggers dbstruct run-id test-id newstate newstatus)))))
     testnames)
    test-ids))

;; ;; speed up for common cases with a little logic
;; ;; NB// Ultimately this will be deprecated in deference to mt:test-set-state-status-by-id
;;
;; NOTE: processing triggers was called here - moved upstream
;;
;;      NOTE: run-id is not used
;; ;;
(define (db:test-set-state-status dbstruct run-id test-id newstate newstatus newcomment)
(define (db:test-set-state-status db run-id test-id newstate newstatus newcomment)
  (db:with-db
   dbstruct
   ;; run-id
   #f
   #t
   (lambda (db)
     (cond
      ((and newstate newstatus newcomment)
       (sqlite3:execute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus newcomment ;; (sdb:qry 'getid newcomment)
			test-id))
      ((and newstate newstatus)
       (sqlite3:execute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id))
      (else
       (if newstate   (sqlite3:execute db "UPDATE tests SET state=?   WHERE id=?;" newstate   test-id))
       (if newstatus  (sqlite3:execute db "UPDATE tests SET status=?  WHERE id=?;" newstatus  test-id))
       (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment ;; (sdb:qry 'getid newcomment)
  (cond
   ((and newstate newstatus newcomment)
    (sqlite3:execute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus newcomment ;; (sdb:qry 'getid newcomment)
		     test-id))
   ((and newstate newstatus)
    (sqlite3:execute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id))
   (else
    (if newstate   (sqlite3:execute db "UPDATE tests SET state=?   WHERE id=?;" newstate   test-id))
    (if newstatus  (sqlite3:execute db "UPDATE tests SET status=?  WHERE id=?;" newstatus  test-id))
    (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment test-id)))))
				       test-id))))))
  (mt:process-triggers dbstruct run-id test-id newstate newstatus))

;; NEW BEHAVIOR: Count tests running in all runs!
;;
(define (db:get-count-tests-running dbstruct run-id) ;; fastmode)
  (let* ((qry ;; (if fastmode
		;;   "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND NOT (uname = 'n/a' AND item_path = '') LIMIT 1;"
		  "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND NOT (uname = 'n/a' AND item_path = '');")) ;; )

	  (set! fail-count fcount)
	  (set! pass-count pcount))
	db 
	"SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count,
             (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'pass') AS pass_count;"
	test-id test-id)
       ;; Now rollup the counts to the central megatest.db
       (db:general-call dbstruct 'pass-fail-counts (list pass-count fail-count test-id))
       (db:general-call dbstruct 'pass-fail-counts run-id (list pass-count fail-count test-id))
       ;; if the test is not FAIL then set status based on the fail and pass counts.
       (db:general-call dbstruct 'test_data-pf-rollup (list test-id test-id test-id test-id))))))
       (db:general-call dbstruct 'test_data-pf-rollup run-id (list test-id test-id test-id test-id))))))

;; each section is a rule except "final" which is the final result
;;
;; [rule-5]
;; operator in
;; section LogFileBody
;; desc Output voltage

			   test-name))
	 (item-path    (db:test-get-item-path testdat))
         (tl-testdat   (db:get-test-info dbstruct run-id test-name ""))
         (tl-test-id   (if tl-testdat
			   (db:test-get-id tl-testdat)
			   #f)))
    (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) 
	(db:general-call dbstruct 'set-test-start-time (list test-id)))
    (mutex-lock! *db-transaction-mutex*)
	(db:general-call dbstruct 'set-test-start-time run-id (list test-id)))
    ;; (mutex-lock! *db-transaction-mutex*)
    (db:with-db
     dbstruct #f #f
     dbstruct run-id #f
     (lambda (db)
       (let ((tr-res
              (sqlite3:with-transaction
               db
               (lambda ()
                 ;; NB// Pass the db so it is part fo the transaction
		  ;; this call sets the item state/status
                 (db:test-set-state-status db run-id test-id state status comment) ;; this call sets the item state/status
                 (db:test-set-state-status db run-id test-id state status comment)
                 (if (not (equal? item-path "")) ;; only roll up IF incoming test is an item
                     (let* ((state-status-counts  (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path state status)) ;; item-path is used to exclude current state/status of THIS test
			      						  (state-stauses (db:roll-up-rules state-status-counts state status))
                          (newstate (car state-stauses))
                          (newstatus (cadr state-stauses)))
                       (debug:print 4 *default-log-port* "BB> tl-test-id="tl-test-id" ; "test-name":"item-path" newstate="newstate" newstatus="newstatus" len(sscs)="(length state-status-counts)  " state-status-counts: "
							(apply conc
                  (map (lambda (x)
                     (conc
                     		(with-output-to-string (lambda () (pp (dbr:counts->alist x)))) " | "))
                              state-status-counts))); end debug:print
   
		      (with-output-to-string (lambda () (pp (dbr:counts->alist x)))) " | "))
		       state-status-counts))); end debug:print
		       
                       (if tl-test-id
			   (db:test-set-state-status db run-id tl-test-id newstate newstatus #f)) ;; we are still in the transaction - must access the db and not the dbstruct
		       ))))))
         (mutex-unlock! *db-transaction-mutex*)
         ;; (mutex-unlock! *db-transaction-mutex*)
         (if (and test-id state status (equal? status "AUTO")) 
             (db:test-data-rollup dbstruct run-id test-id status))
         tr-res)))))
         tr-res)))
    ;; this was moved out of test-set-state-status
    (mt:process-triggers dbstruct run-id test-id state status)))


(define (db:roll-up-rules state-status-counts state status)
		(let* ((running     (length (filter (lambda (x)
                          (member (dbr:counts-state x) *common:running-states*))
                                 state-status-counts)))
           (bad-not-started      (length (filter (lambda (x)
                                      (and (equal? (dbr:counts-state x) "NOT_STARTED") 

                                         "\n--> newstatus            "newstatus
                                         "\n\n")

                        ;; NB// Pass the db so it is part of the transaction
         (list newstate newstatus)))

(define (db:set-state-status-and-roll-up-run dbstruct run-id curr-state curr-status)
    (mutex-lock! *db-transaction-mutex*)
  ;; (mutex-lock! *db-transaction-mutex*)
    (db:with-db
     dbstruct #f #f
     (lambda (db)
       (let ((tr-res
              (sqlite3:with-transaction
               db
               (lambda ()
                   (let* ((state-status-counts  (db:get-all-state-status-counts-for-run dbstruct run-id))
													(state-stauses (db:roll-up-rules state-status-counts #f #f ))
                          (newstate (car state-stauses))
                          (newstatus (cadr state-stauses))) 
                    (if (or (not (eq? newstate curr-state)) (not (eq?  newstatus curr-status)))
                   (db:set-run-state-status dbstruct run-id newstate newstatus )))))))
         (mutex-unlock! *db-transaction-mutex*)
         ;; (mutex-unlock! *db-transaction-mutex*)
         tr-res))))


(define (db:get-all-state-status-counts-for-run dbstruct run-id)
 (let* ((test-count-recs (db:with-db
                                  dbstruct #f #f
                                  (lambda (db)

   ((not (equal? megatest-version calling-version))
    (list #t (conc "Login warning due to mismatch megatest version: " calling-version ", " megatest-version)))
   
    (else
    (hash-table-set! *logged-in-clients* client-signature (current-seconds))
    '(#t "successful login"))))

(define (db:general-call dbstruct stmtname params)
(define (db:general-call dbstruct stmtname run-id params)
  (let ((query (let ((q (alist-ref (if (string? stmtname)
				       (string->symbol stmtname)
				       stmtname)
				   db:queries)))
 		 (if q (car q) #f))))
    (db:with-db
     dbstruct #f #f
     dbstruct run-id #f
     (lambda (db)
       (apply sqlite3:execute db query params)
       #t))))

;; get a summary of state and status counts to calculate a rollup
;;
(define (db:get-state-status-summary dbstruct run-id testname)

			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-writable? test-rundir))
				 test-rundir)
				((and (directory-exists? *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)) ;; ) ;; )

	    ;; Setting MT_LINKTREE here is almost certainly unnecessary. 
	    (let ((tconfig-file (conc hed "/" test-name "/testconfig")))
	      (if (and (common:file-exists? 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"))
			(bigmodenv      (module-environment 'bigmod)))
		    (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 env-to-use: bigmodenv))) ;; 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))))))))))

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

(define (db:get-server-info dbstruct apath dbname)
  (db:with-db
   dbstruct
   #f #f
   (lambda (db)
     (sqlite3:fold-row
      (lambda (res host port servkey pid ipaddr apath dbpath)
	(list host port servkey pid ipaddr apath dbpath))
      #f
      db
      "SELECT host,port,servkey,pid,ipaddr,apath,dbname FROM servers WHERE apath=? AND dbname=?;"
      apath dbname))))

(define (db:get-count-servers dbstruct apath)
  (db:with-db
   dbstruct
   #f #f
   (lambda (db)
     (sqlite3:fold-row
      (lambda (res count)
	(max res count))
      0
      db
      "SELECT count(*) FROM servers WHERE apath=?;"
      apath))))
)

)

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

(use format)
(require-library iup)
(import format)
(import iup)
(import (prefix iup iup:))
(use canvas-draw)
(import canvas-draw-iup)
(use regex typed-records matchable)
(import canvas-draw)

(import regex typed-records matchable srfi-69)

(declare (unit dcommon))

(declare (uses gutils))
(declare (uses db))
;; (declare (uses synchash))
(declare (uses dbmod))
(declare (uses mtver))
(declare (uses debugprint))

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

(import
 mtver
 dbmod
 debugprint
 )

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

;;======================================================================
;; C O M M O N   D A T A   S T R U C T U R E

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

    subgraph cluster_1 {
        node [style=filled,shape=box];

	rmt:send-receive -> "init-*remote* if needed" -> rmt:general-open-connection ->
	  rmt:send-receive-real;
	

	check_available_queue       -> remove_entries_over_10s_old;
	remove_entries_over_10s_old -> set_available [label="num_avail < 3"];
	remove_entries_over_10s_old -> exit [label="num_avail > 2"];

	set_available               -> delay_2s;
	delay_2s          -> check_place_in_queue;

	check_place_in_queue        -> "http:transport-launch" [label="at head"];
	check_place_in_queue        -> exit [label="not at head"];

	"client:login"              -> "server:shutdown" [label="login failed"];
	"server:shutdown"           -> exit;	

	subgraph cluster_2 {
		"http:transport-launch"       -> "http:transport-run";
		"http:transport-launch"       -> "http:transport-keep-running";

		"http:transport-keep-running" -> "tests running?";
		"tests running?"              -> "client:login" [label=yes];
		"tests running?"              -> "server:shutdown" [label=no];
		"client:login"                -> delay_5s [label="login ok"];
		delay_5s                      -> "http:transport-keep-running";
//	check_available_queue       -> remove_entries_over_10s_old;
//	remove_entries_over_10s_old -> set_available [label="num_avail < 3"];
//	remove_entries_over_10s_old -> exit [label="num_avail > 2"];
//
//	set_available               -> delay_2s;
//	delay_2s          -> check_place_in_queue;
//
//	check_place_in_queue        -> "http:transport-launch" [label="at head"];
//	check_place_in_queue        -> exit [label="not at head"];
//
//	"client:login"              -> "server:shutdown" [label="login failed"];
//	"server:shutdown"           -> exit;	
//
//	subgraph cluster_2 {
//		"http:transport-launch"       -> "http:transport-run";
//		"http:transport-launch"       -> "http:transport-keep-running";
//
//		"http:transport-keep-running" -> "tests running?";
//		"tests running?"              -> "client:login" [label=yes];
//		"tests running?"              -> "server:shutdown" [label=no];
//		"client:login"                -> delay_5s [label="login ok"];
//		delay_5s                      -> "http:transport-keep-running";
	}

//	}
	// start_server -> "server_running?";
	// "server_running?" -> set_available [label="no"];
	// "server_running?" -> delay_2s [label="yes"];
	// delay_2s -> "still_running?";
	// "still_running?" -> ping_server [label=yes];
	// "still_running?" -> set_available [label=no];
	// ping_server -> exit [label=alive];
	// ping_server -> remove_server_record [label=dead];
	// remove_server_record -> set_available;
	// set_available -> avail_delay [label="delay 3s"];
	// avail_delay -> "first_in_queue?";
	// 
	// "first_in_queue?" -> set_running [label=yes];
	// set_running -> get_next_port -> handle_requests;
	// "first_in_queue?" -> "dead_entry_in_queue?" [label=no];
	// "dead_entry_in_queue?" -> "server_running?" [label=no];
	// "dead_entry_in_queue?" -> "remove_dead_entries" [label=yes];
	// remove_dead_entries -> "server_running?";
	// 
	// handle_requests -> start_shutdown [label="no traffic\nno running tests"];
	// handle_requests -> shutdown_request;
	// start_shutdown -> shutdown_delay;
	// shutdown_request -> shutdown_delay;
	// shutdown_delay -> exit;
	
        label = "server:launch";
        color=brown;
//
//	// start_server -> "server_running?";
//	// "server_running?" -> set_available [label="no"];
//	// "server_running?" -> delay_2s [label="yes"];
//	// delay_2s -> "still_running?";
//	// "still_running?" -> ping_server [label=yes];
//	// "still_running?" -> set_available [label=no];
//	// ping_server -> exit [label=alive];
//	// ping_server -> remove_server_record [label=dead];
//	// remove_server_record -> set_available;
//	// set_available -> avail_delay [label="delay 3s"];
//	// avail_delay -> "first_in_queue?";
//	// 
//	// "first_in_queue?" -> set_running [label=yes];
//	// set_running -> get_next_port -> handle_requests;
//	// "first_in_queue?" -> "dead_entry_in_queue?" [label=no];
//	// "dead_entry_in_queue?" -> "server_running?" [label=no];
//	// "dead_entry_in_queue?" -> "remove_dead_entries" [label=yes];
//	// remove_dead_entries -> "server_running?";
//	// 
//	// handle_requests -> start_shutdown [label="no traffic\nno running tests"];
//	// handle_requests -> shutdown_request;
//	// start_shutdown -> shutdown_delay;
//	// shutdown_request -> shutdown_delay;
//	// shutdown_delay -> exit;
//	
//        label = "server:launch";
//        color=brown;
    }

//     client_start_server -> start_server;
//     handle_requests -> read_write;
//     read_write -> handle_requests;
}

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

			     (conc "# error, no command for step "stepname)))
	 (script         "") ; "#!/bin/bash\n") ;; yep, we depend on bin/bash FIXME!!!\
	 (logpro-file    (conc stepname ".logpro"))
	 (html-file      (conc stepname ".html"))
	 (dat-file       (conc stepname ".dat"))
	 (tconfig-logpro (configf:lookup testconfig "logpro" stepname))
	 (logpro-used    (common:file-exists? logpro-file)))
    (setenv "MT_STEP_NAME" stepname)
    (set-environment-variable! "MT_STEP_NAME" stepname)
    (hash-table-set! all-steps-dat stepname `((params . ,paramparts)))
    (debug:print 0 *default-log-port* "stepparts: " stepparts ", stepparams: " stepparams
                 ", paramparts: " paramparts ", subrun: " subrun ", stepcmd: " stepcmd)
    
    (if (and tconfig-logpro
	     (not logpro-used)) ;; no logpro file found but have a defn in the testconfig
	(begin

			   (begin
			     (thread-sleep! 2)
			     (processloop (+ i 1))))
		       )))))
    (debug:print-info 0 *default-log-port* "step " stepname " completed with exit code " (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2))
    ;; now run logpro if needed
    (if logpro-used
	(let* ((logpro-exe (or (getenv "LOGPRO_EXE") "logpro"))
	(let* ((logpro-exe (or (get-environment-variable "LOGPRO_EXE") "logpro"))
               (pid        (process-run (conc "/bin/sh -c '"logpro-exe" "logpro-file " " (conc stepname ".html") " < " stepname ".log > /dev/null'"))))
	  (let processloop ((i 0))
	    (let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
			(mutex-lock! m)
			;; (make-launch:einf pid: pid exit-status: exit-status exit-code: exit-code)
			(launch:einf-pid-set!         exit-info pid)         ;; (vector-set! exit-info 0 pid)
			(launch:einf-exit-status-set! exit-info exit-status) ;; (vector-set! exit-info 1 exit-status)

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

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

(use srfi-1 regex regex-case srfi-69)
(import srfi-1 regex regex-case srfi-69)

(declare (unit gutils))

;; NOTE: These functions will move to iuputils

(define (gutils:colors-similar? color1 color2)
  (let* ((c1 (map string->number (string-split color1)))
	 (c2 (map string->number (string-split color2)))

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

;;======================================================================
;; Tests
;;======================================================================

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

(declare (unit tests))
(declare (unit testsmod))
(declare (uses lock-queue))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
(declare (uses dbmod))
(declare (uses commonmod))
(declare (uses itemsmod))
(declare (uses runconfigmod))

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

;; Populate the links tree with index.html files
;;

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

(declare (unit itemsmod))
(declare (uses mtargs))
(declare (uses debugprint))
(declare (uses configfmod))
(declare (uses commonmod))

(module itemsmod
	*
	
(import scheme

	chicken.base

      (if elflag
	  (begin
	    (set! res (append res (list item)))
	    (loop (+ indx 1)
		  '()
		  #f)))
      res)))
            ;; Nope, not now, return null as of 6/6/2011
		
(define (items:check-valid-items class item)
  (let ((valid-values (let ((s (configf:lookup *configdat* "validvalues" class)))
;; Nope, not now, return null as of 6/6/2011

(define (items:check-valid-items valid-values class item)
  (let ((valid-values (let ((s valid-values)) ;; (configf:lookup *configdat* "validvalues" class)))
			(if s (string-split s) #f))))
    (if valid-values
	(if (member item valid-values)
	    item #f)
	item)))

;;  '(("k1" "k2" "k3")

			     (alist-ref "keep-going" params equal?)
			     #f)))
	(debug:print 0 *default-log-port* "keep-going=" keep-going)
	(and keep-going (equal? (car keep-going) "yes")))))

;; if handed a string, process it, else look for MT_CMDINFO
(define (launch:get-cmdinfo-assoc-list #!key (encoded-cmd #f))
  (let ((enccmd (if encoded-cmd encoded-cmd (getenv "MT_CMDINFO"))))
  (let ((enccmd (if encoded-cmd encoded-cmd (get-environment-variable "MT_CMDINFO"))))
    (if enccmd
	(common:read-encoded-string enccmd)
	'())))

(define (launch:manage-steps run-id test-id item-path fullrunscript ezsteps subrun test-name tconfigreg exit-info m)
  ;; (let-values
  ;;  (((pid exit-status exit-code)

			     (prevstep #f))
                    (debug:print-info 0 *default-log-port* "Processing ezstep \"" (string-intersperse ezstep " ") "\"")
		    ;; check exit-info (vector-ref exit-info 1)
		    (if (launch:einf-exit-status exit-info) ;; (vector-ref exit-info 1)
			(let* ((logpro-used (launch:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat))
			       (stepname    (car ezstep))
			       (stepparms   (hash-table-ref all-steps-dat stepname)))
			  (setenv "MT_STEP_NAME" stepname)
			  (set-environment-variable! "MT_STEP_NAME" stepname)
			  (pp (hash-table->alist all-steps-dat))
			  ;; 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 (steprun-good? logpro-used (launch:einf-exit-code exit-info) stepparms)
			      (if (not (null? tal))
				  (loop (car tal) (cdr tal) stepname))

          (rmt:set-state-status-and-roll-up-items run-id test-id 'foo "RUNNING" "n/a" "was marked dead; really still running.")
          ;;(set! kill-reason "KILLING TEST because it was marked as DEAD by launch:handle-zombie-tests (might indicate really overloaded server or else overzealous setup.deadtime)") ;; MARK RUNNING
          (set! kill-job? #f)))

        (debug:print 4 *default-log-port* "cpu: " new-cpu-load " disk: " new-disk-free " last-sync: " last-sync " do-sync: " do-sync)
        (launch:handle-zombie-tests run-id)
        (when do-sync
          ;;(with-output-to-file (conc (getenv "MT_TEST_RUN_DIR") "/last-loadinfo.log" #:append)
          ;;(with-output-to-file (conc (get-environment-variable "MT_TEST_RUN_DIR") "/last-loadinfo.log" #:append)
          ;;  (lambda () (pp (list (current-seconds) new-cpu-load new-disk-free (calc-minutes)))))
          ;; (common:telemetry-log "zombie" (conc  "launch:monitor-job - dosync started at "(current-seconds)))
          (tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f)
          ;; (common:telemetry-log "zombie" (conc "launch:monitor-job - dosync finished at "(current-seconds)))
	  )
        
	(if kill-job? 

                        (if do-sync (current-seconds) last-sync)))))))
    (tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f))) ;; NOTE: Checking twice for keep-going is intentional


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

                                                    (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-area-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 (get-environment-variable "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)

	   (or (args:get-arg "-run")
	       (args:get-arg "-runtests")
	       (args:get-arg "-execute")))
      (let* ((linktree (common:get-linktree)) ;; (get-environment-variable "MT_LINKTREE"))
	     (target   (common:args-get-target exit-if-bad: #t))
	     (runname  (or (args:get-arg "-runname")
			   (args:get-arg ":runname")
			   (getenv "MT_RUNNAME")))
			   (get-environment-variable "MT_RUNNAME")))
	     (fulldir  (conc linktree "/"
			     target "/"
			     runname)))
	(if (and linktree (common:file-exists? linktree)) ;; can't proceed without linktree
	    (begin
	      (debug:print-info 0 *default-log-port* "Have -run with target=" target ", runname=" runname ", fulldir=" fulldir ", testpatt=" (or (args:get-arg "-testpatt") "%"))
	      (if (not (common:file-exists? fulldir))

		  (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         (common:list-or-null (rmt:get-keys)
							    message: "Failed to retrieve keys in launch.scm. Please report this to the developers."))
			 (key-vals     (keys:target->keyval keys target))
			 (linktree     (common:get-linktree)) ;; (or (getenv "MT_LINKTREE")(if *configdat* (configf:lookup *configdat* "setup" "linktree") #f)))
			 (linktree     (common:get-linktree)) ;; (or (get-environment-variable "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"
					env-to-use: (module-environment 'bigmod)))
			 (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-area-name)))
	      (set-environment-variable! "MT_RUN_AREA_HOME" *toppath*)
	      (set-environment-variable! "MT_TESTSUITENAME" (common:get-area-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))

	    (list #f #f)))))


(define (launch:handle-zombie-tests run-id)
  (let* ((key (conc "zombiescan-runid-"run-id))
         (now (current-seconds))
         (threshold (- (current-seconds)  (* 2 (or (configf:lookup-number *configdat* "setup" "deadtime") 120))))
         (val (rmt:get-var key))
         (val (rmt:get-var run-id key))
         (do-scan?
          (cond
           ((not val)
            #t)
           ((< val threshold)
            #t)
           (else #f))))
    (when do-scan?
      (debug:print 1 *default-log-port* "INFO: search and mark zombie tests")
      (rmt:set-var key (current-seconds))
      (rmt:set-var run-id key (current-seconds))
      (runs:find-and-mark-incomplete-and-check-end-of-run run-id #f))))





;; 1. look though disks list for disk with most space

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

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

                                                      #f ;; sort-by
                                                      #f ;; sort-order
                                                      #f ;; get full data (not 'shortlist)
                                                      0 ;; (runs:gendat-inc-results-last-update *runs:general-data*) ;; last update time
                                                      'dashboard)
                               '()))
           (log-dir         (conc *toppath* "/logs"))
           (log-file        (conc "post-hook-" (string-translate (getenv "MT_TARGET") "/" "-") "-" (getenv "MT_RUNNAME") ".log"))
           (log-file        (conc "post-hook-" (string-translate (get-environment-variable "MT_TARGET") "/" "-") "-" (get-environment-variable "MT_RUNNAME") ".log"))
           (full-log-fname  (conc log-dir "/" log-file)))
      (if run-post-hook
          ;; (if (null? existing-tests)
          ;;    (debug:print 0 *default-log-port* "Skipping post-hook call \"" run-post-hook "\" as there are existing tests for this run.")))))
	  (let* ((use-log-dir (if (not (directory-exists? log-dir))
				  (handle-exceptions
				      exn

	      (system (conc run-post-hook " >> " actual-logf " 2>&1"))
	      (debug:print-info 0 *default-log-port* "post-hook \"" run-post-hook "\" took " (- (current-seconds) start-time) " seconds to run."))))))


(define (runs:rerun-hook test-id new-test-path testdat rerunlst)
    (let* ((rerun-hook   (configf:lookup *configdat* "runs" "rerun-hook"))
           (log-dir         (conc *toppath* "/reruns/logs"))
           (target (getenv "MT_TARGET"))
           (target (get-environment-variable "MT_TARGET"))
           (runname (common:args-get-runname))
           (rundir (db:test-get-rundir testdat))
           (tarfiledir (conc *toppath* "/reruns"))
           (status (db:test-get-status testdat))
           (comment (conc "\"" (db:test-get-comment testdat) "\"" ))
           (testname (db:test-get-testname testdat))
           (itempath (db:test-get-item-path testdat))

(define (runs:update-junit-test-reporter-xml run-id)
  (let*	((junit-test-reporter	(configf:lookup *configdat* "runs" "junit-test-reporter-xml"))
	 (junit-test-report-dir  (configf:lookup *configdat* "runs" "junit-test-report-dir"))
	 (xml-dir		(if (and junit-test-reporter (equal? junit-test-reporter "yes" ))
				    (if junit-test-report-dir
					junit-test-report-dir
					(conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME")))
					(conc (get-environment-variable "MT_LINKTREE") "/" (get-environment-variable "MT_TARGET") "/" (get-environment-variable "MT_RUNNAME")))
				    #f))
	 (xml-ts-name		(if xml-dir
				    (conc (getenv "MT_TESTSUITENAME")"."(string-translate (getenv "MT_TARGET") "/" ".") "." (getenv "MT_RUNNAME"))
				    (conc (get-environment-variable "MT_TESTSUITENAME")"."(string-translate (get-environment-variable "MT_TARGET") "/" ".") "." (get-environment-variable "MT_RUNNAME"))
				    #f))
         (keyname               (if xml-ts-name (common:get-signature xml-ts-name) #f))
	 (xml-path		(if xml-dir
				    (conc xml-dir "/" keyname ".xml")
				    #f))

	 (test-data		(if xml-dir

  '(*TOP*
    (*PI* xml "version='1.0'")
    (testsuite)))

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

;; set up needed environment variables given a run-id and optionally a target, itempath etc.
;;
(define (runs:set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)(intarget #f)(testname #f)(itempath #f))
  ;;(bb-check-path msg: "runs:set-megatest-env-vars entry")
  (let* ((target    (or intarget 
			(common:args-get-target)
			(get-environment-variable "MT_TARGET")))
	 (keys      (if inkeys    inkeys    (common:get-fields *configdat*) #;(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")  "/"
					(getenv "MT_TARGET")    "/"
					(getenv "MT_RUNNAME")   "/"
					(getenv "MT_TEST_NAME")
	(set-environment-variable! "MT_TEST_RUN_DIR" (conc (get-environment-variable "MT_LINKTREE")  "/"
					(get-environment-variable "MT_TARGET")    "/"
					(get-environment-variable "MT_RUNNAME")   "/"
					(get-environment-variable "MT_TEST_NAME")
					(if (and itempath
						 (not (equal? itempath "")))
					    (conc "/" itempath)
					    ""))))))

  
;; cache the runconfigs in $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME/.runconfig
;;
(define (full-runconfigs-read)
  ;; in the envprocessing branch the below code replaces the further below code
  ;;  (if (eq? *configstatus* 'fulldata)
  ;;      *runconfigdat*
  ;;      (begin
  ;;	(launch:setup)
  ;;	*runconfigdat*)))
  (let* ((rundir (if (and (getenv "MT_LINKTREE")(getenv "MT_TARGET")(getenv "MT_RUNNAME"))
		     (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME"))
  (let* ((rundir (if (and (get-environment-variable "MT_LINKTREE")(get-environment-variable "MT_TARGET")(get-environment-variable "MT_RUNNAME"))
		     (conc (get-environment-variable "MT_LINKTREE") "/" (get-environment-variable "MT_TARGET") "/" (get-environment-variable "MT_RUNNAME"))
		     #f))
	 (cfgf   (if rundir (conc rundir "/.runconfig." megatest-version "-" megatest-fossil-hash) #f)))
    (if (and cfgf
	     (file-exists? cfgf)
	     (file-writable? cfgf)
	     (common:use-cache?))
	(configf:read-alist cfgf) ;; use the cached file
	(let* ((keys   (common:get-fields *configdat*))     ;; (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))
			   ;; (configf: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-writable? rundir))
	      (begin

  (let* ((start-time (current-seconds))
	 (am-server  (args:get-arg "-server"))
	 (dbfile     (args:get-arg "-db"))
	 (apath      *toppath*))
    (let loop ()
      (thread-sleep! 5) ;; add control / setting for this
      (if am-server
	  (if (not  *dbstruct-db*)
	  (if (not  *dbstruct-db*) ;; skip syncing until db is setup
	      (loop)
	      (begin
		;; (debug:print-info 0 *default-log-port* "syncing "apath" "dbfile" at "(current-seconds))
	      (db:sync-inmem->disk *dbstruct-db* *toppath* dbfile))))))
		;; (db:sync-inmem->disk *dbstruct-db* apath dbfile)
		(loop)))))))
  
;; 
;; (let ((dbstruct 
;; 	    (debug:print-info 13 *default-log-port* "after db:setup with dbstruct=" dbstruct)
;; 	    (cond
;; 	     ((dbr:dbstruct-read-only dbstruct)
;; 	      (debug:print-info 13 *default-log-port* "loading read-only watchdog")

	  srfi-98
	  srfi-69

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

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

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

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

     ;;======================================================================
     ;; Test commands (i.e. for use inside tests)
     ;;======================================================================
     
     (define (megatest:step step state status logfile msg)
       (if (not (getenv "MT_CMDINFO"))
           (begin
;;======================================================================
;; Test commands (i.e. for use inside tests)
;;======================================================================

(define (megatest:step step state status logfile msg)
  (if (not (get-environment-variable "MT_CMDINFO"))
      (begin
     	(debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!")
     	(exit 5))
           (let* ((cmdinfo   (common:read-encoded-string (getenv "MT_CMDINFO")))
      (let* ((cmdinfo   (common:read-encoded-string (get-environment-variable "MT_CMDINFO")))
     	     (transport (assoc/default 'transport cmdinfo))
     	     (testpath  (assoc/default 'testpath  cmdinfo))
     	     (test-name (assoc/default 'test-name cmdinfo))
     	     (runscript (assoc/default 'runscript cmdinfo))
     	     (db-host   (assoc/default 'db-host   cmdinfo))
     	     (run-id    (assoc/default 'run-id    cmdinfo))
     	     (test-id   (assoc/default 'test-id   cmdinfo))

     	    (let ((comment (launch:load-logpro-dat run-id test-id step)))
     	      ;; (rmt:test-set-log! run-id test-id (conc stepname ".html"))))
     	      (rmt:teststep-set-status! run-id test-id step state status (or comment msg) logfile))
     	    (begin
     	      (debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -step")
     	      (exit 6))))))

     ;;======================================================================
     ;; full run
     ;;======================================================================
     
     (define (handle-run-requests target runname keys keyvals need-clean)	 
       (if (or (args:get-arg "-kill-rerun") (args:get-arg "-rerun-clean")) ;; first set states/statuses correct
           ;; For rerun-clean do we or do we not support the testpatt?
           (let ((states   (or (configf:lookup *configdat* "validvalues" "cleanrerun-states")
;;======================================================================
;; full run
;;======================================================================

(define (handle-run-requests target runname keys keyvals need-clean)	 
  (if (or (args:get-arg "-kill-rerun") (args:get-arg "-rerun-clean")) ;; first set states/statuses correct
      ;; For rerun-clean do we or do we not support the testpatt?
      (let ((states   (or (configf:lookup *configdat* "validvalues" "cleanrerun-states")
     			  "KILLREQ,KILLED,UNKNOWN,INCOMPLETE,STUCK,NOT_STARTED"))
     	    (statuses (or (configf:lookup *configdat* "validvalues" "cleanrerun-statuses")
     			  "FAIL,INCOMPLETE,ABORT,CHECK,DEAD,PREQ_FAIL,PREQ_DISCARDED")))
     	(hash-table-set! args:arg-hash "-preclean" #t)
     	(runs:operate-on 'set-state-status
     			 target
     			 (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))

     			 target
     			 (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
     			 ;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
     			 (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
     			 ;; state:  states
     			 status: statuses
     			 new-state-status: "NOT_STARTED,n/a")))
       ;; RERUN ALL
       (if (args:get-arg "-rerun-all") ;; first set states/statuses correct
           (let* ((rconfig (full-runconfigs-read)))
  ;; RERUN ALL
  (if (args:get-arg "-rerun-all") ;; first set states/statuses correct
      (let* ((rconfig (full-runconfigs-read)))
     	(hash-table-set! args:arg-hash "-preclean" #t)
     	(runs:operate-on 'set-state-status
     			 target
     			 (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
     			 (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt")
     			 state:  #f
     			 ;; status: statuses
     			 new-state-status: "NOT_STARTED,n/a")
     	(runs:clean-cache target runname *toppath*)
     	(runs:operate-on 'set-state-status
     			 target
     			 (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
     			 (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt")
     			 ;; state:  states
     			 status: #f
     			 new-state-status: "NOT_STARTED,n/a")))
       (let* ((config-reruns      (let ((x (configf:lookup *configdat* "setup" "reruns")))
  (let* ((config-reruns      (let ((x (configf:lookup *configdat* "setup" "reruns")))
     			       (if x (string->number x) #f)))
     	 (rerun-cnt (if config-reruns
     			config-reruns
     			1)))
     
         (runs:run-tests target
    
    (runs:run-tests target
     		    runname
     		    #f ;; (common:args-get-testpatt #f)
     		    ;; (or (args:get-arg "-testpatt")
     		    ;;     "%")
     		    (bdat-user *bdat*)
     		    args:arg-hash
     		    run-count: rerun-cnt)))

     ;; csv processing record
     (define (make-refdb:csv)
       (vector 
        (make-sparse-array)
        (make-hash-table)
        (make-hash-table)
        0
        0))
     (define-inline (refdb:csv-get-svec     vec)    (vector-ref  vec 0))
     (define-inline (refdb:csv-get-rows     vec)    (vector-ref  vec 1))
     (define-inline (refdb:csv-get-cols     vec)    (vector-ref  vec 2))
     (define-inline (refdb:csv-get-maxrow   vec)    (vector-ref  vec 3))
     (define-inline (refdb:csv-get-maxcol   vec)    (vector-ref  vec 4))
     (define-inline (refdb:csv-set-svec!    vec val)(vector-set! vec 0 val))
     (define-inline (refdb:csv-set-rows!    vec val)(vector-set! vec 1 val))
     (define-inline (refdb:csv-set-cols!    vec val)(vector-set! vec 2 val))
     (define-inline (refdb:csv-set-maxrow!  vec val)(vector-set! vec 3 val))
     (define-inline (refdb:csv-set-maxcol!  vec val)(vector-set! vec 4 val))
     
     (define (get-dat results sheetname)
       (or (hash-table-ref/default results sheetname #f)
           (let ((tmp-vec  (make-refdb:csv)))
;; csv processing record
(define (make-refdb:csv)
  (vector 
   (make-sparse-array)
   (make-hash-table)
   (make-hash-table)
   0
   0))
(define-inline (refdb:csv-get-svec     vec)    (vector-ref  vec 0))
(define-inline (refdb:csv-get-rows     vec)    (vector-ref  vec 1))
(define-inline (refdb:csv-get-cols     vec)    (vector-ref  vec 2))
(define-inline (refdb:csv-get-maxrow   vec)    (vector-ref  vec 3))
(define-inline (refdb:csv-get-maxcol   vec)    (vector-ref  vec 4))
(define-inline (refdb:csv-set-svec!    vec val)(vector-set! vec 0 val))
(define-inline (refdb:csv-set-rows!    vec val)(vector-set! vec 1 val))
(define-inline (refdb:csv-set-cols!    vec val)(vector-set! vec 2 val))
(define-inline (refdb:csv-set-maxrow!  vec val)(vector-set! vec 3 val))
(define-inline (refdb:csv-set-maxcol!  vec val)(vector-set! vec 4 val))

(define (get-dat results sheetname)
  (or (hash-table-ref/default results sheetname #f)
      (let ((tmp-vec  (make-refdb:csv)))
     	(hash-table-set! results sheetname tmp-vec)
     	tmp-vec)))
     
     ;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions
     (define (open-logfile logpath-in)
       (condition-case
        (let* ((log-dir (or (pathname-directory logpath-in) "."))

;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions
(define (open-logfile logpath-in)
  (condition-case
   (let* ((log-dir (or (pathname-directory logpath-in) "."))
     	  (fname   (pathname-strip-directory logpath-in))
     	  (logpath (if (> (string-length fname) 250)
     		       (let ((newlogf (conc log-dir "/" (common:get-signature fname) ".log")))
     			 (debug:print 0 *default-log-port* "WARNING: log file " logpath-in " path too long, converted to " newlogf)
     			 newlogf)
     		       logpath-in)))
          (if (not (directory-exists? log-dir))
              (system (conc "mkdir -p " log-dir)))
          (open-output-file logpath))
        (exn ()
             (debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath-in)
             (define *didsomething* #t)  
             (exit 1))))
     (if (not (directory-exists? log-dir))
	 (system (conc "mkdir -p " log-dir)))
     (open-output-file logpath))
   (exn ()
	(debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath-in)
	(define *didsomething* #t)  
	(exit 1))))

(define (debug:setup)
  (let ((debugstr (or (args:get-arg "-debug")
      		      (args:get-arg "-debug-noprop")
      		      (getenv "MT_DEBUG_MODE"))))
      		      (get-environment-variable "MT_DEBUG_MODE"))))
    (set! *verbosity* (debug:calc-verbosity debugstr 'q))
    (debug:check-verbosity *verbosity* debugstr)
    ;; if we were handed a bad verbosity rule then we will override it with 1 and continue
    (if (not *verbosity*)(set! *verbosity* 1))
    (if (and (not (args:get-arg "-debug-noprop"))
      	     (or (args:get-arg "-debug")
      		 (not (getenv "MT_DEBUG_MODE"))))
      	(setenv "MT_DEBUG_MODE" (if (list? *verbosity*)
      		 (not (get-environment-variable "MT_DEBUG_MODE"))))
      	(set-environment-variable! "MT_DEBUG_MODE" (if (list? *verbosity*)
      				    (string-intersperse (map conc *verbosity*) ",")
      				    (conc *verbosity*))))))

;; check verbosity, #t is ok
(define (debug:check-verbosity verbosity vstr)
  (if (not (or (number? verbosity)
     	       (list?   verbosity)))
      (begin
     	(print "ERROR: Invalid debug value \"" vstr "\"")
     	#f)
      #t))

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

(define help (conc "
Megatest, documentation at http://www.kiatoa.com/fossils/megatest
  version " megatest-version "
  license GPL, Copyright Matt Welland 2006-2017
 
Usage: megatest [options]
  -h                      : this help

         (debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv))  " ")))
     
     ;; before doing anything else change to the start-dir if provided
     ;;
     (if (args:get-arg "-start-dir")
         (if (common:file-exists? (args:get-arg "-start-dir"))
             (let ((fullpath (common:real-path (args:get-arg "-start-dir"))))
               (setenv "PWD" fullpath)
               (set-environment-variable! "PWD" fullpath)
               (change-directory fullpath))
     	(begin
     	  (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.")
     	  (exit 1))))
     
     ;; immediately set MT_TARGET if -reqtarg or -target are available
     ;;
     (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target"))))
       (if targ (setenv "MT_TARGET" targ)))
       (if targ (set-environment-variable! "MT_TARGET" targ)))
     
     ;; The watchdog is to keep an eye on things like db sync etc.
     ;;
(init-watchdog)
;; (init-watchdog)
  
;;      (define (debug:debug-mode n)
;;        (cond
;;         ((and (number? *verbosity*)   ;; number number
;;      	 (number? n))
;;          (<= n *verbosity*))
;;         ((and (list? *verbosity*)     ;; list   number

         (let ((newval (conc (args:get-arg "-testpatt") "/" (args:get-arg "-itempatt"))))
           (debug:print 0 *default-log-port* "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval)
           (hash-table-set! args:arg-hash "-testpatt" newval)
           (hash-table-delete! args:arg-hash "-itempatt")))
     
     (if (args:get-arg "-runtests")
         (debug:print 0 *default-log-port* "WARNING: \"-runtests\" is deprecated. Use \"-run\" with \"-testpatt\" instead"))
     
     (on-exit std-exit-procedure)

     (debug:print 0 *default-log-port* "on-exit disabled. Please re-enable")
     ;; (on-exit std-exit-procedure)
     
     ;;======================================================================
     ;; Misc general calls
     ;;======================================================================

;; TODO: Restore this functionality

     #; (if (and (args:get-arg "-cache-db")
              (args:get-arg "-source-db"))
         (let* ((temp-dir (or (args:get-arg "-target-db") (create-directory (conc "/tmp/" (getenv "USER") "/" (string-translate (current-directory) "/" "_")))))
         (let* ((temp-dir (or (args:get-arg "-target-db") (create-directory (conc "/tmp/" (get-environment-variable "USER") "/" (string-translate (current-directory) "/" "_")))))
                (target-db (conc temp-dir "/cached.db"))
                (source-db (args:get-arg "-source-db")))        
           (db:cache-for-read-only source-db target-db)
           (set! *didsomething* #t)))
     
     ;; handle a clean-cache request as early as possible
     ;;

            (else
     	(debug:print-error 0 *default-log-port* "-dumpmode of " (args:get-arg "-dumpmode") " not recognised")))
           (set! *didsomething* #t)
           (pop-directory)
           (bdat-time-to-exit-set! *bdat* #t)))
     
     (if (args:get-arg "-show-cmdinfo")
         (if (or (args:get-arg ":value")(getenv "MT_CMDINFO"))
     	(let ((data (common:read-encoded-string (or (args:get-arg ":value")(getenv "MT_CMDINFO")))))
         (if (or (args:get-arg ":value")(get-environment-variable "MT_CMDINFO"))
     	(let ((data (common:read-encoded-string (or (args:get-arg ":value")(get-environment-variable "MT_CMDINFO")))))
     	  (if (equal? (args:get-arg "-dumpmode") "json")
     	      (json-write data)
     	      (pp data))
     	  (set! *didsomething* #t))
     	(debug:print-info 0 *default-log-port* "environment variable MT_CMDINFO is not set")))
     
     ;;======================================================================

     
     ;;======================================================================
     ;; Get paths to tests
     ;;======================================================================
     ;; Get test paths matching target, runname, and testpatt
     (if (or (args:get-arg "-test-files")(args:get-arg "-test-paths"))
         ;; if we are in a test use the MT_CMDINFO data
         (if (getenv "MT_CMDINFO")
         (if (get-environment-variable "MT_CMDINFO")
     	(let* ((startingdir (current-directory))
     	       (cmdinfo   (common:read-encoded-string (getenv "MT_CMDINFO")))
     	       (cmdinfo   (common:read-encoded-string (get-environment-variable "MT_CMDINFO")))
     	       (transport (assoc/default 'transport cmdinfo))
     	       (testpath  (assoc/default 'testpath  cmdinfo))
     	       (test-name (assoc/default 'test-name cmdinfo))
     	       (runscript (assoc/default 'runscript cmdinfo))
     	       (db-host   (assoc/default 'db-host   cmdinfo))
     	       (run-id    (assoc/default 'run-id    cmdinfo))
     	       (itemdat   (assoc/default 'itemdat   cmdinfo))

     	;;     NEW POLICY - -setlog sets test overall log on every call.
     	(args:get-arg "-set-toplog")
     	(args:get-arg "-test-status")
     	(args:get-arg "-set-values")
     	(args:get-arg "-load-test-data")
     	(args:get-arg "-runstep")
     	(args:get-arg "-summarize-items"))
         (if (not (getenv "MT_CMDINFO"))
         (if (not (get-environment-variable "MT_CMDINFO"))
     	(begin
     	  (debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!")
     	  (exit 5))
     	(let* ((startingdir (current-directory))
     	       (cmdinfo   (common:read-encoded-string (getenv "MT_CMDINFO")))
     	       (cmdinfo   (common:read-encoded-string (get-environment-variable "MT_CMDINFO")))
     	       (transport (assoc/default 'transport cmdinfo))
     	       (testpath  (assoc/default 'testpath  cmdinfo))
     	       (test-name (assoc/default 'test-name cmdinfo))
     	       (runscript (assoc/default 'runscript cmdinfo))
     	       (db-host   (assoc/default 'db-host   cmdinfo))
     	       (run-id    (assoc/default 'run-id    cmdinfo))
     	       (test-id   (assoc/default 'test-id   cmdinfo))

          (args:get-arg "-target")
          (args:get-arg "-runname")
          (args:get-arg "-diff-html")
          (args:get-arg "-diff-email"))
         (set! *didsomething* #t)
         (exit 0)))
     
     (if (or (getenv "MT_RUNSCRIPT")
     (if (or (get-environment-variable "MT_RUNSCRIPT")
     	(args:get-arg "-repl")
     	(args:get-arg "-load"))
         (let* ((toppath (launch:setup)))
		
     	        ;; (dbstruct (if (and toppath
		;; 	      #;(common:on-homehost?))
		;; 	 (db:setup #f) ;; sets up main.db
		;; 	 #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f)))
	   (if *toppath*
	       (cond
		((getenv "MT_RUNSCRIPT")
		((get-environment-variable "MT_RUNSCRIPT")
		 ;; How to run megatest scripts
		 ;;
		 ;; #!/bin/bash
		 ;;
		 ;; export MT_RUNSCRIPT=yes
		 ;; megatest << EOF
		 ;; (print "Hello world")

(declare (unit runs))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))

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

nng-test : nng-test.scm
	csc nng-test.scm

test : nng-test
	./nng-test do-test

(import (chicken io)
	(chicken file)
	(chicken file posix)
        (chicken string)
	(chicken process-context)
	(chicken process-context posix)
        miscmacros
        nng
        srfi-18
	srfi-69
        test
	matchable
	typed-records
	system-information
	directory-utils
	)

(define help "Usage: nng-test COMMAND
  where COMMAND is one of:
    dotest    : run the basic req/rep test
")

(define address-tcp-1 "tcp://localhost:5555")
(define address-tcp-2 "tcp://localhost:6666")

(define address-inproc-1 "inproc://local1")
(define address-inproc-2 "inproc://local2")

;;;
;;; Req-Rep
;;;
(define (make-listening-reply-socket address)
  (let ((socket (make-rep-socket)))
    (socket-set! socket 'nng/recvtimeo 2000)
    (nng-listen socket address)
    socket))

(define (make-dialed-request-socket address)
  (let ((socket (make-req-socket)))
    (socket-set! socket 'nng/recvtimeo 2000)
    (nng-dial socket address)
    socket))

(define (req-rep-test address)
  (let ((rep (make-listening-reply-socket address))
        (req (make-dialed-request-socket address)))
    (nng-send req "message 1")
    (nng-recv rep)
    (nng-send rep "message")
    (begin0
     (nng-recv req)
     (nng-close! rep))))

(define (do-test)
  (test-group "nng"
              (test "tcp req-rep"
                    "message"
                    (req-rep-test address-tcp-1))
              (test "inproc req-rep"
                    "message"
                    (req-rep-test address-inproc-1)))
  (test-exit))

;; talking to self here...
;;
(define (send-n-messages n srvdat)
  (let* ((name (srv-name srvdat)))
    (let loop ((i 0))
      (if (< i n)
	  (begin
	    (nng-send (srv-req srvdat) (conc name "-" i))
	    (print "received: "(nng-recv (srv-rep srvdat)))
	    (loop (+ i 1)))))))

;; this should be run in a thread
(define (run-listener-responder socket myaddr)
  (let loop ((status 'running))
    (let* ((msg (nng-recv socket))
	   (response (process-message msg)))
      (if (not (eq? response 'done))
	  (begin
	    (nng-send socket response)
	    (loop status))))))

(define *channels* (make-hash-table))

(define (call channels msg addr)
  (let* ((csocket (hash-table-ref/default channels addr #f))
	 (socket  (or csocket (make-dialed-request-socket addr))))
    (nng-send socket msg)
    (print "Sent: "msg", received: "(nng-recv socket))
    (if (not (hash-table-exists? channels addr))
	(hash-table-set! channels addr socket))))

;; start    => hello 0
;; hello 0  => hello 1
;; hello 1  => hello 2
;;  ...
;; hello 11 => 'done
;;
(define (process-message mesg)
  (let ((parts (string-split mesg)))
    (match
     parts
     ((msg c)
      (let ((count (string->number c)))
	(if (> count 10)
	    'done
	    (conc msg " " (if count count 0)))))
     ((msg)
      (conc msg " 0"))
     (else
      "hello 0"))))

(define (close-srv srvdat)
  (nng-close! (srv-rep srvdat)))
    
(match
 (command-line-arguments)
 (("do-test")(do-test))
 ((run myaddr)
  ;; start listener
  ;; put myaddr into file by host-pid in .runners
  ;; for 1 minute
  ;;     get all in .runners
  ;;     call each with a message
  ;;
  (let* ((socket (make-listening-reply-socket myaddr))
	 (rfile  (conc ".runners/"(get-host-name)"-"(current-process-id)))
	 (th1    (make-thread (lambda ()
				(run-listener-responder socket myaddr)
				(delete-file* rfile)
				(exit))
		 "responder")))
    (if (not (and (file-exists? ".runners")
		  (directory? ".runners")))
	(create-directory ".runners" #t))
    (with-output-to-file rfile
      (lambda ()
	(print myaddr)))
    (thread-start! th1)
    (let loop ((entries '()))
      (if (null? entries)
	  (loop (glob ".runners/*"))
	  (let* ((entry (car entries))
		 (destaddr (with-input-from-file entry read-line)))
	    (call *channels* (conc "hello-from-"destaddr)  destaddr)
	    (thread-sleep! 0.25)
	    (loop (cdr entries)))))))
 ((cmd)(print "ERROR: command "cmd", not recognised.\n\n"help))
 (else
  (print help)))

	
	directory-utils
	;; http-client
	;; intarweb
	matchable
	md5
	message-digest
	nng ;; nanomsg
	(prefix base64 base64:)
	(prefix sqlite3 sqlite3:)
	regex
	s11n
	;; spiffy
	;; spiffy-directory-listing
	;; spiffy-request-vars
	srfi-1
	srfi-13
	srfi-18
	srfi-69
	stack
	system-information
	tcp6
	;; tcp6
	typed-records
	uri-common
	z3
       
	apimod
	commonmod
	configfmod

;; info about me as a server
;;
(defstruct servdat
  (host #f)
  (port #f)
  (uuid #f)
  (rep  #f)
  (dbfile #f)
  (api-url #f)
  (api-uri #f)
  (api-req #f)
  (status 'starting)
  (trynum 0) ;; count the number of ports we've tried
  ) 

		#t)
	      (start-main-srv)))
	(start-main-srv))))

;; NB// remote is a rmt:remote struct
;;
(define (rmt:general-open-connection remote apath dbname #!key (num-tries 5))
  (let ((mdbname (db:run-id->dbname #f)))
  (let* ((mdbname (db:run-id->dbname #f))
	 (mconn   (rmt:get-conn remote apath mdbname)))
    (cond
     ((not (rmt:get-conn remote apath mdbname)) ;; no channel open to main? 
     ((or (not mconn) ;; no channel open to main?
	  (< (rmt:conn-expires mconn)(+ (current-seconds) 2))) ;; restablish connection if less than 2 seconds on the lease
      (rmt:open-main-connection remote apath)
      (thread-sleep! 2)
      (rmt:general-open-connection remote apath mdbname))
     ((not (rmt:get-conn remote apath dbname))                 ;; no channel open to dbname?     
      (let* ((res (rmt:send-receive-real remote apath mdbname 'get-server `(,apath ,dbname))))
	(case res
	  ((server-started)
	   (if (> num-tries 0)
	       (begin
		 (thread-sleep! 2)
		 (rmt:general-open-connection remote apath dbname num-tries: (- num-tries 1)))
	       (begin
		 (debug:print-error 0 *default-log-port* "Failed to start servers needed or open channel to "apath", "dbname)
		 (exit 1))))
	  (else
	   (if (list? res) ;; server has been registered and the info was returned. pass it on.
	       (begin ;;  ("192.168.0.9" 53817
		      ;;  "5e34239f48e8973b3813221e54701a01" "24310"
		      ;;  "192.168.0.9"
		      ;;  "/home/matt/data/megatest/tests/simplerun"
		 ;;  ".db/1.db")
		 (match
	       res
		  res
		  ((host port servkey pid ipaddr apath dbname)
		   (debug:print-info 0 *default-log-port* "got "res)
		   (hash-table-set! (rmt:remote-conns remote)
				    dbname
				    (make-rmt:conn
				     apath: apath
				     dbname: dbname
				     hostport: (conc host":"port)
				     ipaddr: ipaddr
				     port: port
				     srvkey: servkey
				     lastmsg: (current-seconds)
				     expires: (+ (current-seconds) 60))))
		  (else
		   (debug:print-info 0 *default-log-port* "return data from starting server did not match host port servkey pid ipaddr apath dbname " res)))
		 res)
	       (begin
		 (debug:print-info 0 *default-log-port* "Unexpected result: " res)
		 res)))))))))
		 res))))))
     

     )))

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

;; FOR DEBUGGING SET TO #t
(define *localmode* #t)
(define *dbstruct* (make-dbr:dbstruct))

;; Defaults to current area
;;
(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f))
  (if (not *rmt:remote*)(set! *rmt:remote* (make-rmt:remote)))
  (let* ((apath *toppath*)
	 (conns *rmt:remote*)
	 (dbname (db:run-id->dbname rid)))
    (rmt:general-open-connection conns apath dbname)
    (rmt:send-receive-real conns apath dbname cmd params)))
  (let* ((apath      *toppath*)
	 (conns      *rmt:remote*)
	 (dbname     (db:run-id->dbname rid)))
    (if *localmode*
	(let* ((dbdat    (dbr:dbstruct-get-dbdat *dbstruct* dbname))
	       (indat    `((cmd . ,cmd)(params . ,params))))
	  (api:process-request *dbstruct* indat))
	(begin
	  (rmt:general-open-connection conns apath dbname)
	  (rmt:send-receive-real conns apath dbname cmd params)))))

#;(define (rmt:send-receive-setup conn)
  (if (not (rmt:conn-inport conn))
      (let-values (((i o) (tcp-connect (rmt:conn-ipaddr conn)
				       (rmt:conn-port conn))))
	(rmt:conn-inport-set! conn i)
	(rmt:conn-outport-set! conn o))))
  
;; db is at apath/.db/dbname, rid is an intermediary solution and will be removed
;; sometime in the future
;;
(define (rmt:send-receive-real remote apath dbname cmd params)
  (let* ((conn (rmt:get-conn remote apath dbname)))
    (assert conn "FATAL: rmt:send-receive-real called without the needed channels opened")
    (pp (rmt:conn->alist conn))
    (let* ((key     #f)
    ;; (rmt:send-receive-setup conn)
    (let-values (((i o) (tcp-connect (rmt:conn-ipaddr conn)
				     (rmt:conn-port conn))))
	   (host    (rmt:conn-ipaddr conn))
	   (port    (rmt:conn-port   conn))
      (let* ((key     #f)
	     (payload `((cmd    . ,cmd)
			(key    . ,(rmt:conn-srvkey conn))
			(params . ,params)))
	     (res      (begin
	   (payload `((cmd    . ,cmd)
		      (key    . ,(rmt:conn-srvkey conn))
		      (params . ,params)))
	   (res      (open-send-receive-nn (conc host":"port)
			 (write payload o) ;; (rmt:conn-outport conn))
			 (with-input-from-port
			     i ;; (rmt:conn-inport conn)
			   read))))
					   (sexpr->string payload))))
	(close-input-port i)
	(close-output-port o)
	res))))
;;  (if (string? res)
;; 	  (string->sexpr res)
      (string->sexpr res))))
;; 	  res))))



;; db is at apath/.db/dbname, rid is an intermediary solution and will be removed
;; sometime in the future.
;;
;; Purpose - call the main.db server and request a server be started
;; for the given area path and dbname
;;
;; (define (rmt:send-receive-server-start remote apath dbname)
;;   (let* ((conn (rmt:get-conn remote apath dbname)))
;;     (assert conn "FATAL: Unable to connect to db "apath"/"dbname)
;;     #;(let* ((res      (with-input-from-request
;; 		      (rmt:conn->uri conn "api") 
;; 		      `((params . (,apath ,dbname)))
;; 		      read-string)))
;;       (string->sexpr res))))

(define (rmt:print-db-stats)
  (let ((fmtstr "~40a~7-d~9-d~20,2-f")) ;; "~20,2-f"
    (debug:print 18 *default-log-port* "DB Stats\n========")
    (debug:print 18 *default-log-port* "DB Stats, "(seconds->year-week/day-time (current-seconds))"\n=====================")
    (debug:print 18 *default-log-port* (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg"))
    (for-each (lambda (cmd)
		(let ((cmd-dat (hash-table-ref *db-stats* cmd)))
		  (debug:print 18 *default-log-port* (format #f fmtstr cmd (vector-ref cmd-dat 0) (vector-ref cmd-dat 1) (/ (vector-ref cmd-dat 1)(vector-ref cmd-dat 0))))))
	      (sort (hash-table-keys *db-stats*)
		    (lambda (a b)
		      (> (vector-ref (hash-table-ref *db-stats* a) 0)

;; Use the special run-id == #f scenario here since there is no run yet
(define (rmt:register-run keyvals runname state status user contour)
  ;; first register in main.db (thus the #f)
  (let* ((run-id (rmt:send-receive 'register-run #f (list keyvals runname state status user contour))))
    ;; now register in the run db itself

    ;; NEED A RECORD INSERT INCLUDING SETTING id
    (rmt:send-receive 'register-run run-id (list keyvals runname state status user contour))
    (rmt:send-receive 'insert-run run-id (list run-id keyvals runname state status user contour))
    
    run-id))
  
(define (rmt:get-run-name-from-id run-id)
  (rmt:send-receive 'get-run-name-from-id run-id (list run-id)))

(define (rmt:delete-run run-id)
  (rmt:send-receive 'delete-run run-id (list run-id)))

  ;; (if (rmt:send-receive 'have-incompletes? run-id (list run-id ovr-deadtime))
  (rmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime))
  ) ;; )

(define (rmt:get-main-run-stats run-id)
  (rmt:send-receive 'get-main-run-stats #f (list run-id)))

(define (rmt:get-var varname)
  (rmt:send-receive 'get-var #f (list varname)))
(define (rmt:get-var run-id varname)
  (rmt:send-receive 'get-var run-id (list run-id varname)))

(define (rmt:del-var varname)
  (rmt:send-receive 'del-var #f (list varname)))
(define (rmt:del-var run-id varname)
  (rmt:send-receive 'del-var run-id (list run-id varname)))

(define (rmt:set-var varname value)
  (rmt:send-receive 'set-var #f (list varname value)))
(define (rmt:set-var run-id varname value)
  (rmt:send-receive 'set-var run-id (list run-id varname value)))

(define (rmt:inc-var varname)
  (rmt:send-receive 'inc-var #f (list varname)))
(define (rmt:inc-var run-id varname)
  (rmt:send-receive 'inc-var #f (list run-id varname)))

(define (rmt:dec-var varname)
  (rmt:send-receive 'dec-var #f (list varname)))
(define (rmt:dec-var run-id varname)
  (rmt:send-receive 'dec-var run-id (list run-id varname)))

(define (rmt:add-var varname value)
  (rmt:send-receive 'add-var #f (list varname value)))
(define (rmt:add-var run-id varname value)
  (rmt:send-receive 'add-var run-id (list run-id varname value)))

;;======================================================================
;; M U L T I R U N   Q U E R I E S
;;======================================================================

;; Need to move this to multi-run section and make associated changes
(define (rmt:find-and-mark-incomplete-all-runs #!key (ovr-deadtime #f))

;;  1. Do a remote call to get the test path
;;  2. Continue as above
;; 
;;(define (rmt:get-steps-for-test run-id test-id)
;;  (rmt:send-receive 'get-steps-data run-id (list test-id)))

(define (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile)
  (let* ((valid-values (configf:lookup *configdat* "validvalues" "state"))
  (let* ((state     (items:check-valid-items "state" state-in))
	 (status    (items:check-valid-items "status" status-in)))
	 (state        (items:check-valid-items valid-values "state" state-in))
	 (status       (items:check-valid-items valid-values "status" status-in)))
    (if (or (not state)(not status))
	(debug:print 3 *default-log-port* "WARNING: Invalid " (if status "status" "state")
		     " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config"))
    (rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile))))


(define (rmt:delete-steps-for-test! run-id test-id)

	  (hash-table-set! *pre-reqs-met-cache* key (vector (current-seconds) newres))
	  newres))))

;;======================================================================
;; from metadat lookup MEGATEST_VERSION
;;
(define (common:get-last-run-version) ;; RADT => How does this work in send-receive function??; assume it is the value saved in some DB
  (rmt:get-var "MEGATEST_VERSION"))
  (rmt:get-var #f "MEGATEST_VERSION"))

(define (common:get-last-run-version-number)
  (string->number 
   (substring (common:get-last-run-version) 0 6)))

(define (common:set-last-run-version)
  (rmt:set-var "MEGATEST_VERSION" (common:version-signature)))
  (rmt:set-var #f "MEGATEST_VERSION" (common:version-signature)))

;;======================================================================
;; faux-lock is deprecated. Please use simple-lock below
;;
(define (common:faux-lock keyname #!key (wait-time 8)(allow-lock-steal #t))
  (if (rmt:no-sync-get/default keyname #f) ;; do not be tempted to compare to pid. locking is a one-shot action, if already locked for this pid it doesn't actually count
      (if (> wait-time 0)

(define (common:version-changed?)
  (not (equal? (common:get-last-run-version)
               (common:version-signature))))

(define (common:api-changed?)
  (not (equal? (substring (->string megatest-version) 0 4)
               (substring (conc (common:get-last-run-version)) 0 4))))

(define (rmt:server-shutdown)
  (let ((dbfile   (servdat-dbfile *server-info*)))
    (debug:print-info 0 *default-log-port* "dbfile is "dbfile)
    (if dbfile
	(let* ((am-server  (args:get-arg "-server"))
	       (dbfile     (args:get-arg "-db"))
	       (apath      *toppath*)
	       (dbdat      (db:get-dbdat *dbstruct-db* apath dbfile))
	       (db         (dbr:dbdat-db dbdat))
	       (inmem      (dbr:dbdat-db dbdat))
	       )
	  ;; do a final sync here
	  (debug:print-info 0 *default-log-port* "Doing final sync for "apath" "dbfile" at "(current-seconds))
	  (db:sync-inmem->disk *dbstruct-db* apath dbfile force-sync: #t)
	  ;; let's finalize here
	  (debug:print-info 0 *default-log-port* "Finalizing db and inmem")
	  (sqlite3:finalize! db)
	  (sqlite3:finalize! inmem)
	  (debug:print-info 0 *default-log-port* "Finalizing db and inmem complete")
	  (if am-server
	      (if (string-match ".*/main.db$" dbfile)
		  (let ((pkt-file (conc (get-pkts-dir *toppath*)
					"/" (servdat-uuid *server-info*)
					".pkt")))
		    (debug:print-info 0 *default-log-port* "removing pkt "pkt-file)
		    (delete-file* pkt-file)
		    (debug:print-info 0 *default-log-port* "Releasing lock for "dbfile)
		    (db:with-lock-db (servdat-dbfile *server-info*)
				     (lambda (dbh dbfile)
				       (db:release-lock dbh dbfile))))
		  (let* ((sdat *server-info*) ;; we have a run-id server
			 (host (servdat-host sdat))
			 (port (servdat-port sdat))
			 (uuid (servdat-uuid sdat)))
		    (if (not (string-match ".db/main.db" (args:get-arg "-db")))
			(let* ((res (rmt:deregister-server *rmt:remote* ;; TODO/BUG: why is this requiring *rmt:remote*?
							   *toppath*
							   (servdat-host *server-info*)   ;; iface
							   (servdat-port *server-info*)
							   (servdat-uuid *server-info*)
							   (current-process-id)
							   )))
			  (debug:print-info 0 *default-log-port* "deregistered-server, res="res)))
		    
		    (debug:print-info 0 *default-log-port* "deregistering server "host":"port" with uuid "uuid)
		    )))))))

(define (std-exit-procedure)
  ;;(common:telemetry-log-close)
  (on-exit (lambda () 0))
  ;;(debug:print-info 13 *default-log-port* "std-exit-procedure called; *time-to-exit*="*time-to-exit*)
  (let ((no-hurry  (if (bdat-time-to-exit *bdat*) ;; hurry up
		       #f
		       (begin
			 (bdat-time-to-exit-set! *bdat* #t)
			 #t))))
    (debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.")
    (if (and no-hurry (debug:debug-mode 18))
	(rmt:print-db-stats))
    (let ((th1 (make-thread
    (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds
                              (if *server-info*
		(lambda () ;; thread for cleaning up, give it five seconds
		  (let* ((start-time (current-seconds)))
		    (if (and *server-info*
				  (let ((pkt-file (conc (get-pkts-dir *toppath*)
							"/" (servdat-uuid *server-info*)
							".pkt"))
					(dbfile   (servdat-dbfile *server-info*)))
				    (if dbfile
					(begin

			     *unclean-shutdown*)
					  ;; do a final sync here
					  
					(if (string-match ".*/main.db$" dbfile)
					    (begin
					      (debug:print-info 0 *default-log-port* "removing pkt "pkt-file)
			(begin
			  (debug:print-info 0 *default-log-port* "Unclean server exit, calling server-shtudown")
					      (delete-file* pkt-file)
					      (debug:print-info 0 *default-log-port* "Releasing lock for "dbfile)
			  (rmt:server-shutdown)))
		    (debug:print-info 0 *default-log-port* "Shutdown activities completed in "(- (current-seconds) start-time)" seconds"))
					      (db:with-lock-db (servdat-dbfile *server-info*)
							       (lambda (dbh dbfile)
								 (db:release-lock dbh dbfile))))
					    (let* ((sdat *server-info*)) ;; we have a run-id server
					      (rmt:send-receive-real *rmt:remote* *toppath*
								     (db:run-id->dbname #f)
								     'deregister-server
								     `(,(servdat-uuid sdat)
								       ,(current-process-id)
								       ,(servdat-host sdat)   ;; iface
								       ,(servdat-port sdat)))))))))
			      (if *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated
			      (if (bdat-task-db *bdat*)    ;; TODO: Check that this is correct for task db
				  (let ((db (cdr (bdat-task-db *bdat*))))
				    (if (sqlite3:database? db)
					(begin
					  (sqlite3:interrupt! db)
					  (sqlite3:finalize! db #t)
					  (bdat-task-db-set! *bdat* #f)))))
                              #;(http-client#close-idle-connections!)
                              (if (not (eq? *default-log-port* (current-error-port)))
                                  (close-output-port *default-log-port*))
			      (set! *default-log-port* (current-error-port))) "Cleanup db exit thread"))
		  ;; (if *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated
		  #;(if (bdat-task-db *bdat*)    ;; TODO: Check that this is correct for task db
		  (let ((db (cdr (bdat-task-db *bdat*))))
		  (if (sqlite3:database? db)
		  (begin
		  (debug:print-info 0 *default-log-port* "Closing down task db "db)
		  (sqlite3:interrupt! db)
		  (sqlite3:finalize! db #t)
		  (bdat-task-db-set! *bdat* #f)))))
		  #;(http-client#close-idle-connections!)
		  (if (not (eq? *default-log-port* (current-error-port)))
		      (close-output-port *default-log-port*))
		  (set! *default-log-port* (current-error-port))) "Cleanup db exit thread"))
	  (th2 (make-thread (lambda ()
			      (debug:print 4 *default-log-port* "Attempting clean exit. Please be patient and wait a few seconds...")
			      (debug:print 4 *default-log-port* "Attempting clean exit. Mode="(if no-hurry "no-hurry" "normal")
					   " Please be patient and wait a few seconds...")
			      (if no-hurry
                                  (begin
                                    (thread-sleep! 5)) ;; give the clean up few seconds to do it's stuff
                                  (begin
      				  (thread-sleep! 2)))
				    (thread-sleep! 2)))
      			      (debug:print 4 *default-log-port* " ... done")
      			      )
			    "clean exit")))
      (thread-start! th1)
      (thread-start! th2)
      (thread-join! th1)
      )

      #f
      (conc "http://" (car hostport) ":" (cadr hostport))))

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

;; NOTE: http-transport:launch is the entry point
;;          -> http-transport:run
;;             -> http-transport:try-start-server -> http-transport:try-start-server (until success)

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

#;(define (rmt:launch-server hostn port)
   (if *server-info*
	(begin
	  (servdat-host-set! *server-info* hostn)
	  (servdat-port-set! *server-info* port)
	  (servdat-status-set! *server-info* 'trying-port)
	  (servdat-trynum-set! *server-info* (+ (servdat-trynum *server-info*) 1)))
	(set! *server-info* (make-servdat host: ipaddrstr port: portnum)))
   (let* ((l        (tcp-listen port))
	 (dbstruct #f))
    (let-values (((i o) (tcp-accept l)))
      ;; (write-line "Hello!" o)
      (let loop ((indat (read i)))
	(let* ((res (api:process-request dbstruct indat)))
	  (case res
	    ((quit)
	     (close-input-port i)
	     (close-output-port o))
	    (else
	     (write res o))))))))

(define (rmt:run hostn)
  ;;  ;; Configurations for server
  ;;  (tcp-buffer-size 2048)
  ;;  (max-connections 2048) 
  (debug:print 2 *default-log-port* "Attempting to start the server ...")
  (let* ((db              #f) ;;        (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily
	 (hostname        (get-host-name))
	 (ipaddrstr       (let ((ipstr (if (string=? "-" hostn)
					   ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
					   (server:get-best-guess-address hostname)
					   #f)))
			    (if ipstr ipstr hostn))) ;; hostname))) 
	 (port            (portlogger:open-run-close portlogger:find-port))
	 (link-tree-path  (common:get-linktree))
	 (tmp-area        (common:get-db-tmp-area))
	 ;; (tmp-area        (common:get-db-tmp-area))
	 #;(start-file      (conc tmp-area "/.server-start")))
    (debug:print-info 0 *default-log-port* "portlogger recommended port: " port)
    (if *server-info*
	(begin
	  (servdat-host-set! *server-info* ipaddrstr)
	  (servdat-port-set! *server-info* port)
	  (servdat-status-set! *server-info* 'trying-port)
	  (servdat-trynum-set! *server-info* (+ (servdat-trynum *server-info*) 1)))
	(set! *server-info* (make-servdat host: ipaddrstr port: port)))
    (let* ((l        (rmt:try-start-server ipaddrstr port)))
      (let oloop ()
	(let-values (((i o) (tcp-accept l)))
	  ;; (write-line "Hello!" o)
	  (let loop ((indat (read i)))
	    (if (eof-object? indat)
		(begin
    (let* ((rep (rmt:try-start-server ipaddrstr port)))
      (let loop ((instr (nng-recv rep)))
	(let* ((data   (string->sexpr instr))
	       (res    (case data
			 ((quit) 'quit)
			 (else    (api:process-request *dbstruct-db* data))))
	       (resdat (sexpr->string res)))
	  (if (not (eq? res 'quit))
	      (begin
		  (close-input-port i)
		  (close-output-port o)
		  (oloop))
		(let* ((res (api:process-request *dbstruct-db* indat)))
		  (set! *db-last-access* (current-seconds))
		  (write res o)
		  (loop (read i))))))))
		(set! *db-last-access* (current-seconds))
		(nng-send rep resdat)
		(loop (nng-recv rep)))))))
    (debug:print-info 0 *default-log-port* "After server, should never see this")
    ;; server exit stuff here
    (let* ((portnum (servdat-port *server-info*)))
      (portlogger:open-run-close portlogger:set-port portnum "released")
      (rmt:server-shutdown)
      ;; (bdat-time-to-exit-set! *bdat* #t) ;; tell on-exit to be fast as we've already cleaned up
      (portlogger:open-run-close portlogger:set-port port "released") ;; done in rmt:run
      ;; (debug:print-info 0 *default-log-port* "Max cached queries was    " *max-cache-size*)
      ;; (debug:print-info 0 *default-log-port* "Number of cached writes   " *number-of-writes*)
      ;; (debug:print-info 0 *default-log-port* "Average cached write time "
      ;; 		      (if (eq? *number-of-writes* 0)
      ;; 			  "n/a (no writes)"
      ;; 			  (/ *writes-total-delay*
      ;; 			     *number-of-writes*))
      ;; 		      " ms")
      ;; (debug:print-info 0 *default-log-port* "Number non-cached queries "  *number-non-write-queries*)
      ;; (debug:print-info 0 *default-log-port* "Average non-cached time   "
      ;; 		      (if (eq? *number-non-write-queries* 0)
      ;; 			  "n/a (no queries)"
      ;; 			  (/ *total-non-write-delay* 
      ;; 			     *number-non-write-queries*))
      ;; 		      " ms")
      (debug:print 1 *default-log-port* "INFO: server has been stopped"))))
      
      (db:print-current-query-stats)
      (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting")
      )))

(define (rmt:try-start-server ipaddrstr portnum)
  (if *server-info*
  (if *server-info* ;; update the server info as we might be trying next port
      (begin
	(servdat-host-set! *server-info* ipaddrstr)
	(servdat-port-set! *server-info* portnum)
	(servdat-status-set! *server-info* 'trying-port)
	(servdat-trynum-set! *server-info* (+ (servdat-trynum *server-info*) 1)))
	(servdat-trynum-set! *server-info*
			     (+ (servdat-trynum *server-info*) 1)))
      (set! *server-info* (make-servdat host: ipaddrstr port: portnum)))
  (debug:print-info 0 *default-log-port* "rmt:try-start-server time="
		    (seconds->time-string (current-seconds))
		    " ipaddrsstr=" ipaddrstr
		    " portnum=" portnum)
  (if (is-port-in-use portnum)
      (begin
	(portlogger:open-run-close portlogger:set-failed portnum)
	(debug:print 0 *default-log-port* "WARNING: failed to start on portnum: " portnum ", trying next port")
	;; (thread-sleep! 0.1)
	(rmt:try-start-server ipaddrstr
			      (portlogger:open-run-close
			       portlogger:find-port)))
      (begin
	(if (not *server-info*)
	    (set! *server-info* (make-servdat
				 host: ipaddrstr
				 port: portnum)))
	(servdat-status-set! *server-info* 'starting)
	(servdat-port-set!   *server-info* portnum)
	(if (not (servdat-rep *server-info*))
	    (let ((rep  (make-rep-socket)))
	      (servdat-rep-set!    *server-info* rep)
	      (socket-set! rep 'nng/recvtimeo 2000)))
	(let* ((rep (servdat-rep *server-info*)))
	  (debug:print 0 *default-log-port* "INFO: Trying to start server on " ipaddrstr ":" portnum)
  (handle-exceptions
   exn
   (begin
     (print-error-message exn)
     (if (< portnum 64000)
	 (begin 
	   (debug:print 0 *default-log-port* "WARNING: attempt to start server failed. Trying again ...")
	   (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
	   (debug:print 5 *default-log-port* "exn=" (condition->list exn))
	   (portlogger:open-run-close portlogger:set-failed portnum)
	   (debug:print 0 *default-log-port* "WARNING: failed to start on portnum: " portnum ", trying next port")
	   ;; (thread-sleep! 0.1)
	   (rmt:try-start-server ipaddrstr
				 (portlogger:open-run-close portlogger:find-port)))
	 (begin
	   (print "ERROR: Tried and tried but could not start the server"))))
	  (handle-exceptions
	   exn
	   (begin
	     (print-error-message exn)
	     (if (< portnum 64000)
		 (begin 
		   (debug:print 0 *default-log-port* "WARNING: attempt to start server failed. Trying again ...")
		   (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
		   (debug:print 5 *default-log-port* "exn=" (condition->list exn))
		   (portlogger:open-run-close portlogger:set-failed portnum)
		   (debug:print 0 *default-log-port* "WARNING: failed to start on portnum: " portnum ", trying next port")
		   ;; (thread-sleep! 0.1)
		   (rmt:try-start-server ipaddrstr
					 (portlogger:open-run-close portlogger:find-port)))
		 (begin
		   (print "ERROR: Tried and tried but could not start the server, stopping at port "portnum))))
   ;; any error in following steps will result in a retry
   (if *server-info*
       (servdat-status-set! *server-info* 'starting)
       (set! *server-info* (make-servdat host: ipaddrstr port: portnum)))
   
	   (nng-listen rep (conc "tcp://*:" portnum))
   (debug:print 0 *default-log-port* "INFO: Trying to start server on " ipaddrstr ":" portnum)
   (tcp-listen portnum)))
	   rep)))))

;;======================================================================
;; S E R V E R   U T I L I T I E S 
;;======================================================================

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

	 all-pkt-files)))

(define (server-address srv-pkt)
  (conc (alist-ref 'host srv-pkt) ":"
	(alist-ref 'port srv-pkt)))
	
(define (server-ready? host port key) ;; server-address is host:port
  (let-values (((i o)(handle-exceptions
		      exn
		      (values #f #f)
		      (tcp-connect host port))))
    (if (and i o)
;;  (let-values (((i o)(handle-exceptions
;;		      exn
;;		      (values #f #f)
;;		      (tcp-connect host port))))
;;    (if (and i o)
	(begin
	  (write `((cmd . ping)
		   (key . ,key)
		   (params . ())) o)
	  (let ((res (with-input-from-port i
		       read)))
	    (close-output-port o)
	    (close-input-port i)
	    res))
  (let* ((data (sexpr->string  `((cmd . ping)
				 (key . ,key)
				 (params . ()))))
	 (res  (open-send-receive-nn (conc host ":" port) data)))
    (string->sexpr res)))

;; (let ((res (with-input-from-port i
;; 		       read)))
;; 	    (close-output-port o)
;; 	    (close-input-port i)
;; 	    res))
;; 	    (if (string? res)
;; 		(string->sexpr res)
;; 		res)))
	(begin ;; connection failed
	  (debug:print-info 0 *default-log-port* "Server at "host":"port" is not responding.")
	  #f))))
 	      
;;     (begin ;; connection failed
;; 	  (debug:print-info 0 *default-log-port* "Server at "host":"port" is not responding.")
;; 	  #f))))

;; (define (loop-test host port data) ;; server-address is host:port
;;   ;; ping the server and ask it
;;   ;; if it ready
;;   ;; (let* ((sdat (servdat-init #f host port #f)))
;;   ;;   (http-transport:send-receive sdat "abc" 'ping '())))
;;   (let* ((payload (sexpr->string data))
;; 	 (res     (with-input-from-request

		    (exit))
		  (loop start-time
			(equal? sdat last-sdat)
			sdat))))))))

(define (rmt:register-server remote apath iface port server-key dbname)
  (rmt:open-main-connection remote apath) ;; we need a channel to main.db
  (rmt:send-receive-real remote apath ;; params: host port servkey pid ipaddr dbpath
			 (db:run-id->dbname #f) 'register-server `(,iface
								   ,port
								   ,server-key
								   ,(current-process-id)
								   ,iface
								   ,apath
								   ,dbname)))
  (rmt:send-receive-real remote apath      ;; params: host port servkey pid ipaddr dbpath
			 (db:run-id->dbname #f)
			 'register-server `(,iface
					    ,port
					    ,server-key
					    ,(current-process-id)
					    ,iface
					    ,apath
					    ,dbname)))

(define (rmt:get-count-servers remote apath)
  (rmt:open-main-connection remote apath) ;; we need a channel to main.db
  (rmt:send-receive-real remote apath      ;; params: host port servkey pid ipaddr dbpath
			 (db:run-id->dbname #f)
			 'get-count-servers `(,apath
					      )))

(define (rmt:deregister-server remote apath iface port server-key dbname)
  (rmt:open-main-connection remote apath) ;; we need a channel to main.db
  (rmt:send-receive-real remote apath      ;; params: host port servkey pid ipaddr dbpath
                         (db:run-id->dbname #f)
                         'deregister-server `(,iface
                                              ,port
                                              ,server-key
                                              ,(current-process-id)
                                              ,iface
                                              ,apath
                                              ,dbname)))

(define (http-transport:wait-for-stable-interface #!optional (num-tries-allowed 100))
  ;; wait until *server-info* stops changing
  (let* ((stime (current-seconds)))
    (let loop ((last-host  #f)
	       (last-port  #f)
	       (tries 0))

    ;; main and run db servers have both got wait logic (could/should merge it)
    (if is-main
	(http-transport:wait-for-server pkts-dir dbname server-key)
	(http-transport:wait-for-stable-interface))
    ;; this is our forever loop
    (let* ((iface             (servdat-host *server-info*))
	   (port              (servdat-port *server-info*)))
      (let loop ((count         0)
      (let loop ((count          0)
		 (bad-sync-count 0)
		 (start-time     (current-milliseconds)))
	
	(if (not is-main)
	(if (and (not is-main)
		 (common:low-noise-print 60 "servdat-status"))
	    (debug:print-info 0 *default-log-port* "servdat-status is " (servdat-status *server-info*)))

	;; set up the database handle
	(mutex-lock! *heartbeat-mutex*)
	(if (not *dbstruct-db*) ;; no db opened yet, open the db and register with main if appropriate
	    (let ((watchdog (bdat-watchdog *bdat*)))		 
	      (debug:print 0 *default-log-port* "SERVER: dbprep")

			(begin 
			  (debug:print 0 *default-log-port* "We are not the server for "dbname", exiting.")
			  (exit)))))
	      (debug:print 0 *default-log-port*
			   "SERVER: running, db "dbname" opened, megatest version: "
			   (common:get-full-version))
	      ;; start the watchdog

	      ;; is this really needed?
	      
	      (if watchdog
	      #;(if watchdog
		  (if (not (member (thread-state watchdog)
				   '(ready running blocked
					   sleeping dead)))
		      (begin
			(debug:print-info 0 *default-log-port* "Starting watchdog thread (in state "(thread-state watchdog)")")
			(thread-start! watchdog))
		      (debug:print-info 0 *default-log-port* "Not starting watchdog thread (in state "(thread-state watchdog)")"))
		  (debug:print 0 *default-log-port* "ERROR: *watchdog* not setup, cannot start it."))
	      #;(loop (+ count 1) bad-sync-count start-time)))
	      #;(loop (+ count 1) bad-sync-count start-time)
	      ))

	(debug:print-info 0 *default-log-port* "syncing "*toppath*" "dbname" at "(current-seconds))
	(db:sync-inmem->disk *dbstruct-db* *toppath* dbname force-sync: #t)
	
	(mutex-unlock! *heartbeat-mutex*)
	
	;; when things go wrong we don't want to be doing the various
	;; queries too often so we strive to run this stuff only every
	;; four seconds or so.
	(let* ((sync-time (- (current-milliseconds) start-time))
	       (rem-time  (quotient (- 4000 sync-time) 1000)))

	    (begin
	      (debug:print 0 *default-log-port* "Server stats:")
	      (db:print-current-query-stats)))
	(let* ((hrs-since-start  (/ (- (current-seconds) server-start-time) 3600)))
	  (cond
	   ((and *server-run*
		 (> (+ last-access server-timeout)
		    (current-seconds)))
		    (current-seconds))
		 (if is-main
		     (> (rmt:get-count-servers *rmt:remote* *toppath*) 1)
		     #t))
	    (if (common:low-noise-print 120 "server continuing")
		(debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access)))
	    (loop 0 bad-sync-count (current-milliseconds)))
	   (else
	    (set! *unclean-shutdown* #f)
	    (debug:print-info 0 *default-log-port* "Server timed out. seconds since last db access: " (- (current-seconds) last-access))
	    (http-transport:server-shutdown port))))))))

(define (http-transport:server-shutdown port)
  (begin
    ;;(BB> "http-transport:server-shutdown called")
    (debug:print-info 0 *default-log-port* "Starting to shutdown the server. pid="(current-process-id))
	    (debug:print-info 0 *default-log-port* "Starting to shutdown the server. pid="(current-process-id))
    ;;
    ;; start_shutdown
	    (rmt:server-shutdown)
    ;;

    ;; deregister the server

    
    (bdat-time-to-exit-set! *bdat* #t) ;; tell on-exit to be fast as we've already cleaned up
    (portlogger:open-run-close portlogger:set-port port "released")
	    (portlogger:open-run-close portlogger:set-port port "released")
    (thread-sleep! 1)

	    (exit)
    ;; (debug:print-info 0 *default-log-port* "Max cached queries was    " *max-cache-size*)
    ;; (debug:print-info 0 *default-log-port* "Number of cached writes   " *number-of-writes*)
    ;; (debug:print-info 0 *default-log-port* "Average cached write time "
	    #;(debug:print-info 0 *default-log-port* "Sending 'quit to server, received: "
    ;; 		      (if (eq? *number-of-writes* 0)
    ;; 			  "n/a (no writes)"
    ;; 			  (/ *writes-total-delay*
    ;; 			     *number-of-writes*))
    ;; 		      " ms")
    ;; (debug:print-info 0 *default-log-port* "Number non-cached queries "  *number-non-write-queries*)
    ;; (debug:print-info 0 *default-log-port* "Average non-cached time   "
    ;; 		      (if (eq? *number-non-write-queries* 0)
    ;; 			  "n/a (no queries)"
    ;; 			  (/ *total-non-write-delay* 
    ;; 			     *number-non-write-queries*))
    ;; 		      " ms")
    
			      (open-send-receive-nn (conc iface":"port)      ;; do this here and not in server-shutdown
    (db:print-current-query-stats)
    (common:save-pkt `((action . exit)
                       (T      . server)
						    (sexpr->string 'quit)))
                       (pid    . ,(current-process-id)))
                     *configdat* #t)
    (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting")
    (exit)))
	    )))))))

;; Call this to start the actual server
;;
;; all routes though here end in exit ...
;;
;; This is the point at which servers are started
;;
(define (rmt:server-launch dbname)
  (debug:print-info 0 *default-log-port* "Entered rmt:server-launch")
  (let* ((th2 (make-thread (lambda ()
			     (debug:print-info 0 *default-log-port* "Server run thread started")
			     (rmt:run (if (args:get-arg "-server")
					  (args:get-arg "-server")
					  "-")
				      )) "Server run"))
	 (th3 (make-thread (lambda ()
			     (debug:print-info 0 *default-log-port* "Server monitor thread started")
			     (rmt:keep-running dbname)
			     "Keep running"))))
    (thread-start! th2)
    (thread-sleep! 0.252) ;; give the server time to settle before starting the keep-running monitor.
    (thread-start! th3)
    (set! *didsomething* #t)
    (thread-join! th2)
    (thread-join! th3)
  (exit))

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

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

;;======================================================================
;; Nanomsg transport
;;======================================================================

(define (is-port-in-use port-num)
  (let* ((ret #f))
    (let-values (((inp oup pid)
		  (process "netstat" (list  "-tulpn" ))))
      (let loop ((inl (read-line inp)))
        (if (not (eof-object? inl))
            (begin 
	      (if (string-search (regexp (conc ":" port-num)) inl)
		  (begin
					;(print "Output: "  inl)
		    (set! ret  #t))
		  (loop (read-line inp)))))))
    ret))

;;start a server, returns the connection
;;
(define (start-nn-server portnum )
  (let ((rep (make-rep-socket))) ;; (nn-socket 'rep)))
    (socket-set! rep 'nng/recvtimeo 2000)
    (handle-exceptions
     exn
     (let ((emsg ((condition-property-accessor 'exn 'message) exn)))
       (print "ERROR: Failed to start server \"" emsg "\"")
       (exit 1))
      
     (nng-dial #;nn-bind rep (conc "tcp://*:" portnum)))
    rep))

;; open connection to server, send message, close connection
;;
(define (open-send-close-nn host-port msg #!key (timeout 3) ) ;; default timeout is 3 seconds
  (let ((req  (make-req-socket 'req))
        (uri  (conc "tcp://" host-port))
        (res  #f)
        ;; (contacts (alist-ref 'contact attrib))
        ;; (mode (alist-ref 'mode attrib))
	)
    (socket-set! req 'nng/recvtimeo 2000)
    (handle-exceptions
     exn
     (let ((emsg ((condition-property-accessor 'exn 'message) exn)))
       ;; Send notification       
       (debug:print 0 *default-log-port* "ERROR: Failed to connect / send to " uri " message was \"" emsg "\"" )
       #f)
     (nng-dial req uri)
     ;; (print "Connected to the server " )
     (nng-send req msg)
     ;; (print "Request Sent")  
     (let* ((th1  (make-thread (lambda ()
                                 (let ((resp (nng-recv req)))
                                   (nng-close! req)
                                   (set! res (if (equal? resp "ok")
                                                 #t
                                                 #f))))
                               "recv thread"))
            (th2 (make-thread (lambda ()
                                (thread-sleep! timeout)
                                (thread-terminate! th1))
			      "timer thread")))
       (thread-start! th1)
       (thread-start! th2)
       (thread-join! th1)
       res))))

(define (open-send-receive-nn host-port msg #!key (timeout 3) ) ;; default timeout is 3 seconds
  (let ((req  (make-req-socket))
        (uri  (conc "tcp://" host-port))
        (res  #f)
	;;        (contacts (alist-ref 'contact attrib))
        ;; (mode (alist-ref 'mode attrib))
	) 
    (handle-exceptions
     exn
     (let ((emsg ((condition-property-accessor 'exn 'message) exn)))
       ;; Send notification      
       (debug:print 0 *default-log-port* "ERROR: Failed to connect / send to " uri " message was \"" emsg "\", exn=" exn)
       #f)
     (nng-dial req uri)
     ;; (print "Connected to the server " )
     (nng-send req msg)
     ;; (print "Request Sent")  
     ;; receive code here
     ;;(print (nn-recv req))
     (let* ((th1  (make-thread (lambda ()
                                 (let ((resp (nng-recv req)))
                                   (nng-close! req)
                                   (print resp)
                                   (set! res resp)))
                               "recv thread"))
            (th2 (make-thread (lambda ()
                                (thread-sleep! timeout)
                                (thread-terminate! th1))
                             "timer thread")))
       (thread-start! th1)
       (thread-start! th2)
       (thread-join! th1)
       res))))

;;======================================================================
;; S E R V E R   U T I L I T I E S 
;;======================================================================

;; run ping in separate process, safest way in some cases
;;

                                                      #f ;; sort-by
                                                      #f ;; sort-order
                                                      #f ;; get full data (not 'shortlist)
                                                      0 ;; (runs:gendat-inc-results-last-update *runs:general-data*) ;; last update time
                                                      'dashboard)
                               '()))
           (log-dir         (conc *toppath* "/logs"))
           (log-file        (conc "pre-hook-" (string-translate (getenv "MT_TARGET") "/" "-") "-" (getenv "MT_RUNNAME") ".log"))
           (log-file        (conc "pre-hook-" (string-translate (get-environment-variable "MT_TARGET") "/" "-") "-" (get-environment-variable "MT_RUNNAME") ".log"))
           (full-log-fname  (conc log-dir "/" log-file)))
      (if run-pre-hook
          (if (null? existing-tests)
              (let* ((use-log-dir (if (not (directory-exists? log-dir))
                                      (handle-exceptions
                                       exn
                                       (begin

;;            
(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"))
         (dbfile             (conc  *toppath* "/.db/main.db"))
         (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

    ;; Ensure all tests are registered in the test_meta table
    (runs:update-all-test_meta #f)

    ;; run the run prehook if there are no tests yet run for this run:
    ;;
    (runs:run-pre-hook run-id)
    ;; mark all test launched flag as false in the meta table 
    (rmt:set-var (conc "lunch-complete-" run-id) "no")
    (rmt:set-var run-id (conc "lunch-complete-" run-id) "no")
    (debug:print-info 1 *default-log-port* "Setting end-of-run to no")
    (let* ((config-reruns      (let ((x (configf:lookup *configdat* "setup" "reruns")))
			       (if x (string->number x) #f)))
	  (config-rerun-cnt (if config-reruns
			config-reruns
			1)))
    (if (eq? config-rerun-cnt run-count)
      (rmt:set-var (conc "end-of-run-" run-id) "no")))
      (rmt:set-var run-id (conc "end-of-run-" run-id) "no")))

    (rmt:set-run-state-status run-id "new" "n/a")
    ;; now add non-directly referenced dependencies (i.e. waiton)
    ;;======================================================================
    ;; refactoring this block into tests:get-full-data
    ;;
    ;; What happended, this code is now duplicated in tests!?
    ;;
    ;;======================================================================
    
    (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)))

	  (debug:print-info 0 *default-log-port* "Have leftovers!")
	  (loop (car reg)(cdr reg) '() reruns))
	 (else
          (debug:print-info 4 *default-log-port* "cond branch - "  "rtq-9")
	  (debug:print-info 4 *default-log-port* "Exiting loop with...\n  hed=" hed "\n  tal=" tal "\n  reruns=" reruns))
	 ))) ;; end loop on sorted test names
    ;; this is the point where everything is launched and now you can mark the run in metadata table as all launched 
    (rmt:set-var (conc "lunch-complete-" run-id) "yes")  
    (rmt:set-var run-id (conc "lunch-complete-" run-id) "yes")  
        
    ;; now *if* -run-wait we wait for all tests to be done
    ;; Now wait for any RUNNING tests to complete (if in run-wait mode)
    ;; (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat)))
    (thread-sleep! 10) ;; I think there is a race condition here. Let states/statuses settle
    
    (let wait-loop ((num-running      (rmt:get-count-tests-running-for-run-id run-id))

    (debug:print-info 4 *default-log-port*
		      "\nTESTNAME: " full-test-name 
		      "\n   test-config: " (hash-table->alist test-conf)
		      "\n   itemdat: " itemdat
		      )
    (debug:print 2 *default-log-port* "Attempting to launch test " full-test-name)
    ;; (setenv "MT_TEST_NAME" test-name) ;; 
    ;; (setenv "MT_ITEMPATH"  item-path)
    ;; (setenv "MT_RUNNAME"   runname)
    ;; (set-environment-variable! "MT_TEST_NAME" test-name) ;; 
    ;; (set-environment-variable! "MT_ITEMPATH"  item-path)
    ;; (set-environment-variable! "MT_RUNNAME"   runname)
    (change-directory *toppath*)

    ;; Here is where the test_meta table is best updated
    ;; Yes, another use of a global for caching. Need a better way?
    ;;
    ;; There is now a single call to runs:update-all-test_meta and this 
    ;; per-test call is not needed. Given the delicacy of the move to 

			    (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
			    #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")
		   (let ((old-targethost (get-environment-variable "TARGETHOST")))
		     (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")

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

;; (require-extension (srfi 18) extras tcp s11n)
;; 
;; (use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest
;;      directory-utils posix-extras matchable)
;; 
;; (use spiffy uri-common intarweb http-client spiffy-request-vars)
;; 
;; (declare (unit server))
;; 
;; (declare (uses common))
;; (declare (uses db))
;; (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
;; ;; (declare (uses synchash))
;; (declare (uses http-transport))
;; ;;(declare (uses rpc-transport))
;; (declare (uses launch))
;; ;; (declare (uses daemon))
;; 
;; (include "common_records.scm")
;; (include "db_records.scm")

;;======================================================================
;; P K T S   S T U F F 
;;======================================================================

;; ???

;;======================================================================
;; P K T S   S T U F F 
;;======================================================================

;; ???

;; (for-each (lambda (tdat)
;; 	    (test #f tdat (loop-test (rmt:conn-ipaddr *main*)
;; 				     (rmt:conn-port *main*) tdat)))
;; 	  (list 'a
;; 		'(a "b" 123 1.23 )))
(test #f #t (rmt:send-receive 'ping #f 'hello))

(define *db* (db:setup #f))
(define *db* (db:setup ".db/main.db"))

;; these let me cut and paste from source easily
(define apath *toppath*)
(define dbname ".db/2.db")
(define remote *rmt:remote*)
(define keyvals  '(("SYSTEM" "a")("RELEASE" "b")))

 ;; db:get-dbdat
 ;; rmt:find-main-server
;;  rmt:send-receive-real
;;  rmt:send-receive
 ;; sexpr->string
 ;; server-ready?
 ;; rmt:register-server
 ;;  rmt:deregister-server
 ;; rmt:open-main-connection
 ;; rmt:general-open-connection
 ;; rmt:get-conny
 ;; rmt:get-conn
 ;; common:watchdog
 ;; rmt:find-main-server
 ;; get-all-server-pkts
 ;; get-viable-servers
 ;; get-best-candidate
 ;; api:run-server-process
 ;; api:process-request
 ;; rmt:run
 ;; rmt:try-start-server
 )

(define *db* (db:setup #f))
(define *db* (db:setup ".db/main.db"))

;; these let me cut and paste from source easily
(define apath *toppath*)
(define dbname ".db/2.db")
(define remote *rmt:remote*)
(define keyvals  '(("SYSTEM" "a")("RELEASE" "b")))

(test #f #t (rmt:open-main-connection remote apath))
(test #f #t (rmt:conn? (rmt:get-conn *rmt:remote* *toppath* ".db/main.db")))
(test #f #t (rmt:conn? (rmt:get-conn *rmt:remote* *toppath* ".db/main.db")))
(test #f 'server-started (rmt:send-receive-real *rmt:remote* *toppath* ".db/main.db" 'get-server `(,apath ,dbname)))

(thread-sleep! 2)
(test #f #t (list? (rmt:general-open-connection *rmt:remote* *toppath* ".db/2.db")))

(test #f '("SYSTEM" "RELEASE") (rmt:get-keys))
(test #f 1 (rmt:send-receive 'register-run #f (list keyvals "run1" "new" "n/a" "justme" #f)))
(print "Got here.")
(test #t 1 (rmt:send-receive 'register-run 1 (list keyvals "run2" "new" "n/a" "justme" #f)))

(test #f 1 (rmt:register-run keyvals "run2" "new" "n/a" "justme" #f))

(test #f 1 (rmt:send-receive 'register-run 1 (list keyvals "run1" "new" "n/a" "justme" #f)))
;; (delete-file* "logs/1.log")
;; (define run-id 1)

;; (test "setup for run" #t (begin (launch:setup)
;;  				(string? (getenv "MT_RUN_AREA_HOME"))))
;; 
;; (test #f #t (and (server:kind-run *toppath*) #t))
;; 
;; 
;; (define user    (current-user-name))
;; (define runname "mytestrun")
;; (define keys    (rmt:get-keys))
;; (define runinfo #f)
;; (define keyvals '(("SYSTEM" "abc")("RELEASE" "def")))
;; (define header  (list "SYSTEM" "RELEASE" "id" "runname" "state" "status" "owner" "event_time"))
;; 
;; ;; Setup
;; ;;
;; ;; (test #f #f  (not (client:setup run-id)))
;; ;; (test #f #f  (not (hash-table-ref/default *runremote* run-id #f)))
;; 
;; ;; Login
;; ;;
;; (test #f'(#t "successful login")
;;       (rmt:login run-id))
;; 
;; ;; Keys
;; ;;
;; (test #f '("SYSTEM" "RELEASE")  (rmt:get-keys))
;; 
;; ;; No data in db
;; ;;
;; (test #f '() (rmt:get-all-run-ids))
;; (test #f #f  (rmt:get-run-name-from-id run-id))
;; (test #f 
;;       (vector
;;        header
;;        (vector #f #f #f #f))
;;       (rmt:get-run-info run-id))
;; 
;; ;; Insert data into db
;; ;;
;; (test #f 1 (rmt:register-run keyvals runname "new" "n/a" user))
(test #f 2 (rmt:register-run keyvals "run2" "new" "n/a" "justme" #f))
;; ;; (test #f #f (rmt:get-runs-by-patt keys runname))
;; (test #f #t (rmt:general-call 'register-test run-id run-id "test-one" ""))
;; (define test-one-id #f)
;; (test #f 1  (let ((test-id (rmt:get-test-id run-id "test-one" "")))
;; 	      (set! test-one-id test-id)
;; 	      test-id))
;; (define test-one-rec #f)
;; (test #f "test-one" (let ((test-rec (rmt:get-test-info-by-id run-id test-one-id)))
;; 		      (set! test-one-rec test-rec)
;; 		      (vector-ref test-rec 2)))
;; 
;; ;; With data in db
;; ;;
;; (print "Using runame=" runname)
;; (test #f '(1)    (rmt:get-all-run-ids))
;; (test #f runname (rmt:get-run-name-from-id run-id))
;; (test #f 
;; (test #f 2 (rmt:deregister-server *rmt:remote* *toppath* iface port server-key dbname
;;       runname
;;       (let ((run-info (rmt:get-run-info run-id)))
;; 	(db:get-value-by-header (db:get-rows run-info)
;; 				(db:get-header run-info)
;; 				"runname")))
;; 
;; ;; test killing server
;; ;;
;; (for-each
;;  (lambda (run-id)
;;    (test #f #t (and (tasks:kill-server-run-id run-id) #t))
;;    (test #f #f (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id)))
;;  (list 0 1))
;; 
;; ;; Tests to assess reading/writing while servers are starting/stopping
;; ;; NO LONGER APPLICABLE
;; 
;; ;; Server tests go here
;; (define (server-tests-dont-run-right-now)
;; (for-each
;;  (lambda (run-id)
;;    (test #f #f (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id))
;;    (server:kind-run run-id)
;;    (test "did server start within 20 seconds?"
;; 	 #t
;; 	 (let loop ((remtries 20)
;; 		    (running (tasks:server-running-or-starting? (db:delay-if-busy
;; 								 (tasks:open-db))
;; 								run-id)))
;; 	   (if running 
;; 	       (> running 0)
;; 	       (if (> remtries 0)
;; 		   (begin
;; 		     (thread-sleep! 1)
;; 		     (loop (- remtries 1)
;; 			   (tasks:server-running-or-starting? (db:delay-if-busy
;; 							       (tasks:open-db))
;; 							      run-id)))))))
;;    
;;    (test "did server become available" #t
;; 	 (let loop ((remtries 10)
;; 		    (res      (tasks:get-server (db:delay-if-busy (tasks:open-db)) run-id)))
;; 	   (if res
;; 	       (vector? res)
;; 	       (begin
;; 		 (if (> remtries 0)
;; 		     (begin
;; 		       (thread-sleep! 1.1)
;; 		       (loop (- remtries 1)(tasks:get-server (db:delay-if-busy (tasks:open-db)) run-id)))
;; 		     res)))))
;;    )
;;  (list 0 1)))
;; 
;; (define start-time (current-seconds))
;; (define (reading-writing-while-server-starting-stopping-dont-run-now)
;; (let loop ((test-state 'start))
;;   (let* ((server-dats (tasks:get-server-records (db:delay-if-busy (tasks:open-db)) run-id))
;; 	 (first-dat   (if (not (null? server-dats))
;; 			  (car server-dats)
;; 			  #f)))
;;     (map (lambda (dat)
;; 	   (apply print (intersperse (vector->list dat) ", ")))
;; 	 server-dats)
;;     (test #f test-one-rec (rmt:get-test-info-by-id run-id test-one-id))
;;     (thread-sleep! 1)
;;     (case test-state
;;       ((start)
;;        (print "Trying to start server")
;;        (server:kind-run run-id)
;;        (loop 'server-started))
;;       ((server-started)
;;        (case (if first-dat (vector-ref first-dat 0) 'blah)
;; 	 ((running)
;; 	  (print "Server appears to be running. Now ask it to shutdown")
;; 	  (rmt:kill-server run-id)
;; 	  (loop 'server-shutdown))
;; 	 ((shutting-down)
;; 	  (loop test-state))
;; 	 (else (print "Don't know what to do if get here"))))
;;       ((server-shutdown)
;;        (loop test-state)))))
;; )

;;======================================================================
;; END OF TESTS
;;======================================================================

(test #f 2 (rmt:get-count-servers *rmt:remote* *toppath*))

;; (test #f #f (client:setup run-id))

;; (set! *transport-type* 'http)
;; 
;; (test "setup for run" #t (begin (launch:setup-for-run)
;; 				(string? (getenv "MT_RUN_AREA_HOME"))))
;; 
;; (test "server-register, get-best-server" #t (let ((res #f))
;; 					      (open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live 'http)
;; 					      (set! res (open-run-close tasks:get-best-server tasks:open-db))
;; 					      (number? (vector-ref res 3))))
;; 
;; (test "de-register server" #f (let ((res #f))
;; 				(open-run-close tasks:server-deregister tasks:open-db "bob" port: 1234)
;; 				(vector? (open-run-close tasks:get-best-server tasks:open-db))))
;; 
;; (define server-pid #f)
;; 
;; ;; Not sure how the following should work, replacing it with system of megatest -server
;; ;; (test "launch server" #t (let ((pid (process-fork (lambda ()
;; ;; 						    ;; (daemon:ize)
;; ;; 						    (server:launch 'http)))))
;; ;; 			   (set! server-pid pid)
;; ;; 			   (number? pid)))
;; (system "../../bin/megatest -server - -debugbcom 22 > server.log 2> server.log &")
;; 
;; (let loop ((n 10))
;;   (thread-sleep! 1) ;; need to wait for server to start.
;;   (let ((res (open-run-close tasks:get-best-server tasks:open-db)))
;;     (print "tasks:get-best-server returned " res)
;;     (if (and (not res)
;; 	     (> n 0))
;; 	(loop (- n 1)))))
;; 
;; (test "get-best-server" #t (begin 
;; 			     (client:launch)
;; 			     (let ((dat (open-run-close tasks:get-best-server tasks:open-db)))
;; 			       (vector? dat))))
;; 
;; (define *keys*               (keys:config-get-fields *configdat*))
;; (define *keyvals*            (keys:target->keyval *keys* "a/b/c"))
;; 
;; (test #f #t                       (string? (car *runremote*)))
;; (test #f '(#t "successful login") (rmt:login)) ;;  *runremote* *toppath* *my-client-signature*)))
;; 
;; (test #f #f                       (rmt:get-test-info-by-id 99)) ;; get non-existant test
;; 
;; ;; RUNS
;; (test #f 1                        (rmt:register-run  *keyvals* "firstrun" "new" "n/a" (current-user-name)))
;; (test "get run info"  "firstrun"  (let ((rinfo (rmt:get-run-info 1)))
;; 				    (vector-ref (vector-ref rinfo 1) 3)))
;; (test "get runname from id" "firstrun" (rmt:get-run-name-from-id 1))
(test #f "run2" (rmt:get-run-name-from-id 2))
;; 
;; ;; TESTS
;; (test "get tests (no data)" '()   (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f))
;; (test "register test"       #t    (rmt:general-call 'register-test 1 "test1" ""))
;; (test "get tests (some data)"  1  (length (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f)))
;; (test "get test id"            1  (rmt:get-test-id 1 "test1" ""))
;; (test "sync back"              #t (> (rmt:sync-inmem->db) 0))
;; (test "get test id from main"  1  (db:get-test-id *db* 1 "test1" ""))
;; (test "get keys"               #t (list? (rmt:get-keys)))
;; (test "set comment"            #t (begin (rmt:general-call 'set-test-comment "this is a comment" 1) #t))
;; (test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1)))
;; 					  (db:test-get-comment trec)))
;; 
;; ;; MORE RUNS
;; (test "get runs"  #t (let* ((runs   (rmt:get-runs "%" #f #f '()))
;; 			    (header (vector-ref runs 0))
;; 			    (data   (vector-ref runs 1)))
;; 		       (and (list?   header)
;; 			    (list?   data)
;; 			    (vector? (car data)))))
;; 
;; (test "get local testinfo" "test1" (vector-ref (db:get-testinfo-state-status *db* 1) 2))
;; (test "get testinfo"       "test1" (vector-ref (rmt:get-testinfo-state-status 1) 2))
;; 
;; ;;======================================================================
;; ;; D B
;; ;;======================================================================
;; 
;; (test "pass fail counts" #t (rmt:general-call 'pass-fail-counts 10 9 1))
;; (test "get pass fail counts" 19 (let ((dat (rmt:get-test-info-by-id 1)))
;; 				  (+ (db:test-get-pass_count dat)
;; 				     (db:test-get-fail_count dat))))
;; 
;; (define testregistry (make-hash-table))
;; (for-each
;;  (lambda (tname)
;;    (for-each
;;     (lambda (itempath)
;;       (let ((tkey  (conc tname "/" itempath))
;; 	    (rpass (random 10))
;; 	    (rfail (random 10)))
;; 	(hash-table-set! testregistry tkey (list tname itempath))
;; 	(rmt:general-call 'register-test 1 tname itempath)
;; 	(let* ((tid  (rmt:get-test-id 1 tname itempath))
;; 	       (tdat (rmt:get-test-info-by-id tid)))
;; 	  (rmt:general-call 'pass-fail-counts rpass rfail (db:test-get-id tdat))
;; 	  (let* ((resdat (rmt:get-test-info-by-id tid)))
;; 	    (test "set/get pass fail counts" (list rpass rfail)
;; 		  (list (db:test-get-pass_count resdat)
;; 			(db:test-get-fail_count resdat)))))))
;;     (list "" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j")))
;;  (list "test1" "test2" "test3" "test4" "test5"))
;; 
;; 
;; (test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f)))
;; 

;; (exit)


;; all old stuff below




(delete-file* "logs/1.log")
(define run-id 1)

(test "setup for run" #t (begin (launch:setup-for-run)
 				(string? (getenv "MT_RUN_AREA_HOME"))))

;; Insert data into db
;;
(define user    (current-user-name))
(define runname "mytestrun")
(define keys    (rmt:get-keys))
(define runinfo #f)
(define keyvals '(("SYSTEM" "abc")("RELEASE" "def")))
(define header  (list "SYSTEM" "RELEASE" "id" "runname" "state" "status" "owner" "event_time"))

(test #f 1 (rmt:register-run keyvals runname "new" "n/a" user))
;; (test #f #f (rmt:get-runs-by-patt keys runname))
(test #f #t (rmt:general-call 'register-test run-id run-id "test-one" ""))
(define test-one-id #f)
(test #f 30001  (let ((test-id (rmt:get-test-id run-id "test-one" "")))
	      (set! test-one-id test-id)
	      test-id))
(define test-one-rec #f)
(test #f "test-one" (let ((test-rec (rmt:get-test-info-by-id run-id test-one-id)))
		      (set! test-one-rec test-rec)
		      (vector-ref test-rec 2)))

(use trace)
(import trace)
;; (trace
;;  rmt:send-receive
;;  rmt:open-qry-close-locally
;; )

;; Tests to assess reading/writing while servers are starting/stopping
(define start-time (current-seconds))
(let loop ((test-state 'start))
  (let* ((server-dats (tasks:get-server-records (db:delay-if-busy (tasks:open-db)) run-id))
	 (first-dat   (if (not (null? server-dats))
			  (car server-dats)
			  #f))
	 (server-state (or (and first-dat (string->symbol (vector-ref first-dat 8))) 'no-dat)))
    (if first-dat
	(map (lambda (dat)
	       (apply print (intersperse (vector->list dat) ", ")))
	     server-dats)
	(print "No server"))
    (test #f test-one-rec (rmt:get-test-info-by-id run-id test-one-id))
    (thread-sleep! 1)
    (case test-state
      ((start)
       (print "Trying to start server")
       (server:kind-run run-id)
       (loop 'server-started))
      ((server-started)
       (case server-state 
	 ((running)
	  (print "Server appears to be running. Now ask it to shutdown")
	  (rmt:kill-server run-id)
	  ;; (trace rmt:open-qry-close-locally rmt:send-receive)
	  (loop 'shutdown-started))
	 ((available)
	  (loop test-state))
	 ((shutting-down)
	  (loop test-state))
	 ((no-dat)
	  (loop test-state))
	 (else (print "Don't know what to do if get here"))))
      ((shutdown-started)
       (case server-state 
	 ((no-dat)
	  (print "Server appears to have shutdown, ending this test"))
	 (else
	  (loop test-state)))))))

(exit)	 
       
;; (set! *transport-type* 'http)
;; 
;; (test "setup for run" #t (begin (setup-for-run)
;; 				(string? (getenv "MT_RUN_AREA_HOME"))))
;; 
;; (test "server-register, get-best-server" #t (let ((res #f))
;; 					      (open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live 'http)
;; 					      (set! res (open-run-close tasks:get-best-server tasks:open-db))
;; 					      (number? (vector-ref res 3))))
;; 
;; (test "de-register server" #f (let ((res #f))
;; 				(open-run-close tasks:server-deregister tasks:open-db "bob" port: 1234)
;; 				(vector? (open-run-close tasks:get-best-server tasks:open-db))))
;; 
;; (define server-pid #f)
;; 
;; ;; Not sure how the following should work, replacing it with system of megatest -server
;; ;; (test "launch server" #t (let ((pid (process-fork (lambda ()
;; ;; 						    ;; (daemon:ize)
;; ;; 						    (server:launch 'http)))))
;; ;; 			   (set! server-pid pid)
;; ;; 			   (number? pid)))
;; (system "../../bin/megatest -server - -debug 22 > server.log 2> server.log &")
;; 
;; (let loop ((n 10))
;;   (thread-sleep! 1) ;; need to wait for server to start.
;;   (let ((res (open-run-close tasks:get-best-server tasks:open-db)))
;;     (print "tasks:get-best-server returned " res)
;;     (if (and (not res)
;; 	     (> n 0))
;; 	(loop (- n 1)))))
;; 
;; (test "get-best-server" #t (begin 
;; 			     (client:launch)
;; 			     (let ((dat (open-run-close tasks:get-best-server tasks:open-db)))
;; 			       (vector? dat))))
;; 
;; (define *keys*               (keys:config-get-fields *configdat*))
;; (define *keyvals*            (keys:target->keyval *keys* "a/b/c"))
;; 
;; (test #f #t                       (string? (car *runremote*)))
;; (test #f '(#t "successful login") (rmt:login)) ;;  *runremote* *toppath* *my-client-signature*)))
;; 
;; (test #f #f                       (rmt:get-test-info-by-id 1 99)) ;; get non-existant test
;; 
;; ;; RUNS
;; (test #f 1                        (rmt:register-run  *keyvals* "firstrun" "new" "n/a" (current-user-name)))
;; (test "get run info"  "firstrun"  (let ((rinfo (rmt:get-run-info 1)))
;; 				    (vector-ref (vector-ref rinfo 1) 3)))
;; (test "get runname from id" "firstrun" (rmt:get-run-name-from-id 1))
;; 
;; ;; TESTS
;; (test "get tests (no data)" '()   (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f))
;; (test "register test"       #t    (rmt:general-call 'register-test 1 1 "test1" ""))
;; (test "get tests (some data)"  1  (length (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f)))
;; (test "get test id"            1  (rmt:get-test-id 1 "test1" ""))
;; 
;; (test "sync back"              #t (> (rmt:sync-inmem->db) 0))
;; (test "get test id from main"  1  (db:get-test-id *db* 1 "test1" ""))
;; 
;; (test "get keys"               #t (list? (rmt:get-keys)))
;; (test "set comment"            #t (begin (rmt:general-call 'set-test-comment 1 "this is a comment" 1) #t))
;; (test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1 1)))
;; 					  (db:test-get-comment trec)))
;; 
;; ;; MORE RUNS
;; (test "get runs"  #t (let* ((runs   (rmt:get-runs "%" #f #f '()))
;; 			    (header (vector-ref runs 0))
;; 			    (data   (vector-ref runs 1)))
;; 		       (and (list?   header)
;; 			    (list?   data)
;; 			    (vector? (car data)))))
;; 
;; (test "get local testinfo" "test1" (vector-ref (db:get-testinfo-state-status *db* 1 1) 2))
;; (test "get testinfo"       "test1" (vector-ref (rmt:get-testinfo-state-status 1 1) 2))
;; 
;; ;;======================================================================
;; ;; D B
;; ;;======================================================================
;; 
;; (test "pass fail counts" #t (rmt:general-call 'pass-fail-counts 10 9 1))
;; (test "get pass fail counts" 19 (let ((dat (rmt:get-test-info-by-id 1)))
;; 				  (+ (db:test-get-pass_count dat)
;; 				     (db:test-get-fail_count dat))))
;; 
;; (define testregistry (make-hash-table))
;; (for-each
;;  (lambda (tname)
;;    (for-each
;;     (lambda (itempath)
;;       (let ((tkey  (conc tname "/" itempath))
;; 	    (rpass (random 10))
;; 	    (rfail (random 10)))
;; 	(hash-table-set! testregistry tkey (list tname itempath))
;; 	(rmt:general-call 'register-test 1 tname itempath)
;; 	(let* ((tid  (rmt:get-test-id 1 tname itempath))
;; 	       (tdat (rmt:get-test-info-by-id tid)))
;; 	  (rmt:general-call 'pass-fail-counts rpass rfail (db:test-get-id tdat))
;; 	  (let* ((resdat (rmt:get-test-info-by-id tid)))
;; 	    (test "set/get pass fail counts" (list rpass rfail)
;; 		  (list (db:test-get-pass_count resdat)
;; 			(db:test-get-fail_count resdat)))))))
;;     (list "" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j")))
;;  (list "test1" "test2" "test3" "test4" "test5"))
;; 
;; 
;; (test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f)))
;; 

(include "run_records.scm")
(include "test_records.scm")
(include "js-path.scm")

(define (init-java-script-lib)
  (set! *java-script-lib* (conc  (common:get-install-area) "/share/js/jquery-3.1.0.slim.min.js"))
  )

;; pulled from commonmod
;;

;; return items given config
;;
(define (tests:get-items tconfig)
  (let ((items      (hash-table-ref/default tconfig "items" #f)) ;; items 4
	(itemstable (hash-table-ref/default tconfig "itemstable" #f))) 
    ;; if either items or items table is a proc return it so test running
    ;; process can know to call items:get-items-from-config
    ;; if either is a list and none is a proc go ahead and call get-items
    ;; otherwise return #f - this is not an iterated test
    (cond
     ((procedure? items)      
      (debug:print-info 4 *default-log-port* "items is a procedure, will calc later")
      items)            ;; calc later
     ((procedure? itemstable)
      (debug:print-info 4 *default-log-port* "itemstable is a procedure, will calc later")
      itemstable)       ;; calc later
     ((filter (lambda (x)
		(let ((val (car x)))
		  (if (procedure? val) val #f)))
	      (append (if (list? items) items '())
		      (if (list? itemstable) itemstable '())))
      'have-procedure)
     ((or (list? items)(list? itemstable)) ;; calc now
      (debug:print-info 4 *default-log-port* "items and itemstable are lists, calc now\n"
			"    items: " items " itemstable: " itemstable)
      (items:get-items-from-config tconfig))
     (else #f))))                           ;; not iterated



;; Call this one to do all the work and get a standardized list of tests
;;   gets paths from configs and finds valid tests 
;;   returns hash of testname --> fullpath
;;
(define (tests:get-all)
  (let* ((test-search-path   (tests:get-tests-search-path *configdat*)))

			   dcomment ",," ;; extra comma for status
			   type     )))
	    ;; This was run remote, don't think that makes sense. Perhaps not, but that is the easiest path for the moment.
	    (rmt:csv->test-data run-id test-id
				dat)
	    ;; This was added in check-in a5adfa3f9a. Message was: "...added delay in set-values to allow for delayed write on server start"
	    ;; I'm inserting an arbitrary rmt: call to force/ensure that the server is available to (hopefully) prevent a communication issue.
	    (rmt:get-var "MEGATEST_VERSION") ;; this does NOTHING but ensure the server is reachable. This is almost certainly NOT needed :)
	    ;; (rmt:get-var "MEGATEST_VERSION") ;; this does NOTHING but ensure the server is reachable. This is almost certainly NOT needed :)
            ;; BB - commentiong out arbitrary 10 second wait (thread-sleep! 10) ;; add 10 second delay before quit incase rmt needs time to start a server.
            )))
      
    ;; need to update the top test record if PASS or FAIL and this is a subtest
    ;;;;;; (if (not (equal? item-path ""))
    ;;;;;;     (rmt:set-state-status-and-roll-up-items run-id test-name item-path state status #f) ;;;;;)

;;      (filter (lambda (testname)
;; 	       (tests:match test-patts testname #f))
;; 	     (map (lambda (testp)
;; 		    (last (string-split testp "/")))
;; 		  tests)))))

(define (tests:get-test-path-from-environment)
  (if (and (getenv "MT_LINKTREE")
	   (getenv "MT_TARGET")
	   (getenv "MT_RUNNAME")
	   (getenv "MT_TEST_NAME")
	   (getenv "MT_ITEMPATH"))
      (conc (getenv "MT_LINKTREE")  "/"
	    (getenv "MT_TARGET")    "/"
	    (getenv "MT_RUNNAME")   "/"
	    (getenv "MT_TEST_NAME")
	    (if (and (getenv "MT_ITEMPATH")
                     (not (string=? "" (getenv "MT_ITEMPATH"))))
		(conc "/" (getenv "MT_ITEMPATH"))
  (if (and (get-environment-variable "MT_LINKTREE")
	   (get-environment-variable "MT_TARGET")
	   (get-environment-variable "MT_RUNNAME")
	   (get-environment-variable "MT_TEST_NAME")
	   (get-environment-variable "MT_ITEMPATH"))
      (conc (get-environment-variable "MT_LINKTREE")  "/"
	    (get-environment-variable "MT_TARGET")    "/"
	    (get-environment-variable "MT_RUNNAME")   "/"
	    (get-environment-variable "MT_TEST_NAME")
	    (if (and (get-environment-variable "MT_ITEMPATH")
                     (not (string=? "" (get-environment-variable "MT_ITEMPATH"))))
		(conc "/" (get-environment-variable "MT_ITEMPATH"))
                ""))
      #f))

;; if .testconfig exists in test directory read and return it
;; else if have cached copy in *testconfigs* return it IFF there is a section "have fulldata"
;; else read the testconfig file
;;   if have path to test directory save the config as .testconfig and return it

	  (if (and  dat ;; have a locally cached version
		    (hash-table-ref/default dat "have fulldata" #f)) ;; marked as good data?
	      dat
	      ;; no cached data available
	      (let* ((treg         (or test-registry
				       (tests:get-all)))
		     (test-path    (or (hash-table-ref/default treg test-name #f)
                                       (let* ((local-tcdir (conc (getenv "MT_LINKTREE") "/"
                                                                 (getenv "MT_TARGET") "/"
                                                                 (getenv "MT_RUNNAME") "/"
                                       (let* ((local-tcdir (conc (get-environment-variable "MT_LINKTREE") "/"
                                                                 (get-environment-variable "MT_TARGET") "/"
                                                                 (get-environment-variable "MT_RUNNAME") "/"
                                                                 test-name "/" item-path))
                                              (local-tcfg (conc local-tcdir "/testconfig")))
                                         (if (common:file-exists? local-tcfg)
                                             local-tcdir
                                             #f))
				       (conc *toppath* "/tests/" test-name)))
		     (test-configf (conc test-path "/testconfig"))

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

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

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

(declare (unit tree))
(declare (uses margs))
(declare (uses launch))
(declare (uses mtargs))
(declare (uses mtver))
(declare (uses launchmod))
;; (declare (uses megatest-version))
(declare (uses gutils))
(declare (uses db))
(declare (uses server))
(declare (uses dbmod))
(declare (uses servermod))
;; (declare (uses synchash))
(declare (uses dcommon))

(import mtver
	launchmod
	dbmod
	servermod
	)

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

;;======================================================================
;; T R E E   S T U F F 
;;======================================================================

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

(use simple-exceptions)
(import simple-exceptions)
(define vg:lib-exn (make-exception "wrong record type, expected vg:lib." 'assert))
(define (pmake-vg:lib . params)(let ((v (if (null? params)(make-vector 2)(apply vector 'vg:lib params)))) v))
(define (make-vg:lib #!key 
              (comps #f)
         )
    (vector 'vg:lib comps))

(define-inline (vg:lib-comps       vec)(if (eq? (vector-ref vec 0) 'vg:lib)(vector-ref  vec 1)(raise (vg:lib-exn 'vg:lib-comps 'xpr))))

(define-inline (vg:lib-comps-set!  vec val)(if (eq? (vector-ref vec 0) 'vg:lib)(vector-set! vec 1 val)(raise (vg:lib-exn 'comps))))
;; Generated using make-vector-record -safe vg comp objs name file

(use simple-exceptions)
(import simple-exceptions)
(define vg:comp-exn (make-exception "wrong record type, expected vg:comp." 'assert))
(define (pmake-vg:comp . params)(let ((v (if (null? params)(make-vector 4)(apply vector 'vg:comp params)))) v))
(define (make-vg:comp #!key 
              (objs #f)
              (name #f)
              (file #f)
         )
    (vector 'vg:comp objs name file))

(define-inline (vg:comp-objs       vec)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-ref  vec 1)(raise (vg:comp-exn 'vg:comp-objs 'xpr))))
(define-inline (vg:comp-name       vec)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-ref  vec 2)(raise (vg:comp-exn 'vg:comp-name 'xpr))))
(define-inline (vg:comp-file       vec)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-ref  vec 3)(raise (vg:comp-exn 'vg:comp-file 'xpr))))

(define-inline (vg:comp-objs-set!  vec val)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-set! vec 1 val)(raise (vg:comp-exn 'objs))))
(define-inline (vg:comp-name-set!  vec val)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-set! vec 2 val)(raise (vg:comp-exn 'name))))
(define-inline (vg:comp-file-set!  vec val)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-set! vec 3 val)(raise (vg:comp-exn 'file))))
;; Generated using make-vector-record -safe vg obj type pts fill-color text line-color call-back angle font attrib extents proc

(use simple-exceptions)
(import simple-exceptions)
(define vg:obj-exn (make-exception "wrong record type, expected vg:obj." 'assert))
(define (pmake-vg:obj . params)(let ((v (if (null? params)(make-vector 12)(apply vector 'vg:obj params)))) v))
(define (make-vg:obj #!key 
              (type #f)
              (pts #f)
              (fill-color #f)
              (text #f)

(define-inline (vg:obj-angle-set!       vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 7 val)(raise (vg:obj-exn 'angle))))
(define-inline (vg:obj-font-set!        vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 8 val)(raise (vg:obj-exn 'font))))
(define-inline (vg:obj-attrib-set!      vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 9 val)(raise (vg:obj-exn 'attrib))))
(define-inline (vg:obj-extents-set!     vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 10 val)(raise (vg:obj-exn 'extents))))
(define-inline (vg:obj-proc-set!        vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 11 val)(raise (vg:obj-exn 'proc))))
;; Generated using make-vector-record -safe vg inst libname compname theta xoff yoff scalex scaley mirrx mirry call-back cache

(use simple-exceptions)
(import simple-exceptions)
(define vg:inst-exn (make-exception "wrong record type, expected vg:inst." 'assert))
(define (pmake-vg:inst . params)(let ((v (if (null? params)(make-vector 12)(apply vector 'vg:inst params)))) v))
(define (make-vg:inst #!key 
              (libname #f)
              (compname #f)
              (theta #f)
              (xoff #f)

(define-inline (vg:inst-scaley-set!     vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 7 val)(raise (vg:inst-exn 'scaley))))
(define-inline (vg:inst-mirrx-set!      vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 8 val)(raise (vg:inst-exn 'mirrx))))
(define-inline (vg:inst-mirry-set!      vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 9 val)(raise (vg:inst-exn 'mirry))))
(define-inline (vg:inst-call-back-set!  vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 10 val)(raise (vg:inst-exn 'call-back))))
(define-inline (vg:inst-cache-set!      vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 11 val)(raise (vg:inst-exn 'cache))))
;; Generated using make-vector-record -safe vg drawing libs insts scalex scaley xoff yoff cnv cache

(use simple-exceptions)
(import simple-exceptions)
(define vg:drawing-exn (make-exception "wrong record type, expected vg:drawing." 'assert))
(define (pmake-vg:drawing . params)(let ((v (if (null? params)(make-vector 9)(apply vector 'vg:drawing params)))) v))
(define (make-vg:drawing #!key 
              (libs #f)
              (insts #f)
              (scalex #f)
              (scaley #f)

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

(declare (unit vgmod))

(module vgmod
    *
  
(import scheme chicken data-structures extras ports)
(use canvas-draw iup)
(use typed-records srfi-1 srfi-69)
    (import scheme
	    chicken.base
	    chicken.bitwise
	    chicken.string
	    chicken.random
	    )
    
(import canvas-draw iup)
(import typed-records srfi-1 srfi-69)
(import canvas-draw-iup)

(include "vg_records.scm")

;; ;; structs
;; ;;
;; (defstruct vg:lib     comps)
;; (defstruct vg:comp    objs name file)

    (arithmetic-shift r 16)
    (arithmetic-shift g 8)
    b))

;; Obsolete function
;;
(define (vg:generate-color)
  (vg:rgb->number (random 255)
                  (random 255)
                  (random 255)))
  (vg:rgb->number (pseudo-random-integer 255)
                  (pseudo-random-integer 255)
                  (pseudo-random-integer 255)))

;; Need to return a string of random iup-color for graph
;; Need to return a string of pseudo-random-integer iup-color for graph
;;
(define (vg:generate-color-rgb)
  (conc (number->string (random 255)) " "
        (number->string (random 255)) " "
        (number->string (random 255))))
  (conc (number->string (pseudo-random-integer 255)) " "
        (number->string (pseudo-random-integer 255)) " "
        (number->string (pseudo-random-integer 255))))

(define (vg:iup-color->number iup-color)
  (apply vg:rgb->number (map string->number (string-split iup-color))))

;;======================================================================
;; graphing
;;======================================================================