Megatest

            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

# GUISRCF = 

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

# dashboard-guimonitor.scm 

mofiles/dashboard-context-menu.o : mofiles/dcommon.o
mofiles/dashboard-tests.o : mofiles/dcommon.o
# mofiles/dcommon.o mofiles/tree.o : mofiles/gutils.o

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

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

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

%.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
	csc $(CSCOPTS) -M -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

# BASH_MACHTYPE=$(shell bash -c "echo \$$MACHTYPE")
# ARCHSTR=$(BASH_MACHTYPE)_$(shell lsb_release -sr)
ARCHSTR=$(shell if [[ -e /usr/bin/sw_vers ]]; then /usr/bin/sw_vers -productVersion; else lsb_release -sr; fi)
# ARCHSTR=$(shell bash -c "echo \$$MACHTYPE")

PNGFILES = $(shell cd docs/manual;ls *png)

mtest: readline-fix.scm megatest.scm $(MOFILES) $(MOIMPFILES)
	csc $(CSCOPTS) $(OFILES) $(MOFILES) $(MOIMPFILES) megatest.scm -o mtest
mtest: megatest.scm $(MOFILES) megatest-fossil-hash.scm
	csc $(CSCOPTS) $(MOFILES) megatest.scm -o mtest

#  $(MOIMPFILES) removed

showmtesthash:
	@echo $(MTESTHASH)

dboard : dashboard.scm $(MOFILES) $(GMOFILES) megatest-fossil-hash.scm
	csc -k $(CSCOPTS) $(MOFILES) $(GMOFILES) dashboard.scm -o dboard
dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES) $(MOIMPFILES) megatest-fossil-hash.scm
	csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) $(MOIMPFILES) -o dboard

# $(GMOIMPFILES) $(MOIMPFILES) 

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

# include makefile.inc

TCMTOBJS = \

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

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

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

buildmanual:
	cd docs/manual && make

targets:
	@grep : Makefile | perl -ne '/^([A-Za-z0-9_-]+):/ && print "$$1\n"'

(declare (uses commonmod))
(declare (uses dbmod))
(declare (uses debugprint))
(declare (uses tasksmod))
(declare (uses servermod))

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

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

    ;; TEST DATA
    ((test-data-rollup)             (apply db:test-data-rollup dbstruct params))
    ((csv->test-data)               (apply db:csv->test-data dbstruct params))

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

    ;; TESTMETA
    ((testmeta-add-record)       (apply db:testmeta-add-record dbstruct params))
    ((testmeta-update-field)     (apply db:testmeta-update-field dbstruct params))
    ((get-tests-tags)            (db:get-tests-tags dbstruct))

    ;; TASKS

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

)

(declare (uses dbmod))
(declare (uses rmtmod))
(declare (uses launchmod))
(declare (uses processmod))
(declare (uses servermod))

(module archivemod
	   (
archive:get-archive-disks
archive:get-archive
archive:allocate-new-archive-block
archive:run-bup
archive:megatest-db
archive:restore-db
archive:ls->list
time-string->seconds
seconds->std-time-str
archive:get-timestamp-dir
archive:bup-restore
common:get-youngest-test
archive:bup-get-data
)
	*

	
(import scheme
	(prefix sqlite3 sqlite3:)
	chicken.base
	chicken.condition
	chicken.file
	chicken.file.posix

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

;; Copyright 2006-2011, 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 synch sqlite3 posix srfi-13 srfi-1 utils regex)
(use sqlite3 srfi-1 posix regex srfi-69 srfi-13 posix-extras)
(import (prefix sqlite3 sqlite3:))

(declare (unit filedb))

(include "fdb_records.scm")
;; (include "settings.scm")

(define (filedb:open-db dbpath)
  (let* ((fdb      (make-filedb:fdb))
	 (dbexists (common:file-exists? dbpath))
	 (db (sqlite3:open-database dbpath)))
    (filedb:fdb-set-db!        fdb db)
    (filedb:fdb-set-dbpath!    fdb dbpath)
    (filedb:fdb-set-pathcache! fdb (make-hash-table))
    (filedb:fdb-set-idcache!   fdb (make-hash-table))
    (filedb:fdb-set-partcache! fdb (make-hash-table))
    (sqlite3:set-busy-handler!  db (make-busy-timeout 136000))
    (if (not dbexists)
	(begin
	  (sqlite3:execute db "PRAGMA synchronous = OFF;")
	  (sqlite3:execute db "CREATE TABLE names (id INTEGER PRIMARY KEY,name TEST);") ;; for future use - change path in paths table to path_id
	  (sqlite3:execute db "CREATE INDEX name_index ON names (name);")
	  ;; NB// We store a useful subset of file attributes but do not attempt to store all
	  (sqlite3:execute db "CREATE TABLE paths (id        INTEGER PRIMARY KEY,
                                                   path      TEXT,
                                                   parent_id INTEGER,
                                                   mode      INTEGER DEFAULT -1,
                                                   uid       INTEGER DEFAULT -1,
                                                   gid       INTEGER DEFAULT -1,
                                                   size      INTEGER DEFAULT -1,
                                                   mtime     INTEGER DEFAULT -1);")
	  (sqlite3:execute db "CREATE INDEX path_index ON paths (path,parent_id);")
	  (sqlite3:execute db "CREATE TABLE bases (id INTEGER PRIMARY KEY,base TEXT,                  updated TIMESTAMP);")))
    ;; close the sqlite3 db and open it as needed
    (filedb:finalize-db! fdb)
    (filedb:fdb-set-db! fdb #f)
    fdb))

(define (filedb:reopen-db fdb)
  (let ((db (sqlite3:open-database (filedb:fdb-get-dbpath fdb))))
    (filedb:fdb-set-db! fdb db)
    (sqlite3:set-busy-handler!  db (make-busy-timeout 136000))))
  
(define (filedb:finalize-db! fdb)
  (sqlite3:finalize! (filedb:fdb-get-db fdb)))

(define (filedb:get-current-time-string)
  (string-chomp (time->string (seconds->local-time (current-seconds)))))

(define (filedb:get-base-id db path)
  (let ((stmt   (sqlite3:prepare db "SELECT id FROM bases WHERE base=?;"))
        (id-num #f))
    (sqlite3:for-each-row 
     (lambda (num) (set! id-num num)) stmt path)
    (sqlite3:finalize! stmt)
    id-num))

(define (filedb:get-path-id db path parent)
  (let ((stmt   (sqlite3:prepare db "SELECT id FROM paths WHERE path=? AND parent_id=?;"))
        (id-num #f))
    (sqlite3:for-each-row 
     (lambda (num) (set! id-num num)) stmt path parent)
    (sqlite3:finalize! stmt)
    id-num))

(define (filedb:add-base db path)
  (let ((existing (filedb:get-base-id db path)))
    (if existing #f
        (begin
          (sqlite3:execute db "INSERT INTO bases (base,updated) VALUES (?,?);" path (filedb:get-current-time-string))))))

;; index 	value 	field 	notes
;; 0 	inode number 	st_ino 	
;; 1 	mode 	st_mode 	bitfield combining file permissions and file type
;; 2 	number of hard links 	st_nlink 	
;; 3 	UID of owner 	st_uid 	as with file-owner
;; 4 	GID of owner 	st_gid 	
;; 5 	size 	st_size 	as with file-size
;; 6 	access time 	st_atime 	as with file-access-time
;; 7 	change time 	st_ctime 	as with file-change-time
;; 8 	modification time 	st_mtime 	as with file-modification-time
;; 9 	parent device ID 	st_dev 	ID of device on which this file resides
;; 10 	device ID 	st_rdev 	device ID for special files (i.e. the raw major/minor number)
;; 11 	block size 	st_blksize 	
;; 12 	number of blocks allocated 	st_blocks 	

(define (filedb:add-path-stat db path parent statinfo)
  (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id,mode,uid,gid,size,mtime) VALUES (?,?,?,?,?,?,?);")))
	(sqlite3:execute stmt
			 path
			 parent
			 (vector-ref statinfo 1) ;; mode
			 (vector-ref statinfo 3) ;; uid
			 (vector-ref statinfo 4) ;; gid
			 (vector-ref statinfo 5) ;; size
			 (vector-ref statinfo 8) ;; mtime
			 )
	(sqlite3:finalize! stmt))) ;;  (filedb:get-current-time-string))))
  
(define (filedb:add-path db path parent)
  (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id) VALUES (?,?);")))
    (sqlite3:execute stmt path parent)
    (sqlite3:finalize! stmt)))

(define (filedb:register-path fdb path #!key (save-stat #f))
  (let* ((db        (filedb:fdb-get-db        fdb))
	 (pathcache (filedb:fdb-get-pathcache fdb))
	 (stat      (if save-stat (file-stat path #t)))
	 (id        (hash-table-ref/default pathcache path #f)))
    (if (not db)(filedb:reopen-db fdb))
    (if id id 
        (let ((plist (string-split path "/")))
          (let loop ((head (car plist))
                     (tail (cdr plist))
                     (parent 0))
            (let ((id (filedb:get-path-id db head parent))
                  (done (null? tail)))
              (if id          ;; we'll have a id if the path is already registered
                  (if done 
                      (begin
                        (hash-table-set! pathcache path id)
                        id) ;; return the last path id for a result
                      (loop (car tail)(cdr tail) id))
                  (begin      ;; add the path and then repeat the loop with the same data
		    (if save-stat
			(filedb:add-path-stat db head parent stat) 
			(filedb:add-path db head parent))
                    (loop head tail parent)))))))))

(define (filedb:update-recursively fdb path #!key (save-stat #f))
  (let ((p  (open-input-pipe (string-append "find -L " path)))) ;; (resolve-pathname path)))) ;; (string-append "find " path))))
    (print "processed 0 files...")
    (let loop ((l  (read-line p))
               (lc 0)) ;; line count
      (if (eof-object? l) 
	  (begin
	    (print "          " lc " files")
	    (close-input-port p))
          (begin
            (filedb:register-path fdb l save-stat: save-stat) ;; (get-real-path l)) ;; don't like losing the original path info
            (if (= (modulo lc 100) 0)
                (print "          " lc " files"))
            (loop (read-line p)(+ lc 1)))))))

(define (filedb:update fdb path #!key (save-stat #f))
  ;; first get the realpath and add it to the bases table
  (let ((real-path path) ;; (filedb:get-real-path path))
	(db        (filedb:fdb-get-db    fdb)))
    (filedb:add-base db real-path)
    (filedb:update-recursively fdb path save-stat: save-stat)))

;; not used and broken
;;
(define (filedb:get-real-path path)
  (let* ((p (open-input-pipe (string-append real-path " " (regexp-escape path))))
         (pth (read-line p)))
    (if (eof-object? pth) path
	(begin
	  (close-input-port p)
	  pth))))

(define (filedb:drop-base fdb path)
  (print "Sorry, I don't do anything yet"))

(define (filedb:find-all fdb pattern action)
  (let* ((db     (filedb:fdb-get-db fdb))
	 (stmt   (sqlite3:prepare db "SELECT id FROM paths WHERE path like ?;"))
	 (result '()))
    (sqlite3:for-each-row 
     (lambda (num)
       (action num)
       (set! result (cons num result))) stmt pattern)
    (sqlite3:finalize! stmt)
    result))

(define (filedb:get-path-record fdb id)
  (let* ((db        (filedb:fdb-get-db        fdb))
	 (partcache (filedb:fdb-get-partcache fdb))
	 (dat (hash-table-ref/default partcache id #f)))
    (if dat dat
	(let ((stmt (sqlite3:prepare db "SELECT path,parent_id FROM paths WHERE id=?;"))
	      (result #f))
	  (sqlite3:for-each-row 
	   (lambda (path parent_id)(set! result (list path parent_id))) stmt id)
	  (hash-table-set! partcache id result)
	  (sqlite3:finalize! stmt)
	  result))))

(define (filedb:get-children fdb parent-id)
  (let* ((db        (filedb:fdb-get-db fdb))
	 (res       '()))
    (sqlite3:for-each-row
     (lambda (id path parent-id)
       (set! res (cons (vector id path parent-id) res)))
     db "SELECT id,path,parent_id FROM paths WHERE parent_id=?;"
     parent-id)
    res))

;; retrieve all that have children and those without
;; children that match patt
(define (filedb:get-children-patt fdb parent-id search-patt)
  (let* ((db        (filedb:fdb-get-db fdb))
	 (res       '()))
    ;; first get the children that have no children
    (sqlite3:for-each-row
     (lambda (id path parent-id)
       (set! res (cons (vector id path parent-id) res)))
     db "SELECT id,path,parent_id FROM paths WHERE parent_id=? AND 
            (id IN (SELECT parent_id FROM paths) OR path LIKE ?);"
     parent-id search-patt)
    res))

(define (filedb:get-path fdb id)
  (let* ((db      (filedb:fdb-get-db      fdb))
	 (idcache (filedb:fdb-get-idcache fdb))
	 (path    (hash-table-ref/default idcache id #f)))
    (if (not db)(filedb:reopen-db fdb))
    (if path path
        (let loop ((curr-id id)
                   (path    ""))
          (let ((path-record (filedb:get-path-record fdb curr-id)))
            (if (not path-record) #f ;; this id has no path
                (let* ((parent-id (list-ref path-record 1))
                       (pname     (list-ref path-record 0))
                       (newpath   (string-append  "/" pname path)))
                  (if (= parent-id 0) ;; fields 0=path, 1=parent. root parent=0
                      (begin
                        (hash-table-set! idcache id newpath)
                        newpath)
                      (loop parent-id newpath)))))))))

(define (filedb:search db pattern)
  (let ((action (lambda (id)(print (filedb:get-path db id)))))
    (filedb:find-all db pattern action)))

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

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

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

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

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

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

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

(use typed-records srfi-1)

(declare (unit vg))
(use canvas-draw iup)
(import canvas-draw-iup)

(include "vg_records.scm")

;;======================================================================
;; IDEA
;;
;;      make it possible to instantiate a vg drawing inside a vg drawing
;;
;;======================================================================

;; ;; structs
;; ;;
;; (defstruct vg:lib     comps)
;; (defstruct vg:comp    objs name file)
;; ;; extents caches extents calculated on draw
;; ;; proc is called on draw and takes the obj itself as a parameter
;; ;; attrib is an alist of parameters
;; (defstruct vg:obj     type pts fill-color text line-color call-back angle font attrib extents proc)
;; (defstruct vg:inst    libname compname theta xoff yoff scalex scaley mirrx mirry call-back cache)
;; (defstruct vg:drawing libs insts scalex scaley xoff yoff cnv cache)
;; ;; libs: hash of name->lib, insts: hash of instname->inst

;; inits
;;
(define (vg:comp-new)
  (make-vg:comp objs: '() name: #f file: #f))

(define (vg:lib-new)
  (make-vg:lib comps: (make-hash-table)))

(define (vg:drawing-new)
  (make-vg:drawing scalex: 1 
		   scaley: 1 
		   xoff: 0 
		   yoff: 0 
		   libs: (make-hash-table) 
		   insts: (make-hash-table)
		   cache: '()))

;;======================================================================
;; scaling and offsets
;;======================================================================

(define-inline (vg:scale-offset val s o)
  (+ o (* val s)))
  ;; (* (+ o val) s))

;; apply scale and offset to a list of x y values
;;
(define (vg:scale-offset-xy lstxy sx sy ox oy)
  (if (> (length lstxy) 1) ;; have at least one xy pair
      (let loop ((x   (car lstxy))
		 (y   (cadr lstxy))
		 (tal (cddr lstxy))
		 (res '()))
	(let ((newres (cons (vg:scale-offset y sy oy)
			    (cons (vg:scale-offset x sx ox)
				  res))))
	  (if (> (length tal) 1)
	      (loop (car tal)(cadr tal)(cddr tal) newres)
	      (reverse newres))))
      '()))

;; apply drawing offset and scaling to the points in lstxy
;;
(define (vg:drawing-apply-scale drawing lstxy)
  (vg:scale-offset-xy 
   lstxy
   (vg:drawing-scalex drawing)
   (vg:drawing-scaley drawing)
   (vg:drawing-xoff   drawing)
   (vg:drawing-yoff   drawing)))

;; apply instance offset and scaling to the points in lstxy
;;
(define (vg:inst-apply-scale inst lstxy)
  (vg:scale-offset-xy 
   lstxy
   (vg:inst-scalex inst)
   (vg:inst-scaley inst)
   (vg:inst-xoff   inst)
   (vg:inst-yoff   inst)))

;; apply both drawing and instance scaling to a list of xy points
;; 
(define (vg:drawing-inst-apply-scale-offset drawing inst lstxy)
  (vg:drawing-apply-scale 
   drawing
   (vg:inst-apply-scale inst lstxy)))

;;======================================================================
;; objects
;;======================================================================

;;   (vg:inst-apply-scale 
;;    inst
;;    (vg:drawing-apply-scale drawing lstxy)))

;; make a rectangle obj
;;
(define (vg:make-rect-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)(extents #f))
  (make-vg:obj type: 'r pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color fill-color: fill-color extents: extents))

;; make a rectangle obj
;; 
(define (vg:make-line-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)(extents #f))
  (make-vg:obj type: 'l pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color extents: extents))

;; make a text obj
;;
(define (vg:make-text-obj x1 y1 text #!key (line-color #f)(fill-color #f)
		      (angle #f)(scale-with-zoom #f)(font #f)
		      (font-size #f))
  (make-vg:obj type: 't pts: (list x1 y1) text: text 
	       line-color: line-color fill-color: fill-color
	       angle: angle font: font extents: #f
	       attributes: (vg:make-attrib 'font-size font-size)))

;; proc takes startnum and endnum and yields scalef, per-grad and unitname
;;
(define (vg:make-xaxis-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)(proc #f))
  (make-vg:obj type: 'x pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color fill-color: fill-color extents: #f proc: proc))

;;======================================================================
;; obj modifiers and queries
;;======================================================================

;; get extents, use knowledge of type ...
;;
(define (vg:obj-get-extents drawing obj)
  (let ((type (vg:obj-type obj)))
    (case type
      ((l)(vg:rect-get-extents obj))
      ((r)(vg:rect-get-extents obj))
      ((t)(vg:draw-text drawing obj draw: #f))
      (else #f))))

(define (vg:rect-get-extents obj)
  (vg:obj-pts obj)) ;; extents are just the points for a rectangle

(define (vg:grow-rect borderx bordery x1 y1 x2 y2)
  (list
   (- x1 borderx)
   (- y1 bordery)
   (+ x2 borderx)
   (+ y2 bordery)))

(define (vg:make-attrib . attrib-list)
  #f)

;;======================================================================
;; components
;;======================================================================

;; add obj to comp
;;
(define (vg:add-objs-to-comp comp . objs)
  (vg:comp-objs-set! comp (append (vg:comp-objs comp) objs)))

(define (vg:add-obj-to-comp comp obj)
  (vg:comp-objs-set! comp (cons obj (vg:comp-objs comp))))

;; use the struct. leave this here to remind of this!
;;
;; (define (vg:comp-get-objs comp)
;;   (vg:comp-objs comp))

;; add comp to lib
;;
(define (vg:add-comp-to-lib lib compname comp)
  (hash-table-set! (vg:lib-comps lib) compname comp))

;; instanciate component in drawing
;;
(define (vg:instantiate drawing libname compname instname xoff yoff #!key (theta 0)(scalex 1)(scaley 1)(mirrx #f)(mirry #f))
  (let ((inst (make-vg:inst libname: libname compname: compname xoff: xoff yoff: yoff theta: theta scalex: scalex scaley: scaley mirrx: mirrx mirry: mirry)) )
    (hash-table-set! (vg:drawing-insts drawing) instname inst)))

(define (vg:instance-move drawing instname newx newy)
  (let ((inst (hash-table-ref (vg:drawing-insts drawing) instname)))
    (vg:inst-xoff-set! inst newx)
    (vg:inst-yoff-set! inst newy)))

;; get component from drawing (look in apropriate lib) given libname and compname
(define (vg:get-component drawing libname compname)
  (let* ((lib  (hash-table-ref (vg:drawing-libs drawing) libname))
	 (inst (hash-table-ref (vg:lib-comps lib) compname)))
    inst))

(define (vg:get-extents-for-objs drawing objs)
  (if (or (not objs)
	  (null? objs))
      #f
      (let loop ((hed     (car objs))
		 (tal     (cdr objs))
		 (extents (vg:obj-get-extents drawing (car objs))))
	(let ((newextents
	       (vg:get-extents-for-two-rects
		extents
		(vg:obj-get-extents drawing hed))))
	  (if (null? tal)
	      extents
	      (loop (car tal)(cdr tal) newextents))))))

;;   (let ((extents #f))
;;     (for-each
;;      (lambda (obj)
;;        (set! extents
;; 	 (vg:get-extents-for-two-rects
;; 	  extents
;; 	  (vg:obj-get-extents drawing obj))))
;;      objs)
;;     extents))

;; given rectangles r1 and r2, return the box that bounds both
;;
(define (vg:get-extents-for-two-rects r1 r2)
  (if (not r1)
      r2
      (if (not r2)
	  r1 ;; #f ;; no extents from #f #f
	  (list (min (car r1)(car r2))           ;; llx
		(min (cadr r1)(cadr r2))         ;; lly
		(max (caddr r1)(caddr r2))       ;; ulx
		(max (cadddr r1)(cadddr r2)))))) ;; uly

(define (vg:components-get-extents drawing . comps)
  (if (null? comps)
      #f
      (let loop ((hed  (car comps))
		 (tal  (cdr comps))
		 (extents #f))
	(let* ((objs  (vg:comp-objs hed))
	       (newextents (if extents
			       (vg:get-extents-for-two-rects
				extents
				(vg:get-extents-for-objs drawing objs))
			       (vg:get-extents-for-objs drawing objs))))
	  (if (null? tal)
	      newextents
	      (loop (car tal)(cdr tal) newextents))))))

;;======================================================================
;; libraries
;;======================================================================

;; register lib with drawing

;;
(define (vg:add-lib drawing libname lib)
  (hash-table-set! (vg:drawing-libs drawing) libname lib))

(define (vg:get-lib drawing libname)
  (hash-table-ref/default (vg:drawing-libs drawing) libname #f))

(define (vg:get/create-lib drawing libname)
  (let ((lib (vg:get-lib drawing libname)))
    (if lib
	lib
	(let ((newlib (vg:lib-new)))
	  (vg:add-lib drawing libname newlib)
	  newlib))))

;;======================================================================
;; map objects given offset, scale and mirror, resulting obj is displayed
;;======================================================================

;; dispatch the drawing of obj off to the correct drawing routine
;;
(define (vg:map-obj drawing inst obj)
  (case (vg:obj-type obj)
    ((l)(vg:map-line   drawing inst obj))
    ((r)(vg:map-rect   drawing inst obj))
    ((t)(vg:map-text   drawing inst obj))
    ((x)(vg:map-xaxis  drawing inst obj))
    (else #f)))

;; given a drawing and a inst map a rectangle to it screen coordinates
;;
(define (vg:map-rect drawing inst obj)
  (let ((res (make-vg:obj type:       'r ;; is there a defstruct copy?
			  fill-color: (vg:obj-fill-color obj)
			  text:       (vg:obj-text       obj)
			  line-color: (vg:obj-line-color obj)
			  font:       (vg:obj-font       obj)))
	(pts (vg:obj-pts obj)))
    (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts))
    (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing) ))
    res))

;; given a drawing and a inst map a line to it screen coordinates
;;
(define (vg:map-line drawing inst obj)
  (let ((res (make-vg:obj type:       'l ;; is there a defstruct copy?
			  line-color: (vg:obj-line-color obj)
			  font:       (vg:obj-font       obj)))
	(pts (vg:obj-pts obj)))
    (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts))
    (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing) ))
    res))

;; given a drawing and a inst map a text to it screen coordinates
;;
(define (vg:map-text drawing inst obj)
  (let ((res (make-vg:obj type:       't
			  fill-color: (vg:obj-fill-color obj)
			  text:       (vg:obj-text       obj)
			  line-color: (vg:obj-line-color obj)
			  font:       (vg:obj-font       obj)
			  angle:      (vg:obj-angle      obj)
			  attrib:     (vg:obj-attrib     obj)))
	(pts (vg:obj-pts obj)))
    (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts))
    (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing)))
    res))

;; given a drawing and a inst map a line to it screen coordinates
;;
(define (vg:map-xaxis drawing inst obj)
  (let ((res (make-vg:obj type:      'x ;; is there a defstruct copy?
			  line-color: (vg:obj-line-color obj)
			  font:       (vg:obj-font       obj)))
	(pts (vg:obj-pts obj)))
    (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts))
    (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing) ))
    res))

;;======================================================================
;; instances
;;======================================================================

(define (vg:instances-get-extents drawing . instance-names)
  (let ((xtnt-lst (vg:draw drawing #f)))
    (if (null? xtnt-lst)
	#f
	(let loop ((extents (car xtnt-lst))
		   (tal     (cdr xtnt-lst))
		   (llx     #f)
		   (lly     #f)
		   (ulx     #f)
		   (uly     #f))
	  (let ((nllx      (if llx (min llx (list-ref extents 0))(list-ref extents 0)))
		(nlly      (if lly (min lly (list-ref extents 1))(list-ref extents 1)))
		(nulx      (if ulx (max ulx (list-ref extents 2))(list-ref extents 2)))
		(nuly      (if uly (max uly (list-ref extents 3))(list-ref extents 3))))
	    (if (null? tal)
		(list llx lly ulx uly)
		(loop (car tal)(cdr tal) nllx nlly nulx nuly)))))))

(define (vg:lib-get-component lib instname)
  (hash-table-ref/default  (vg:lib-comps lib) instname #f))

;;======================================================================
;; color
;;======================================================================

(define (vg:rgb->number r g b #!key (a 0))
  (bitwise-ior
    (arithmetic-shift a 24)
    (arithmetic-shift r 16)
    (arithmetic-shift g 8)
    b))

;; Obsolete function
;;
(define (vg:generate-color)
  (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
;;
(define (vg:generate-color-rgb)
  (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
;;======================================================================

(define (vg:make-xaxis drawing component x1 y1 x2 y2 startnum endnum scaleproc)
  (let ((obj (vg:make-xaxis-obj x1 y1 x2 y2)))
    #f))

;;======================================================================
;; Unravel and draw the objects
;;======================================================================

;; with get-extents = #t return the extents
;; with draw = #f don't actually draw the object
;;
(define (vg:draw-obj drawing obj #!key (draw #t))
  ;; (print "obj type: " (vg:obj-type obj))
  (case (vg:obj-type obj)
    ((l)(vg:draw-line drawing obj draw: draw))
    ((r)(vg:draw-rect drawing obj draw: draw))
    ((t)(vg:draw-text drawing obj draw: draw))))

;; given a rect obj draw it on the canvas applying first the drawing
;; scale and offset
;;
(define (vg:draw-rect drawing obj #!key (draw #t))
  (let* ((cnv (vg:drawing-cnv drawing))
	 (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj)))
	 (fill-color (vg:obj-fill-color obj))
	 (line-color (vg:obj-line-color obj))
	 (text       (vg:obj-text obj))
	 (font       (vg:obj-font obj))
	 (llx        (car pts))
	 (lly        (cadr pts))
	 (ulx        (caddr pts))
	 (uly        (cadddr pts))
	 (w          (- ulx llx))
	 (h          (- uly lly))
	 (text-xmax  #f)
	 (text-ymax  #f))
    (if draw 
	(let ((prev-background-color (canvas-background cnv))
	      (prev-foreground-color (canvas-foreground cnv)))
	  (if fill-color
	      (begin
		(canvas-foreground-set! cnv fill-color)
		(canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h)
	  (if line-color
	      (canvas-foreground-set! cnv line-color)
	      (if fill-color
		  (canvas-foreground-set! cnv prev-foreground-color)))
	  (canvas-rectangle! cnv llx ulx lly uly)
	  (canvas-foreground-set! cnv prev-foreground-color)
	  (if text 
	      (let* ((prev-font    (canvas-font cnv))
		     (font-changed (and font (not (equal? font prev-font)))))
		(if font-changed (canvas-font-set! cnv font))
		(canvas-text! cnv (+ 2 llx)(+ 2 lly) text)
		(if (eq? draw 'get-extents)
		    (let-values (((xmax ymax)(canvas-text-size cnv text)))
				(set! text-xmax xmax)(set! text-ymax ymax)))
		(if font-changed (canvas-font-set! cnv prev-font))))))
    ;; (print "text-xmax: " text-xmax " text-ymax: " text-ymax)
    (if (vg:obj-extents obj)
	(vg:obj-extents obj)
	(if (not text)
	    pts ;; no text
	    (if (and text-xmax text-ymax) ;; have text
		(let ((xt (list llx lly
				(max ulx (+ llx text-xmax))
				(max uly (+ lly text-ymax)))))
		  (vg:obj-extents-set! obj xt)
		  xt)
		(if cnv
		    (if (eq? draw 'get-extents)
			(let-values (((xmax ymax)(canvas-text-size cnv text)))
				    (let ((xt (list llx lly
						    (max ulx (+ llx xmax))
						    (max uly (+ lly ymax)))))
				      (vg:obj-extents-set! obj xt)
				      xt))
			pts)
		    pts)))))) ;; return extents 

;; given a rect obj draw it on the canvas applying first the drawing
;; scale and offset
;;
(define (vg:draw-line drawing obj #!key (draw #t))
  (let* ((cnv (vg:drawing-cnv drawing))
	 (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj)))
	 ;; (fill-color (vg:obj-fill-color obj))
	 (line-color (vg:obj-line-color obj))
	 (text       (vg:obj-text obj))
	 (font       (vg:obj-font obj))
	 (llx        (car pts))
	 (lly        (cadr pts))
	 (ulx        (caddr pts))
	 (uly        (cadddr pts))
	 (w          (- ulx llx))
	 (h          (- uly lly))
	 (text-xmax  #f)
	 (text-ymax  #f))
    (if draw 
	(let ((prev-background-color (canvas-background cnv))
	      (prev-foreground-color (canvas-foreground cnv)))
	;; (if fill-color
	;;     (begin
	;; 	(canvas-foreground-set! cnv fill-color)
	;; 	(canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h)
	  (if line-color
	      (canvas-foreground-set! cnv line-color))
	     ;; (if fill-color
	     ;;  (canvas-foreground-set! cnv prev-foreground-color)))
	  (canvas-line! cnv llx lly ulx uly)
	  (canvas-foreground-set! cnv prev-foreground-color)
	  (if text 
	      (let* ((prev-font    (canvas-font cnv))
		     (font-changed (and font (not (equal? font prev-font)))))
		(if font-changed (canvas-font-set! cnv font))
		(canvas-text! cnv (+ 2 llx)(+ 2 lly) text)
		(let-values (((xmax ymax)(canvas-text-size cnv text)))
		  (set! text-xmax xmax)(set! text-ymax ymax))
		(if font-changed (canvas-font-set! cnv prev-font))))))
    ;; (print "text-xmax: " text-xmax " text-ymax: " text-ymax)
    (if (vg:obj-extents obj)
	(vg:obj-extents obj)
	(if (not text)
	    pts
	    (if (and text-xmax text-ymax)
		(let ((xt (list llx lly
				(max ulx (+ llx text-xmax))
				(max uly (+ lly text-ymax)))))
		  (vg:obj-extents-set! obj xt)
		  xt)
		(if cnv
		    (let-values (((xmax ymax)(canvas-text-size cnv text)))
		      (let ((xt (list llx lly
				      (max ulx (+ llx xmax))
				      (max uly (+ lly ymax)))))
			(vg:obj-extents-set! obj xt)
			xt))
		    pts)))))) ;; return extents 

;; given a rect obj draw it on the canvas applying first the drawing
;; scale and offset
;;
(define (vg:draw-xaxis drawing obj #!key (draw #t))
  (let* ((cnv (vg:drawing-cnv drawing))
	 (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj)))
	 ;; (fill-color (vg:obj-fill-color obj))
	 (line-color (vg:obj-line-color obj))
	 (text       (vg:obj-text obj))
	 (font       (vg:obj-font obj))
	 (llx        (car pts))
	 (lly        (cadr pts))
	 (ulx        (caddr pts))
	 (uly        (cadddr pts))
	 (w          (- ulx llx))
	 (h          (- uly lly))
	 (text-xmax  #f)
	 (text-ymax  #f))
    (if draw 
	(let ((prev-background-color (canvas-background cnv))
	      (prev-foreground-color (canvas-foreground cnv)))
	;; (if fill-color
	;;     (begin
	;; 	(canvas-foreground-set! cnv fill-color)
	;; 	(canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h)
	  (if line-color
	      (canvas-foreground-set! cnv line-color)
	      #;(if fill-color
		  (canvas-foreground-set! cnv prev-foreground-color)))
	  (canvas-line! cnv llx ulx lly uly)
	  (canvas-foreground-set! cnv prev-foreground-color)
	  (if text 
	      (let* ((prev-font    (canvas-font cnv))
		     (font-changed (and font (not (equal? font prev-font)))))
		(if font-changed (canvas-font-set! cnv font))
		(canvas-text! cnv (+ 2 llx)(+ 2 lly) text)
		(let-values (((xmax ymax)(canvas-text-size cnv text)))
		  (set! text-xmax xmax)(set! text-ymax ymax))
		(if font-changed (canvas-font-set! cnv prev-font))))))
    ;; (print "text-xmax: " text-xmax " text-ymax: " text-ymax)
    (if (vg:obj-extents obj)
	(vg:obj-extents obj)
	(if (not text)
	    pts
	    (if (and text-xmax text-ymax)
		(let ((xt (list llx lly
				(max ulx (+ llx text-xmax))
				(max uly (+ lly text-ymax)))))
		  (vg:obj-extents-set! obj xt)
		  xt)
		(if cnv
		    (let-values (((xmax ymax)(canvas-text-size cnv text)))
		      (let ((xt (list llx lly
				      (max ulx (+ llx xmax))
				      (max uly (+ lly ymax)))))
			(vg:obj-extents-set! obj xt)
			xt))
		    pts)))))) ;; return extents 

;; given a rect obj draw it on the canvas applying first the drawing
;; scale and offset
;;
(define (vg:draw-text drawing obj #!key (draw #t))
  (let* ((cnv        (vg:drawing-cnv drawing))
	 (pts        (vg:drawing-apply-scale drawing (vg:obj-pts obj)))
	 (text       (vg:obj-text obj))
	 (font       (vg:obj-font obj))
	 (fill-color (vg:obj-fill-color obj))
	 (line-color (vg:obj-line-color obj))
	 (llx        (car pts)) 
	 (lly        (cadr pts)))
    (if draw 
	(let* ((prev-background-color (canvas-background cnv))
	       (prev-foreground-color (canvas-foreground cnv))
	       (prev-font             (canvas-font       cnv))
	       (font-changed    (and font (not (equal? font prev-font)))))
	  (if line-color
	      (canvas-foreground-set! cnv line-color)
	      (if fill-color
		  (canvas-foreground-set! cnv prev-foreground-color)))
	  (if font-changed (canvas-font-set! cnv font))
	  (canvas-text! cnv llx lly text)
	  ;; NOTE: we do not set the font back!!
	  (canvas-foreground-set! cnv prev-foreground-color)))
    (if cnv
	(if (eq? draw 'get-extents)
	    (let-values (((xmax ymax)(canvas-text-size cnv text)))
			(append pts (list (+ llx xmax)(+ lly ymax)))) ;; will be wrong if text is rotated?
	    (append pts pts))
	(append pts pts))))

(define (vg:draw-inst drawing inst #!key (draw-mode #t)(prev-extents '()))
  (let* ((libname  (vg:inst-libname inst))
	 (compname (vg:inst-compname inst))
	 (comp     (vg:get-component drawing libname compname))
	 (objs     (vg:comp-objs comp)))
    ;; (print "comp: " comp)
    (if (null? objs)
	prev-extents
	(let loop ((obj (car objs))
		   (tal (cdr objs))
		   (res prev-extents))
	  (let* ((obj-xfrmd (vg:map-obj drawing inst obj))
		 (newres    (cons (vg:draw-obj drawing obj-xfrmd draw: draw-mode) res)))
	    (if (null? tal)
		newres
		(loop (car tal)(cdr tal) newres)))))))

(define (vg:draw drawing draw-mode . instnames)
  (let* ((insts (vg:drawing-insts drawing))
	 (all-inst-names (hash-table-keys insts))
	 (master-list    (if (null? instnames)
			     all-inst-names
			     instnames)))
    (if (null? master-list)
	'()
	(let loop ((instname (car master-list))
		   (tal      (cdr master-list))
		   (res      '()))
	  (let* ((inst     (hash-table-ref/default insts instname #f))
		 (newres   (if inst
			       (vg:draw-inst drawing inst draw-mode: draw-mode prev-extents: res)
			       res)))
	    (if (null? tal)
		newres
		(loop (car tal)(cdr tal) newres)))))))

#!/bin/bash
export PATH=/home/matt/data/buildall/ck5.2/bin:$PATH
if [[ -z /home/matt/data/buildall/ck5.2/lib:/home/matt/data/buildall/ck5.2/lib64 ]];then
   export LD_LIBRARY_PATH=/home/matt/data/buildall/ck5.2/lib:/home/matt/data/buildall/ck5.2/lib64:$LD_LIBRARY_PATH
else
   export LD_LIBRARY_PATH=/home/matt/data/buildall/ck5.2/lib:/home/matt/data/buildall/ck5.2/lib64
fi
export CHICKEN_DOC_PAGER=cat
exec "$@"

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 -feature disable-iup-matrixex"
echo "else:"
echo "CSC_OPTIONS=\"-I$PREFIX/include -I$PREFIX/include/im -I$PREFIX/include/cd -I$PREFIX/include/iup -L$PREFIX/lib -C -std=gnu99\" chicken-install iup"
echo "Then repeat for canvas-draw"

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

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

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

;; (use trace)

(include "altdb.scm")
;; (include "altdb.scm")

;; Some of these routines use:
;;
;;     http://www.cs.toronto.edu/~gfb/scheme/simple-macros.html
;;
;; Syntax for defining macros in a simple style similar to function definiton,
;;  when there is a single pattern for the argument list and there are no keywords.

(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
	   (
make-db:test
db:test-get-id
db:test-get-run_id
db:test-get-testname
db:test-get-state
db:test-get-status
db:test-get-event_time
db:test-get-host
db:test-get-cpuload
db:test-get-diskfree
db:test-get-uname
db:test-get-rundir
db:test-get-item-path
db:test-get-run_duration
db:test-get-final_logf
db:test-get-comment
db:test-get-process_id
db:test-get-archived
db:test-get-last_update
db:test-get-fullname
db:test-make-full-name
db:test-get-first_err
db:test-get-first_warn
db:test-set-cpuload!
db:test-set-diskfree!
db:test-set-testname!
db:test-set-state!
db:test-set-status!
db:test-set-run_duration!
db:test-set-final_logf!
db:test-get-is-toplevel
make-db:mintest
db:mintest-get-id
db:mintest-get-run_id
db:mintest-get-testname
db:mintest-get-state
db:mintest-get-status
db:mintest-get-event_time
db:mintest-get-item_path
make-db:testmeta
db:testmeta-get-id
db:testmeta-get-testname
db:testmeta-get-author
db:testmeta-get-owner
db:testmeta-get-description
db:testmeta-get-reviewed
db:testmeta-get-iterated
db:testmeta-get-avg_runtime
db:testmeta-get-avg_disk
db:testmeta-get-tags
db:testmeta-set-id!
db:testmeta-set-testname!
db:testmeta-set-author!
db:testmeta-set-owner!
db:testmeta-set-description!
db:testmeta-set-reviewed!
db:testmeta-set-iterated!
db:testmeta-set-avg_runtime!
db:testmeta-set-avg_disk!
make-db:test-data
db:test-data-get-id
db:test-data-get-test_id
db:test-data-get-category
db:test-data-get-variable
db:test-data-get-value
db:test-data-get-expected
db:test-data-get-tol
db:test-data-get-units
db:test-data-get-comment
db:test-data-get-status
db:test-data-get-type
db:test-data-get-last_update
db:test-data-set-id!
db:test-data-set-test_id!
db:test-data-set-category!
db:test-data-set-variable!
db:test-data-set-value!
db:test-data-set-expected!
db:test-data-set-tol!
db:test-data-set-units!
db:test-data-set-comment!
db:test-data-set-status!
db:test-data-set-type!
make-db:step
tdb:step-get-id
tdb:step-get-test_id
tdb:step-get-stepname
tdb:step-get-state
tdb:step-get-status
tdb:step-get-event_time
tdb:step-get-logfile
tdb:step-get-comment
tdb:step-get-last_update
tdb:step-set-id!
tdb:step-set-test_id!
tdb:step-set-stepname!
tdb:step-set-state!
tdb:step-set-status!
tdb:step-set-event_time!
tdb:step-set-logfile!
tdb:step-set-comment!
make-db:steps-table
tdb:steps-table-get-stepname
tdb:steps-table-get-start
tdb:steps-table-get-end
tdb:steps-table-get-status
tdb:steps-table-get-runtime
tdb:steps-table-get-log-file
tdb:step-stable-set-stepname!
tdb:step-stable-set-start!
tdb:step-stable-set-end!
tdb:step-stable-set-status!
tdb:step-stable-set-runtime!
make-cdb:packet
cdb:packet-get-client-sig
cdb:packet-get-qtype
cdb:packet-get-immediate
cdb:packet-get-query-sig
cdb:packet-get-params
cdb:packet-get-qtime
cdb:packet-set-client-sig!
cdb:packet-set-qtype!
cdb:packet-set-immediate!
cdb:packet-set-query-sig!
cdb:packet-set-params!
cdb:packet-set-qtime!
runs:runrec-make-record
runs:runrec-get-target
runs:runrec-get-runname
runs:runrec-testpatt
runs:runrec-keys
runs:runrec-keyvals
runs:runrec-environment
runs:runrec-mconfig
runs:runrec-runconfig
runs:runrec-serverdat
runs:runrec-transport
runs:runrec-db
runs:runrec-top-path
runs:runrec-run_id
test:get-id
test:get-run_id
test:get-test-name
test:get-state
test:get-status
test:get-item-path
test:test-get-fullname
make-and-init-bigdata
call-with-environment-variables
common:simple-file-lock
common:simple-file-lock-and-wait
common:simple-file-release-lock
common:fail-safe
get-file-descriptor-count
common:get-this-exe-fullpath
common:get-sync-lock-filepath
common:find-local-megatest
common:logpro-exit-code->status-sym
common:worse-status-sym
common:steps-can-proceed-given-status-sym
status-sym->string
common:logpro-exit-code->test-status
common:clear-caches
common:get-full-version
common:version-signature
common:snapshot-file
common:rotate-logs
make-sparse-array
sparse-array?
sparse-array-ref
sparse-array-set!
common:db-block-further-queries
common:db-access-allowed?
common:to-alist
common:alist-ref/default
common:low-noise-print
common:get-megatest-exe
common:read-encoded-string
common:special-sort
get-with-default
assoc/default
common:get-area-name
common:get-toppath
common:get-db-tmp-area
common:get-signature
common:get-area-path-signature
common:calc-area-key
common:get-area-key
common:human-time
std-signal-handler
special-signal-handler
any->number
any->number-if-possible
patt-list-match
common:get-disks
common:which
common:get-install-area
common:get-create-writeable-dir
common:get-youngest
common:bash-glob
common:list-or-null
common:get-runconfig-targets
common:args-get-state
common:args-get-status
common:args-get-testpatt
common:false-on-exception
common:file-exists?
common:directory-exists?
common:directory-writable?
common:get-linktree
common:args-get-runname
common:args-get-target
common:get-full-test-name
common:use-cache?
common:force-server?
common:list-is-sublist
common:max
common:min-max
common:sum
common:list->htree
common:htree->html
common:htree->atree
common:sparse-list-generate-index
common:lazy-convert
common:val->alist
common:lazy-modification-time
common:lazy-sqlite-db-modification-time
common:get-intercept
common:get-delay
common:print-delay-table
get-cpu-load
common:get-cached-info
common:write-cached-info
common:raw-get-remote-host-load
common:get-cpu-load
common:get-normalized-cpu-load
common:get-normalized-cpu-load-raw
common:unix-ping
launch:is-test-alive
common:get-num-cpus
common:wait-for-normalized-load
common:wait-for-cpuload
tasks:kill-server
server:get-logs-list
server:get-list
server:get-num-alive
server:get-best
server:get-first-best
server:get-rand-best
server:record->id
server:get-num-servers
server:logf-get-start-info
get-uname
realpath
common:real-path
common:get-disk-space-used
get-df
get-free-inodes
get-unix-df
get-unix-inodes
common:check-space-in-dir
common:check-db-dir-space
common:check-db-dir-and-exit-if-insufficient
common:get-disk-with-most-free-space
common:spec-string->list-of-specs
common:file-find-rule
common:dir-clean-up
bb-check-path
save-environment-as-files
common:get-param-mapping
alist->env-vars
get-the-original-environment
common:with-orig-env
common:without-vars
common:run-a-command
common:hms-string->seconds
seconds->hr-min-sec
seconds->time-string
seconds->work-week/day-time
seconds->work-week/day
seconds->year-work-week/day
seconds->year-work-week/day-time
seconds->year-week/day-time
seconds->quarter
common:date-time->seconds
common:find-start-mark-and-mark-delta
common:expand-cron-slash
common:cron-expand
common:cron-event
common:extended-cron
common:name->iup-color
common:iup-color->rgb-hex
common:in-running-test?
common:get-color-from-status
common:load-views-config
hh:make-hh
hh:get
hh:set!
common:get-pkts-dirs
common:save-pkt
common:minimal-save-pkt
common:get-pkt-alists
common:get-pkt-times
common:send-thunk-to-background-thread
common:join-backgrounded-threads
dtests:get-pre-command
dtests:get-post-command
db:patt->like
tests:cache-regexp
tests:glob-like-match
tests:match
tests:match->sqlqry
tests:get-itemmaps
tests:lookup-itemmap
tests:get-tests-search-path
server:get-best-guess-address
tests:readlines
server:expiration-timeout
runs:get-mt-env-alist
keys:make-key/field-string
sexpr->string
string->sexpr
*bdat*
*user-hash-data*
*db-keys*
*pkts-info*
*configinfo*
*runconfigdat*
*configdat*
*configstatus*
*toppath*
*already-seen-runconfig-info*
*test-meta-updated*
*globalexitstatus*
*passnum*
*common:denoise*
*time-zero*
*default-area-tag*
*dbstruct-db*
*db-stats*
*db-stats-mutex*
*db-last-access*
*db-write-access*
*db-last-sync*
*db-sync-in-progress*
*db-multi-sync-mutex*
*task-db*
*db-access-allowed*
*db-access-mutex*
*db-transaction-mutex*
*db-cache-path*
*db-with-db-mutex*
*db-api-call-time*
*no-sync-db*
*my-signature*
*transport-type*
*logged-in-clients*
*server-info*
*server-run*
*run-id*
*server-kind-run*
*home-host*
*heartbeat-mutex*
*api-process-request-count*
*max-api-process-requests*
*server-overloaded*
*writes-total-delay*
*unclean-shutdown*
*rmt-mutex*
*keys*
*keyvals*
*toptest-paths*
*test-paths*
*test-ids*
*test-info*
*run-info-cache*
*launch-setup-mutex*
*homehost-mutex*
*triggers-mutex*
*numcpus-cache*
*host-loads*
*env-vars-by-run-id*
*testconfigs*
*runconfigs*
*pre-reqs-met-cache*
*verbosity-cache*
*fdb*
*last-launch*
*common:std-states*
*common:dont-roll-up-states*
*common:std-statuses*
*common:ended-states*
*common:badly-ended-states*
*common:well-ended-states*
*common:running-states*
*common:cant-run-states*
*common:not-started-ok-statuses*
*verbosity*
*logging*
*common:thread-punchlist*
*last-num-running-tests*
*seen-cant-run-tests*
*runs:denoise*
*max-tries-hash*
*send-receive-mutex*
*db:process-queue-mutex*
*http-functions*
*http-mutex*
*http-requests-in-progress*
*http-connections-next-cleanup*
*number-of-writes*
*number-non-write-queries*
*global-db-store*
*common:logpro-exit-code->status-sym-alist*
*glob-like-match-cache*
	*

;; bad name - clean this up
keys:config-get-fields
sdb:qry

;; record accessors and settors

bdat-home
bdat-user
bdat-watchdog
bdat-time-to-exit
bdat-task-db
bdat-target
bdat-this-exe-fullpath
bdat-this-exe-dir
bdat-this-exe-name
bdat-orig-env
bdat-runs-data

bdat-task-db-set!
bdat-time-to-exit-set!
bdat-watchdog-set!
bdat-task-db-set!
bdat-target-set!

make-launch:einf
launch:einf-pid
launch:einf-exit-status
launch:einf-exit-code
launch:einf-rollup-status
launch:einf-pid-set!
launch:einf-exit-status-set!
launch:einf-exit-code-set!
launch:einf-rollup-status-set!

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

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

megatest-fossil-hash
)

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

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

;;======================================================================
;; CONTENTS
;;
;;  config file utils
;;  misc conversion, data manipulation functions
;;  testsuite and area utilites
;;
;;======================================================================

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

;;======================================================================
;; Make available the old db_records.scm stuff
;;======================================================================
;;

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

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

;;
;; -path-|-megatest.db
;;       |-db-|-main.db
;;            |-monitor.db
;;            |-sdb.db
;;            |-fdb.db
;;            |-1.db
;;            |-<N>.db
;;
;;
;; Accessors for a dbstruct
;;

;; (define-inline (dbr:dbstruct-main    vec)    (vector-ref  vec 0)) ;; ( db path )
;; (define-inline (dbr:dbstruct-strdb   vec)    (vector-ref  vec 1)) ;; ( db path )
;; (define-inline (dbr:dbstruct-path    vec)    (vector-ref  vec 2)) 
;; (define-inline (dbr:dbstruct-local   vec)    (vector-ref  vec 3))
;; (define-inline (dbr:dbstruct-rundb   vec)    (vector-ref  vec 4)) ;; ( db path )
;; (define-inline (dbr:dbstruct-inmem   vec)    (vector-ref  vec 5)) ;; ( db #f )
;; (define-inline (dbr:dbstruct-mtime   vec)    (vector-ref  vec 6))
;; (define-inline (dbr:dbstruct-rtime   vec)    (vector-ref  vec 7))
;; (define-inline (dbr:dbstruct-stime   vec)    (vector-ref  vec 8))
;; (define-inline (dbr:dbstruct-inuse   vec)    (vector-ref  vec 9))
;; (define-inline (dbr:dbstruct-refdb   vec)    (vector-ref  vec 10)) ;; ( db path )
;; (define-inline (dbr:dbstruct-locdbs  vec)    (vector-ref  vec 11))
;; (define-inline (dbr:dbstruct-olddb   vec)    (vector-ref  vec 12)) ;; ( db path )
;; ;; (define-inline (dbr:dbstruct-main-path vec)  (vector-ref  vec 13))
;; ;; (define-inline (dbr:dbstruct-rundb-path vec) (vector-ref  vec 14))
;; ;; (define-inline (dbr:dbstruct-run-id  vec)    (vector-ref  vec 13))
;; 
;; (define-inline (dbr:dbstruct-main-set!   vec val)(vector-set! vec 0 val))
;; (define-inline (dbr:dbstruct-strdb-set!  vec val)(vector-set! vec 1 val))
;; (define-inline (dbr:dbstruct-path-set!   vec val)(vector-set! vec 2 val))
;; (define-inline (dbr:dbstruct-local-set!  vec val)(vector-set! vec 3 val))
;; (define-inline (dbr:dbstruct-rundb-set!  vec val)(vector-set! vec 4 val))
;; (define-inline (dbr:dbstruct-inmem-set!  vec val)(vector-set! vec 5 val))
;; (define-inline (dbr:dbstruct-mtime-set!  vec val)(vector-set! vec 6 val))
;; (define-inline (dbr:dbstruct-rtime-set!  vec val)(vector-set! vec 7 val))
;; (define-inline (dbr:dbstruct-stime-set!  vec val)(vector-set! vec 8 val))
;; (define-inline (dbr:dbstruct-inuse-set!  vec val)(vector-set! vec 9 val))
;; (define-inline (dbr:dbstruct-refdb-set!  vec val)(vector-set! vec 10 val))
;; (define-inline (dbr:dbstruct-locdbs-set! vec val)(vector-set! vec 11 val))
;; (define-inline (dbr:dbstruct-olddb-set!  vec val)(vector-set! vec 12 val))
;; (define-inline (dbr:dbstruct-main-path-set! vec val)(vector-set! vec 13 val))
;; (define-inline (dbr:dbstruct-rundb-path-set! vec val)(vector-set! vec 14 val))
;; 
; (define-inline (dbr:dbstruct-run-id-set! vec val)(vector-set! vec 13 val))

;; constructor for dbstruct
;;
;; (define (make-dbr:dbstruct #!key (path #f)(local #f))
;;   (let ((v (make-vector 15 #f)))
;;     (dbr:dbstruct-path-set! v path)
;;     (dbr:dbstruct-local-set! v local)
;;     (dbr:dbstruct-locdbs-set! v (make-hash-table))
;;     v))


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

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

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

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

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

;; Test record utility functions

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

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

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

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

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

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

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

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


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

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

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

;;======================================================================
;; end of old db_records.scm
;;

;;======================================================================
;; old run_records stuff
;;

(define (runs:runrec-make-record) (make-vector 13))
(define (runs:runrec-get-target  vec)(vector-ref vec 0))  ;; a/b/c
(define (runs:runrec-get-runname vec)(vector-ref vec 1))  ;; string
(define (runs:runrec-testpatt    vec)(vector-ref vec 2))  ;; a,b/c,d%
(define (runs:runrec-keys        vec)(vector-ref vec 3))  ;; (key1 key2 ...)
(define (runs:runrec-keyvals     vec)(vector-ref vec 4))  ;; ((key1 val1)(key2 val2) ...)
(define (runs:runrec-environment vec)(vector-ref vec 5))  ;; environment, alist key val
(define (runs:runrec-mconfig     vec)(vector-ref vec 6))  ;; megatest.config
(define (runs:runrec-runconfig   vec)(vector-ref vec 7))  ;; runconfigs.config
(define (runs:runrec-serverdat   vec)(vector-ref vec 8))  ;; (host port)
(define (runs:runrec-transport   vec)(vector-ref vec 9))  ;; 'http
(define (runs:runrec-db          vec)(vector-ref vec 10)) ;; <sqlite3db> (if 'fs)
(define (runs:runrec-top-path    vec)(vector-ref vec 11)) ;; *toppath*
(define (runs:runrec-run_id      vec)(vector-ref vec 12)) ;; run-id

(define (test:get-id vec)       (vector-ref vec 0))
(define (test:get-run_id vec)   (vector-ref vec 1))
(define (test:get-test-name vec)(vector-ref vec 2))
(define (test:get-state vec)    (vector-ref vec 3))
(define (test:get-status vec)   (vector-ref vec 4))
(define (test:get-item-path vec)(vector-ref vec 5))

(define (test:test-get-fullname test)
   (conc (db:test-get-testname test)
	 (if (equal? (db:test-get-item-path test) "")
	     ""
	     (conc "(" (db:test-get-item-path test) ")"))))

;;======================================================================
;; end of run_records
;;

;; these come from processmod
;;
;; (define setenv set-environment-variable!)
;; (define unsetenv unset-environment-variable!)
;; (define getenv get-environment-variable)

;; move all the miscellanea into this struct
;;
(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 testpatt-key target) #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 testpatt-key target)))
	    (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)

;; first read ~/views.config if it exists, then read $MTRAH/views.config if it exists
;;
(define (common:load-views-config)
  (let* ((view-cfgdat    (make-hash-table))
	 (home-cfgfile   (conc (get-environment-variable "HOME") "/.mtviews.config"))
	 (mthome-cfgfile (conc *toppath* "/.mtviews.config")))
    (if (common:file-exists? mthome-cfgfile)
	(configf:read-config mthome-cfgfile view-cfgdat))
	(configf:read-config mthome-cfgfile view-cfgdat #t))
    ;; we load the home dir file AFTER the MTRAH file so the user can clobber settings when running the dashboard in read-only areas
    (if (common:file-exists? home-cfgfile)
	(configf:read-config home-cfgfile view-cfgdat #t))
    view-cfgdat))

;;======================================================================
;; H I E R A R C H I C A L   H A S H   T A B L E S

	  (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:get-sections
	 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
	 getenv
	 mytarget
	 nice-path
	 process:cmd-run->list
	 runconfig:read
	 runconfigs-get
	 safe-setenv
	 setenv
	 configf:eval-string-in-environment
	)
	
(import scheme

	big-chicken        ;; more of a reminder than anything ...
	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!)

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

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

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

(define (configf:lookup cfgdat section var)
  (if (hash-table? cfgdat)
      (let ((sectdat (hash-table-ref/default cfgdat section '())))
	(if (null? sectdat)
	    #f
	    (let ((match (assoc var sectdat)))
	      (if match ;; (and match (list? match)(> (length match) 1))
		  (cadr match)
	    (let ((res (assoc var sectdat)))
	      (if res ;; (and match (list? match)(> (length match) 1))
		  (cadr res)
		  #f))
	    ))
      #f))

(define (configf:get-sections cfgdat)
  (filter string? (hash-table-keys cfgdat)))

(define (configf:assoc-safe-add alist key val #!key (metadata #f))
  (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist)))
    (append newalist (list (if metadata
			       (list key val metadata)
			       (list key val))))))

(define (configf:section-var-set! cfgdat section-name var value #!key (metadata #f))

	     (rxstr (if (string-contains section-name "%")
			(string-substitute (regexp "%") ".*" section-name)
			(string-substitute (regexp "^/(.*)/$") "\\1" section-name)))
	     (rx    (regexp rxstr)))
	;; (print "\nsection-name: " section-name " rxstr: " rxstr)
        (for-each
         (lambda (section)
	   (if section
	   (if (string? section)
	       (let ((same-section (string=? section-name section))
		     (rx-match     (string-match rx section)))
		 ;; (print "section: " section " vars: " vars " same-section: " same-section " rx-match: " rx-match)
		 (if (and (not same-section) rx-match)
		     (for-each
		      (lambda (bundle)
			;; (print "bundle: " bundle)

;;    'return-string -- return a string representing a proc taking ht as an argument that may be evaulated at some future time
;; envion-patt is a regex spec that identifies sections that will be eval'd
;; in the environment on the fly
;; sections: #f => get all, else list of sections to gather
;; post-section-procs alist of section-pattern => proc, where: (proc section-name next-section-name ht curr-path)
;; apply-wildcards: #t/#f - apply vars from targets with % wildcards to all matching sections
;;
(define (configf:read-config path ht allow-system #!key (environ-patt #f)            (curr-section #f)   
		     (sections #f)              (settings (make-hash-table)) (keep-filenames #f)
		     (post-section-procs '())   (apply-wildcards #t) (env-to-use #f))
(define (configf:read-config path ht allow-system
			     #!key (environ-patt #f)  (curr-section #f)   
			     (sections #f)            (settings (make-hash-table))
			     (keep-filenames #f)      (post-section-procs '())
			     (apply-wildcards #t)     (env-to-use #f))
  (debug:print 9 *default-log-port* "START: " path)
;; (if *configdat*
;;     (common:save-pkt `((action . read-config)
;;       		 (f      . ,(cond ((string? path) path)
;;       				  ((port?   path) "port")
;;       				  (else (conc path))))
;;                        (T      . configf))
;;       	       *configdat* #t add-only: #t))
  (if (and (not (port? path))
	   (not (file-exists? path))) ;; for case where we are handed a port
      (begin 
	(debug:print-info 1 *default-log-port* "configf:read-config - file not found " path " current path: " (current-directory))
	;; WARNING: This is a risky change but really, we should not return an empty hash table if no file read?
	#f) ;; (if (not ht)(make-hash-table) ht))
      (let (;; (env-to-use (if env-to-use env-to-use (module-environment 'configfmod)))
	    (inp        (if (string? path)
			    (open-input-file path)
			      path)) ;; we can be handed a port
	    (res        (let ((ht-in (if (not ht)
	    (res        (if (not ht)(make-hash-table) ht))
					 (make-hash-table)
					 ht)))
			  (if (not (configf:lookup ht-in "" "toppath"))
			      (configf:set-section-var ht-in "" "toppath" path))
			  ht-in))
	    (metapath   (if (or (debug:debug-mode 9)
				keep-filenames)
			    path #f))
            (process-wildcards  (lambda (res curr-section-name)
                                  (if (and apply-wildcards
                                           (or (string-contains curr-section-name "%")   ;; wildcard
                                               (string-match "/.*/" curr-section-name))) ;; regex

                delta-env-alist))))
    (let ((rv (thunk)))
      (for-each (lambda (x) (x)) restore-thunks) ;; restore env to original state
      rv)))

;; return a nice clean pathname made absolute
(define (common:nice-path dir)
  (let ((match (string-match "^(~[^\\/]*)(\\/.*|)$" dir)))
    (if match ;; using ~ for home?
	(common:nice-path (conc (common:read-link-f (cadr match)) "/" (caddr match)))
  (let ((res (string-match "^(~[^\\/]*)(\\/.*|)$" dir)))
    (if res ;; using ~ for home?
	(common:nice-path (conc (common:read-link-f (cadr res)) "/" (caddr res)))
	(normalize-pathname (if (absolute-pathname? dir)
				dir
				(conc (current-directory) "/" dir))))))

;; make "nice-path" available in config files and the repl
(define nice-path common:nice-path)

		   (tal (cdr fdat))
		   (cur "")
		   (led #f)
		   (res '()))
	  ;; ALL WHITESPACE LEADING LINES ARE TACKED ON!!
	  ;;  1. remove led whitespace
	  ;;  2. tack on to hed with "\n"
	  (let ((match (string-match configf:cont-ln-rx hed)))
	    (if match ;; blast! have to deal with a multiline
		(let* ((lead (cadr match))
		       (lval (caddr match))
	  (let ((res (string-match configf:cont-ln-rx hed)))
	    (if res ;; blast! have to deal with a multiline
		(let* ((lead (cadr res))
		       (lval (caddr res))
		       (newl (conc cur "\n" lval)))
		  (if (not led)(set! led lead))
		  (if (null? tal) 
		      (set! fdat (append fdat (list newl)))
		      (loop (car tal)(cdr tal) newl led res))) ;; NB// not tacking newl onto res
		(let ((newres (if led 
				  (append res (list cur hed))

;; convert hierarchial list to ini format
;;
(define (configf:config->ini data)
  (map 
   (lambda (section)
     (let ((section-name (car section))
	   (section-dat  (cdr section)))
       (if (string? section-name)
	   (begin
       (print "\n[" section-name "]")
       (map (lambda (dat-pair)
	      (let* ((var (car dat-pair))
		     (val (cadr dat-pair))
		     (fname (if (> (length dat-pair) 2)(caddr dat-pair) #f)))
		(if fname (print "# " var "=>" fname))
		(print var " " val)))
	    section-dat))) ;;       (print "section-dat: " section-dat))
	     (print "\n[" section-name "]")
	     (map (lambda (dat-pair)
		    (let* ((var (car dat-pair))
			   (val (cadr dat-pair))
			   (fname (if (> (length dat-pair) 2)(caddr dat-pair) #f)))
		      (if fname (print "# " var "=>" fname))
		      (print var " " val)))
		  section-dat))))) ;;       (print "section-dat: " section-dat))
   (hash-table->alist data)))

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

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

;; convert to param?
(define configf:std-imports "(import big-chicken configfmod commonmod rmtmod (prefix mtargs args:))")
(define (configf:process-one matchdat l ht allow-system env-to-use linenum)
  (let* ((prestr  (list-ref matchdat 1))
	 (cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv
	 (cmd     (list-ref matchdat 3))
	 (quotedcmd (conc "\""cmd"\""))
	 (poststr (list-ref matchdat 4))
	 (result  #f)
	 (start-time (current-seconds))
	 (cmdsym  (string->symbol cmdtype))
	 (fullcmd
	  (if (member cmdsym '(scheme scm))
	      `(eval-needed
		,(conc  "(lambda (ht)"
(define configf:std-imports "") ;;(import configfmod commonmod)")

			configf:std-imports
			cmd ")"))
	      (case cmdsym
		((system)     `(noeval-needed  ,(conc (configf:system ht cmd))))
		;; ((shell sh)   `(noeval-needed  ,(conc (string-translate (shell quotedcmd) "\n" " "))))
		((shell sh)   `(noeval-needed  ,(conc (string-translate (shell cmd) "\n" " "))))
		((realpath rp)`(noeval-needed  ,(conc (common:nice-path quotedcmd))))
		((getenv gv)  `(noeval-needed  ,(conc (get-environment-variable cmd))))
		((mtrah)      `(noeval-needed  ,(configf:lookup ht "" "toppath")))
		((get g)   
		 (match
		  (string-split cmd)
		  ((sect var) `(noeval-needed ,(configf:lookup ht sect var)))
		  (else
		   (debug:print-error 0 *default-log-port* "#{get ...} used with only one parameter, \"" cmd "\", two needed.")
		   '(bad-param ,(conc "#{get ...} used with only one parameter, \"" cmd "\", two needed.")))))
		((runconfigs-get rget) `(noeval-needed ,(runconfigs-get ht quotedcmd))) ;; (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
		(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))
     (else ;; (#f errres)
      (debug:print 0 *default-log-port* "WARNING: failed to process config input \""l"\", fullcmd="fullcmd".")))
    ;; we process as a result
    (let ((delta (- (current-seconds) start-time)))
      (debug:print-info (if (> delta 2) 0 9) *default-log-port* "for line \"" l "\"\n command:  " cmd " took " delta " seconds to run with output:\n   " result))
    (conc prestr result poststr)))
	      
(define (configf:process-line l ht allow-system env-to-use #!key (linenum #f))
  (let loop ((res l))
    (if (string? res)
	(let ((matchdat (string-search configf:var-expand-regex res)))
	  (if matchdat
	      (let ((result (configf:process-one matchdat l ht allow-system env-to-use linenum)))
		(loop result))
	      res))
	  res)))

(define (configf:process-line-old l ht allow-system env-to-use #!key (linenum #f))
  (let loop ((res l))
    (if (string? res)
	(let ((matchdat (string-search configf:var-expand-regex res)))
	  (if matchdat
	      (let* ((prestr  (list-ref matchdat 1))
		     (cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv
		     (cmd     (list-ref matchdat 3))
		     (poststr (list-ref matchdat 4))
		     (result  #f)
		     (start-time (current-seconds))
		     (cmdsym  (string->symbol cmdtype))
		     (fullcmd
		      (conc  configf:std-imports
			     "(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 var #!optional (target #f))
  (let ((targ (or target (mytarget)))) ;; (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)

  (debug:print 0 *default-log-port* "INFO: NEED LOCKING ADDED HERE " fname)
  (let* ((dat  (configf:config->alist cdat))
         (res
          (begin
            (with-output-to-file fname ;; first write out the file
              (lambda ()
                (pp dat)))
            
            ;; I don't like this. It makes write-alist opaque and complicated. -mrw-
            (if (file-exists? fname)   ;; now verify it is readable
                (if (configf:read-alist fname)
                    #t ;; data is good.
                    (begin
                      (handle-exceptions
			  exn
			(begin

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

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

(declare (unit dashboard-context-menu))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses dbmod))
;; (declare (uses gutils))
(declare (uses rmtmod))
(declare (uses ezstepsmod))
;; (declare (uses sdb))
;; (declare (uses filedb))
(declare (uses subrunmod))
(declare (uses debugprint))
(declare (uses testsmod))
(declare (uses dcommon))

(module dashboard-context-menu
         (
dboard:launch-testpanel
dashboard:run-menu-items
dashboard:test-menu-items
dashboard:step-logs-menu-item
dashboard:toplevel-menu-items
dashboard:custom-menu-items
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
	chicken.time

	srfi-1
(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))
(import commonmod
	dbmod
(declare (uses gutils))
(declare (uses rmt))
(declare (uses ezsteps))
;; (declare (uses sdb))
;; (declare (uses filedb))
(declare (uses subrun))
	rmtmod
	ezstepsmod
	subrunmod
	debugprint
	configfmod
	testsmod
	dcommon
	;; gutils
	)


(include "common_records.scm")
(include "db_records.scm")
(include "run_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
                    " &")))
    (system cmd)))

;; 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 "db_records.scm")
(include "run_records.scm")
(include "task_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)
(require-library iup)
(import (prefix iup iup:))

(use canvas-draw)

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

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

(module dashboard-tests
	  (
message-window
test-info-panel
test-meta-panel-get-description
test-meta-panel
run-info-panel
host-info-panel
submegatest-panel
update-state-status-buttons
set-fields-panel
dashboard-tests:run-a-step
dashboard-tests:waiver
dashboard-tests:examine-test
colors-similar?
dashboard:draw-tests
dboard:tabdat-test-patts-use
dashboard:update-run-command
iuplistbox-fill-list
*tim*
*dashboard-comment-share-slot*
*state-status*
*dashboard-test-db*
*dashboard-comment-share-slot*
)


(import scheme
	chicken.file.posix
	chicken.base
	chicken.string
	chicken.condition
	chicken.file
	chicken.process-context
	chicken.time
	
	format
	fmt
	(prefix iup iup:)
	canvas-draw
	srfi-1
	srfi-18
	regex regex-case srfi-69
	(prefix sqlite3 sqlite3:))

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

(import commonmod
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
	dcommon
	dbmod
	rmtmod
	ezstepsmod
	subrunmod
	debugprint
;;	gutils
	configfmod
	testsmod
	mtmod
	launchmod
	)

;;======================================================================
;; C O M M O N
;;======================================================================
(define *tim* (iup:timer))

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

(define (message-window msg)
  (iup:show
   (iup:dialog
    (iup:vbox 

    dlog))


;;======================================================================
;;
;;======================================================================
(define (dashboard-tests:examine-test run-id test-id) ;; run-id run-key origtest)
  (let* ((db-path       (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db"))
	 (dbstruct      #f) ;; NOT ACTUALLY USED (db:setup)) ;; (make-dbr:dbstruct path:  (db:dbfile-path #f) ;; (configf:lookup *configdat* "setup" "linktree") 
  (let* ((db-path       (common:get-db-tmp-area)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db"))
	 (dbstruct      #f) ;; NOT ACTUALLY USED (db:setup)) ;; (make-dbr:dbstruct path:  (common:get-db-tmp-area #f) ;; (configf:lookup *configdat* "setup" "linktree") 
			    ;;		   local: #t))
	 (testdat        (rmt:get-test-info-by-id run-id test-id)) ;; (db:get-test-info-by-id dbstruct run-id test-id))
	 (db-mod-time   0) ;; (file-modification-time db-path))
	 (last-update   0) ;; (current-seconds))
	 (request-update #t))
    (if (not testdat)
	(begin

	  (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records))
	(dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records))
    ))

(define (dboard:tabdat-test-patts-use vec)    
  (let ((val (dboard:tabdat-test-patts vec)))(if val val ""))) ;;RADT => What is the if for?

;; additional setters for dboard:data
(define (dboard:tabdat-test-patts-set!-use    vec val)
  (dboard:tabdat-test-patts-set! vec (if (equal? val "") #f val)))
;; ;; additional setters for dboard:data
;; (define (dboard:tabdat-test-patts-set!-use    vec val)
;;   (dboard:tabdat-test-patts-set! vec (if (equal? val "") #f val)))

;; Extract the various bits of data from tabdat and create the command line equivalent that will be displayed
;;
(define (dashboard:update-run-command tabdat)
  (let* ((cmd-tb       (dboard:tabdat-command-tb tabdat))
	 (cmd          (dboard:tabdat-command    tabdat))
	 (test-patt    (let ((tp (dboard:tabdat-test-patts tabdat)))

		    (if (equal? selected-item item)
			(iup:attribute-set! lb "VALUE" i))) ;; (number->string i))))
		(set! i (+ i 1)))
	      items)
    ;; (iup:attribute-set! lb "VALUE" (if selected-item selected-item ""))
    i))

;; if tab-num passed in then use it, otherwise look in commondat at curr-tab-num
;; adds the updater passed in the updaters list at that hashkey
;;
(define (dboard:commondat-add-updater commondat updater #!key (tab-num #f))
  (let* ((tnum          (or tab-num
			     (dboard:commondat-curr-tab-num commondat)))
	 (curr-updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '())))
    (hash-table-set! (dboard:commondat-updaters commondat)
		     tnum
		     (cons updater curr-updaters))))

)

;;     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)
(declare (uses ducttape-lib))

(require-library iup)
(declare (uses debugprint))
(import (prefix iup iup:))

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

(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 dashboard-main))
(declare (uses mt))
(declare (uses configfmod))
(declare (uses dashboard-context-menu))
(declare (uses dashboard-tests))
(declare (uses dbmod))
(declare (uses dcommon))
;; (declare (uses debugprint.import))
(declare (uses itemsmod))
(declare (uses launchmod))
(declare (uses mtargs))
(declare (uses mtmod))
(declare (uses mtver))
(declare (uses processmod))
(declare (uses runsmod))
(declare (uses rmtmod))
(declare (uses subrunmod))
(declare (uses tree))
(declare (uses vgmod))
(declare (uses testsmod))
(declare (uses tasksmod))

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

(module dashboard
	*
	
(import scheme
	chicken.base
	chicken.bitwise
	chicken.condition
	chicken.eval
	chicken.file
	chicken.file.posix
	chicken.format
	chicken.io
	chicken.irregex
	chicken.pathname
	chicken.port
	chicken.pretty-print
	chicken.process
	chicken.process-context
	chicken.process-context.posix
	chicken.process.signal
	chicken.random
	chicken.repl
	chicken.sort
	chicken.string
	chicken.tcp
	chicken.time
	chicken.time.posix

	(prefix iup iup:)
	canvas-draw
	canvas-draw-iup
	(prefix sqlite3 sqlite3:)
	srfi-1
	regex regex-case srfi-69
	typed-records
	sparse-vectors
	format
	srfi-4
	srfi-14
	)

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

(import (prefix mtargs args:)
	;; gutils
	bigmod
	commonmod
	configfmod
	dashboard-context-menu
	dashboard-tests
	dbmod
	dcommon
	debugprint
	itemsmod
	launchmod
	mtmod
	mtver
	processmod
	rmtmod
	runsmod
	subrunmod
	tasksmod
	testsmod
	tree
	vgmod
        ducttape-lib
	)

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

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

	(debug:print 4 *default-log-port* "Found these updaters: " updaters " for tab-num: " tnum)
	(for-each ;; perform the function calls for the complete updaters list
	 (lambda (updater)
	   ;; (debug:print 3 *default-log-port* "Running " updater)
	   (updater))
	 updaters))))

;; if tab-num passed in then use it, otherwise look in commondat at curr-tab-num
;; adds the updater passed in the updaters list at that hashkey
;;
(define (dboard:commondat-add-updater commondat updater #!key (tab-num #f))
  (let* ((tnum          (or tab-num
			     (dboard:commondat-curr-tab-num commondat)))
	 (curr-updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '())))
    (hash-table-set! (dboard:commondat-updaters commondat)
		     tnum
		     (cons updater curr-updaters))))

;; data for each specific tab goes here
;;
(defstruct dboard:tabdat 
  ;; runs
  ((allruns         '())                 : list)        ;; list of dboard:rundat records
  ((allruns-by-id    (make-hash-table))  : hash-table)  ;; hash of run-id -> dboard:rundat records
  ((done-runs       '())                 : list)        ;; list of runs already drawn
  ((not-done-runs   '())                 : list)        ;; list of runs not yet drawn
  (header            #f)                                ;; header for decoding the run records
  (keys              #f)                                ;; keys for this run (i.e. target components)
  ((numruns          (string->number (or (args:get-arg "-cols")
					 (configf:lookup *configdat* "dashboard" "cols")
					 "8")))                 : number)      ;; 
  ((tot-runs          0)                 : number)
  ((last-data-update  0)                 : number)      ;; last time the data in allruns was updated
  ((last-runs-update  0)                 : number)      ;; last time we pulled the runs info to update the tree
  (runs-mutex         (make-mutex))                     ;; use to prevent parallel access to draw objects
  ((run-update-times  (make-hash-table)) : hash-table)  ;; update times indexed by run-id
  ((last-test-dat      (make-hash-table)) : hash-table)  ;; cache last tests dat by run-id
  ((run-db-paths      (make-hash-table)) : hash-table)  ;; cache the paths to the run db files

  ;; Runs view
  ((buttondat         (make-hash-table)) : hash-table)  ;;     
  ((item-test-names  '())                : list)        ;; list of itemized tests
  ((run-keys          (make-hash-table)) : hash-table)
  (runs-matrix        #f)                               ;; used in newdashboard
  ((start-run-offset   0)                : number)      ;; left-right slider value
  ((start-test-offset  0)                : number)      ;; up-down slider value
  ((runs-btn-height    (or (configf:lookup *configdat* "dashboard" "btn-height") "x16")) : string)  ;; was 12
  ((runs-btn-fontsz    (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10")) : string)   ;; was 8
  ((runs-cell-width    (or (configf:lookup *configdat* "dashboard" "cell-width") "50")) : string)   ;; was 50
  ((all-test-names     '())              : list)
  
  ;; Canvas and drawing data
  (cnv                #f)
  (cnv-obj            #f)
  (drawing            #f)
  ((run-start-row     0)                 : number)
  ((max-row           0)                 : number)
  ((running-layout    #f)                : boolean)
  (originx            #f)
  (originy            #f)
  ((layout-update-ok  #t)                : boolean)
  ((compact-layout    #t)                : boolean)

  ;; Run times layout
  ;; (graph-button-box #f) ;; RA => Think it is not referenced anywhere
  (graph-matrix     #f)
  ((graph-matrix-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru graph name info
  ((graph-cell-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru matrix cell info
  ((graph-matrix-row 1) : number)
  ((graph-matrix-col 1) : number)

  ;; Controls used to launch runs etc.
  ((command          "")                 : string)      ;; for run control this is the command being built up
  (command-tb        #f)	                        ;; widget for the type of command; run, remove-runs etc.
  (test-patterns-textbox #f)                            ;; text box widget for editing a list of test patterns
  (key-listboxes     #f)			         
  (key-lbs           #f)			         
  run-name                                              ;; from run name setting widget
  states                                                ;; states for -state s1,s2 ...
  statuses                                              ;; statuses for -status s1,s2 ...
						         
  ;; Selector variables				         
  curr-run-id                                           ;; current row to display in Run summary view
  prev-run-id                                           ;; previous runid selected before current runid was selected (used in xor-two-runs runs summary mode
  curr-test-ids                                         ;; used only in dcommon:run-update which is used in newdashboard
  ((filters-changed  #t)                  : boolean)    ;; to indicate that the user changed filters for this tab
  ((last-filter-str  "")                  : string)      ;; conc the target runname and testpatt for a signature of changed filters
  ((hide-empty-runs  #f)                  : boolean)     
  ((hide-not-hide    #t)                  : boolean)     ;; toggle for hide/not hide empty runs
  (hide-not-hide-button #f)
  ((searchpatts        (make-hash-table)) : hash-table)  ;;
  ((state-ignore-hash  (make-hash-table)) : hash-table)  ;; hash of  STATE => #t/#f for display control
  ((status-ignore-hash (make-hash-table)) : hash-table)  ;; hash of STATUS => #t/#f
  (target              #f)
  (test-patts          #f)

  ;; db info to file the .db files for the area
  (access-mode        (db:get-access-mode))             ;; use cached db or not
  (dbdir               #f)
  (dbfpath             #f)
  (dbkeys              #f)
  ((last-db-update     (make-hash-table)) : hash-table) ;; last db file timestamp
  (monitor-db-path     #f)                              ;; where to find monitor.db
  ro                                                    ;; is the database read-only?

  ;; tests data
  ((num-tests          10)               : number)      ;; total number of tests to show (used in the old runs display)

  ;; runs tree
  ((path-run-ids       (make-hash-table)) : hash-table) ;; path (target / runname) => id
  (runs-tree           #f)
  ((runs-tree-ht       (make-hash-table)) : hash-table) ;; track which targets added to tree (merge functionality with path-run-ids?)

  ;; tab data
  ((view-changed       #t)                : boolean)   
  ((xadj               0)                 : number)     ;; x slider number (if using canvas)
  ((yadj               0)                 : number)     ;; y slider number (if using canvas)
  ;; runs-summary tab state
  ((runs-summary-modes '((one-run . "Show One Run") (xor-two-runs . "XOR Two Runs") (xor-two-runs-hide-clean . "XOR; Hide Clean")) )   : list)
  ((runs-summary-mode-buttons '())               : list)
  ((runs-summary-mode  'one-run)            : symbol)
  ((runs-summary-mode-change-callbacks '()) : list)
  (runs-summary-source-runname-label #f)
  (runs-summary-dest-runname-label #f)
  ;; runs summary view
  
  tests-tree       ;; used in newdashboard
  )

;; register tabdat with BBpp
;; this is used by BBpp (Brandon's pretty printer) to convert dboard:tabdat into a composition of lists that pp will handle
(hash-table-set! *BBpp_custom_expanders_list* TABDAT:
#;(hash-table-set! *BBpp_custom_expanders_list* TABDAT:
                 (cons dboard:tabdat?
                       (lambda (tabdat-item)
                         (filter
                          (lambda (alist-entry)
                            (member (car alist-entry)
                                    '(allruns-by-id allruns))) ;; FIELDS OF INTEREST
                          (dboard:tabdat->alist tabdat-item)))))



(define (dboard:tabdat-target-string vec)
  (let ((targ (dboard:tabdat-target vec)))
    (if (list? targ)(string-intersperse targ "/") "no-target-specified")))

(define (dboard:tabdat-test-patts-use vec)    
  (let ((val (dboard:tabdat-test-patts vec)))(if val val ""))) ;;RADT => What is the if for?

;; additional setters for dboard:data
(define (dboard:tabdat-test-patts-set!-use    vec val)
  (dboard:tabdat-test-patts-set! vec (if (equal? val "") #f val)))

(define (dboard:tabdat-make-data)
  (let ((dat (make-dboard:tabdat)))
    (dboard:setup-tabdat dat)
    (dboard:setup-num-rows dat)
    dat))

(define (dboard:setup-tabdat tabdat)
  (dboard:tabdat-dbdir-set! tabdat (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
  (dboard:tabdat-dbfpath-set! tabdat (db:dbfile-path))
  (dboard:tabdat-dbdir-set! tabdat (common:get-db-tmp-area)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
  (dboard:tabdat-dbfpath-set! tabdat (common:get-db-tmp-area))
  (dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db"))

  ;; HACK ALERT: this is a hack, please fix.
  (dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat))))
  (dboard:tabdat-ro-set! tabdat (not (file-readable? (dboard:tabdat-dbfpath tabdat))))
  
  (dboard:tabdat-keys-set! tabdat (rmt:get-keys))
  (dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname")))
  (dboard:tabdat-tot-runs-set! tabdat (rmt:get-num-runs "%"))
  )

;; RADT => Matrix defstruct addition

  
  ;; data from sql db
  (keys       (rmt:get-keys))         ;; to be removed when targets handling is refactored
  (runs       (make-sparse-vector))   ;; id => runrec
  (runsbynum  (make-vector 100 #f))   ;; vector num => runrec 
  (targ-runid (make-hash-table))      ;; area/target/runname => run-id  ;; not sure this will be needed
  (tests      (make-hash-table))      ;; test[/itempath] => list of test rec
  (path-run-ids (make-hash-table))    ;; path => run-id (this is a guess based on code reference)

  
  ;; run sql filters 
  (targ-sql-filt        "%")
  (runname-sql-filt     "%")
  (run-state-sql-filt   "%")
  (run-status-sql-filt  "%")

  ;; test sql filter

  status
  start-time
  duration
  )

;; register dboard:rundat with BBpp
;; this is used by BBpp (Brandon's pretty printer) to convert dboard:rundat into a composition of lists that pp will handle
(hash-table-set! *BBpp_custom_expanders_list* RUNDAT:
#;(hash-table-set! *BBpp_custom_expanders_list* RUNDAT:
                 (cons dboard:rundat?
                       (lambda (tabdat-item)
                         (filter
                          (lambda (alist-entry)
                            (member (car alist-entry)
                                    '(run run-data-offset ))) ;; FIELDS OF INTEREST
                          (dboard:rundat->alist tabdat-item)))))

  id       ;; testid
  state    ;; test state
  status   ;; test status
  )

;; default is to NOT set the cell if the column and row names are not pre-existing
;;
(define (dboard:runsdat-set-test-cell dat target runname testname itempath test-id state status #!key (force-set #f))
#;(define (dboard:runsdat-set-test-cell dat target runname testname itempath test-id state status #!key (force-set #f))
  (let* ((col-num  (dcommon:runsdat-get-col-num dat target runname force-set))
	 (row-num  (dcommon:runsdat-get-row-num dat testname itempath force-set)))
    (if (and row-num col-num)
	(let ((tdat (dboard:testdat 
		     id: test-id
		     state: state
		     status: status)))
	  (sparse-array-set! (dboard:runsdat-matrix-dat dat) col-num row-num tdat)
	  tdat)
	#f)))

(define *dashboard-mode* (string->symbol (or (configf:lookup *configdat* "dashboard" "mode") "dashboard")))
  

(define *exit-started* #f)

;; sorting global data (would apply to many testsuites so leave it global for now)
;;
(define *tests-sort-options* (vector (vector "Sort +a" 'testname   "ASC")
				     (vector "Sort -a" 'testname   "DESC")
				     (vector "Sort +t" 'event_time "ASC")
				     (vector "Sort -t" 'event_time "DESC")
				     (vector "Sort +s" 'statestatus "ASC")

(define-inline (dboard:uidat-get-keycol  vec)(vector-ref vec 0))
(define-inline (dboard:uidat-get-lftcol  vec)(vector-ref vec 1))
(define-inline (dboard:uidat-get-header  vec)(vector-ref vec 2))
(define-inline (dboard:uidat-get-runsvec vec)(vector-ref vec 3))

(if (get-environment-variable "MT_RUN_AREA_HOME")(change-directory (get-environment-variable "MT_RUN_AREA_HOME")))

(define (message-window msg)
  (iup:show
   (iup:dialog
    (iup:vbox 
     (iup:label msg #:margin "40x40")))))

(define (iuplistbox-fill-list lb items #!key (selected-item #f))
  (let ((i 1))
    (for-each (lambda (item)
		(iup:attribute-set! lb (number->string i) item)
		(if selected-item
		    (if (equal? selected-item item)
			(iup:attribute-set! lb "VALUE" i))) ;; (number->string i))))
		(set! i (+ i 1)))
	      items)
    ;; (iup:attribute-set! lb "VALUE" (if selected-item selected-item ""))
    i))

(define (pad-list l n)(append l (make-list (- n (length l)))))

(define (colors-similar? color1 color2)
  (let* ((c1    (map string->number (string-split color1)))
	 (c2    (map string->number (string-split color2)))
	 (delta (map (lambda (a b)(abs (- a b))) c1 c2)))
    (null? (filter (lambda (x)(> x 3)) delta))))

(define (dboard:compare-tests test1 test2)
  (let* ((test-name1  (db:test-get-testname  test1))
	 (item-path1  (db:test-get-item-path test1))
	 (eventtime1  (db:test-get-event_time test1))
	 (test-name2  (db:test-get-testname  test2))
	 (item-path2  (db:test-get-item-path test2))
	 (eventtime2  (db:test-get-event_time test2))

    ;; create the minimize list of testnames to be displayed. Sorting
    ;; happens here *before* trimming
    ;;
    (dboard:tabdat-all-test-names-set!
     tabdat
     (collapse-rows
      tabdat
      (sort (hash-table-keys all-test-names) string>?))) ;; FIXME: Sorting needs to happen here
      (sort (filter string? (hash-table-keys all-test-names)) string>?))) ;; FIXME: Sorting needs to happen here

    ;; Trim the names list to fit the matrix of buttons
    ;;
    (dboard:tabdat-all-test-names-set!
     tabdat
     (let ((xl (if (> (length (dboard:tabdat-all-test-names tabdat)) (dboard:tabdat-start-test-offset tabdat))
		   (drop (dboard:tabdat-all-test-names tabdat)

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

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

				      (hash-table-delete! alltgls item)
				      (hash-table-set! alltgls item #t))
				  (let ((all (hash-table-keys alltgls)))
				    (proc all)))
				"text-list-toggle-box"))))
		items))))

;; Extract the various bits of data from tabdat and create the command line equivalent that will be displayed
;;
(define (dashboard:update-run-command tabdat)
  (let* ((cmd-tb       (dboard:tabdat-command-tb tabdat))
	 (cmd          (dboard:tabdat-command    tabdat))
	 (test-patt    (let ((tp (dboard:tabdat-test-patts tabdat)))
			 (if (or (not tp)
                                 (equal? tp ""))
                             "%"
                             tp)))
	 (states       (dboard:tabdat-states     tabdat))
	 (statuses     (dboard:tabdat-statuses   tabdat))
	 (target       (let ((targ-list (dboard:tabdat-target     tabdat)))
			 (if targ-list (string-intersperse targ-list "/") "no-target-selected")))
	 (run-name     (dboard:tabdat-run-name   tabdat))
	 (states-str   (if (or (not states)
			       (null? states))
			   ""
			   (conc " -state "  (string-intersperse states ","))))
	 (statuses-str (if (or (not statuses)
			       (null? statuses))
			   ""
			   (conc " -status " (string-intersperse statuses ","))))
	 (full-cmd  "megatest"))
    (case (string->symbol cmd)
      ((run)
       (set! full-cmd (conc full-cmd 
			    " -run"
			    " -testpatt "
			    test-patt
			    " -target "
			    target
			    " -runname "
			    run-name
			    " -clean-cache"
			    )))
      ((remove-runs)
       (set! full-cmd (conc full-cmd
			    " -remove-runs -runname "
			    run-name
			    " -target " 
			    target
			    " -testpatt "
			    test-patt
			    states-str
			    statuses-str
			    )))
      (else (set! full-cmd " no valid command ")))
    (iup:attribute-set! cmd-tb "VALUE" full-cmd)))

;; Display the tests as rows of boxes on the test/task pane
;;
(define (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames test-records)
  (canvas-clear! cnv)
  (canvas-font-set! cnv "Helvetica, -10")
  (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv))
	       ((originx originy)             (canvas-origin cnv)))
    ;; (print "originx: " originx " originy: " originy)
    ;; (canvas-origin-set! cnv 0 (- (/ sizey 2)))
    (if (hash-table-ref/default tests-draw-state 'first-time #t)
	(begin
	  (hash-table-set! tests-draw-state 'first-time #f)
	  (hash-table-set! tests-draw-state 'scalef 1)
	  (hash-table-set! tests-draw-state 'tests-info (make-hash-table))
	  (hash-table-set! tests-draw-state 'selected-tests (make-hash-table))
	  ;; set these 
	  (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records))
	(dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records))
    ))

;;======================================================================
;; R U N   C O N T R O L S
;;======================================================================
;;
;; A gui for launching tests
;;

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

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

(define (tree-path->run-id tabdat path)
  (if (not (null? path))
      (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) path #f)
      #f))

(define (new-tree-path->run-id rdat path)
  (if (not (null? path))
      (hash-table-ref/default (dboard:rdat-path-run-ids tabdat) path #f)
      (hash-table-ref/default (dboard:rdat-path-run-ids rdat) path #f)
      #f))

;; (define (dboard:get-tests-dat tabdat run-id last-update)
;;   (let* ((access-mode     (dboard:tabdat-access-mode tabdat))
;;          (tdat (if run-id (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run
;;                                              run-id 
;; 					     (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")

;;======================================================================
;; S U M M A R Y 
;;======================================================================
;;
;; General info about the run(s) and megatest area
(define (dashboard:summary commondat tabdat #!key (tab-num #f))
  (let* ((rawconfig        (read-config (conc *toppath* "/megatest.config") #f #f)) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string)))
  (let* ((rawconfig        (configf:read-config (conc *toppath* "/megatest.config") #f #f)) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string)))
	 (changed          #f))
    (iup:vbox
     (iup:split
      #:value 300
      (iup:frame 
       #:title "General Info"
       (iup:vbox

(define (dboard:add-external-tab commondat view-name views-cfgdat tabs tab-num)
  (let* ((success #t) ;; at any stage of the process set this flag to #f to skip downstream steps. Intention here is to recover gracefully if user provided tabs fail to load.
	 (source  (configf:lookup views-cfgdat view-name "source"))
	 (viewgen (configf:lookup views-cfgdat view-name "viewgen"))
	 (updater (configf:lookup views-cfgdat view-name "updater"))
	 (result-child #f))
    (if (and (common:file-exists? source)
	     (file-read-access? source))
	     (file-readable? source))
	(handle-exceptions
	 exn
	 (begin
	   (print-call-chain)
	   (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
	   (debug:print 0 *default-log-port* "ERROR: failed to load " source ", try loading in the repl: megatest -repl")
	   (set! success #f))

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

			   ;; user supplied source for a tab
			   ;;
			   ((external) ;; was tabs
			    (let ((tab-content (dboard:add-external-tab commondat view-name views-cfgdat #f tab-num)))
			      (set! additional-tabnames (cons (cons tab-num view-name) additional-tabnames))
			      (set! tab-num (+ tab-num 1))
			      (set! result (append result (list tab-content)))))))))
		 (sort (hash-table-keys views-cfgdat)
		 (sort (configf:get-sections views-cfgdat) ;; (hash-table-keys views-cfgdat)
		       (lambda (a b)
			 (let ((order-a (or (any->number (configf:lookup views-cfgdat a "order")) 999))
			       (order-b (or (any->number (configf:lookup views-cfgdat b "order")) 999)))
			   (> order-a order-b)))))
		result))
	     (tabs (apply iup:tabs
			  #:tabchangepos-cb (lambda (obj curr prev)

(define (dboard:setup-num-rows tabdat)
  (dboard:tabdat-num-tests-set! tabdat (string->number
					(or (args:get-arg "-rows")
					    (get-environment-variable "DASHBOARDROWS")
					    "15"))))
  
(define *tim* (iup:timer))
(define *ord* #f)
(iup:attribute-set! *tim* "TIME" (or (configf:lookup *configdat* "dashboard" "poll-interval") "1000"))
(iup:attribute-set! *tim* "RUN" "YES")

(define *last-recalc-ended-time* 0)

(define (dashboard:recalc modtime please-update-buttons last-db-update-time)
  (or please-update-buttons
      (and ;; (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) ;; can't use this - it needs to be tab specific
	   (> modtime (- last-db-update-time 3)) ;; add three seconds of margin
	   (> (current-seconds)(+ last-db-update-time 1)))))

;; (define *monitor-db-path* #f)
(define *last-monitor-update-time* 0)

;; Force creation of the db in case it isn't already there.
;; (tasks:open-db)

(define (dashboard:get-youngest-run-db-mod-time dbdir)
  (handle-exceptions
   exn
   (begin

	 (dbpth (if (< (length parts) 2) ;; assume then a filename was provided
		    dbstr
		    (if (equal? (car parts) "sqlite3")
			(cadr parts)
			(begin
			  (debug:print 0 *default-log-port* "ERROR: I only know sqlite3 databases for now: " dbstr)
			  #f)))))
    (if (and dbpth (file-read-access? dbpth))
    (if (and dbpth (file-readable? dbpth))
	(let ((db (sqlite3:open-database dbpth))) ;; (open-database dbpth)))
	  (sqlite3:set-busy-handler! db (make-busy-timeout 10000))
	  (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 10000))
	  db)
	#f)))

;; sqlite3:path tablename timefieldname varfieldname field1 field2 ...
;;
(define (dboard:graph-read-data cmdstring tstart tend)
  (let* ((parts (string-split cmdstring))) ;; spaces not allowed

       ))
   "dashboard:runs-tab-updater"))

;;======================================================================
;; The heavy lifting starts here
;;======================================================================

(define (main)
(define (dashboard-main)
  (let ((mtdb-path (conc *toppath* "/megatest.db"))) ;; 
    (if (and (common:file-exists? mtdb-path)
	     (file-write-access? mtdb-path))
    #;(if (and (common:file-exists? mtdb-path)
	     (file-writable? mtdb-path))
	(if (not (args:get-arg "-skip-version-check"))
            (common:exit-on-version-changed)))
    (let* ((commondat       (dboard:commondat-make)))
      ;; Move this stuff to db.scm? I'm not sure that is the right thing to do...
      (cond 
       ((args:get-arg "-test") ;; run-id,test-id
	(let* ((dat     (let ((d (map string->number (string-split (args:get-arg "-test") ",")))) 

      (let ((th1 (make-thread (lambda ()
				(thread-sleep! 1)
				(dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab 
				) "update buttons once"))
	    (th2 (make-thread iup:main-loop "Main loop")))
	(thread-start! th2)
	(thread-join! th2)))))

;; ease debugging by loading ~/.dashboardrc
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
  (if (common:file-exists? debugcontrolf)
      (load debugcontrolf)))
(define (get-debugcontrolf)
  (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
    (if (common:file-exists? debugcontrolf)
	debugcontrolf
	#f)))

(define (main)
(if (args:get-arg "-repl")
    (repl)
    (main))
  (if (args:get-arg "-repl")
      (repl)
      (dashboard-main)))

)

(import dashboard)

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

(main)

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

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

;;
;; -path-|-megatest.db
;;       |-db-|-main.db
;;            |-monitor.db
;;            |-sdb.db
;;            |-fdb.db
;;            |-1.db
;;            |-<N>.db
;;
;;
;; Accessors for a dbstruct
;;

;; (define-inline (dbr:dbstruct-main    vec)    (vector-ref  vec 0)) ;; ( db path )
;; (define-inline (dbr:dbstruct-strdb   vec)    (vector-ref  vec 1)) ;; ( db path )
;; (define-inline (dbr:dbstruct-path    vec)    (vector-ref  vec 2)) 
;; (define-inline (dbr:dbstruct-local   vec)    (vector-ref  vec 3))
;; (define-inline (dbr:dbstruct-rundb   vec)    (vector-ref  vec 4)) ;; ( db path )
;; (define-inline (dbr:dbstruct-inmem   vec)    (vector-ref  vec 5)) ;; ( db #f )
;; (define-inline (dbr:dbstruct-mtime   vec)    (vector-ref  vec 6))
;; (define-inline (dbr:dbstruct-rtime   vec)    (vector-ref  vec 7))
;; (define-inline (dbr:dbstruct-stime   vec)    (vector-ref  vec 8))
;; (define-inline (dbr:dbstruct-inuse   vec)    (vector-ref  vec 9))
;; (define-inline (dbr:dbstruct-refdb   vec)    (vector-ref  vec 10)) ;; ( db path )
;; (define-inline (dbr:dbstruct-locdbs  vec)    (vector-ref  vec 11))
;; (define-inline (dbr:dbstruct-olddb   vec)    (vector-ref  vec 12)) ;; ( db path )
;; ;; (define-inline (dbr:dbstruct-main-path vec)  (vector-ref  vec 13))
;; ;; (define-inline (dbr:dbstruct-rundb-path vec) (vector-ref  vec 14))
;; ;; (define-inline (dbr:dbstruct-run-id  vec)    (vector-ref  vec 13))
;; 
;; (define-inline (dbr:dbstruct-main-set!   vec val)(vector-set! vec 0 val))
;; (define-inline (dbr:dbstruct-strdb-set!  vec val)(vector-set! vec 1 val))
;; (define-inline (dbr:dbstruct-path-set!   vec val)(vector-set! vec 2 val))
;; (define-inline (dbr:dbstruct-local-set!  vec val)(vector-set! vec 3 val))
;; (define-inline (dbr:dbstruct-rundb-set!  vec val)(vector-set! vec 4 val))
;; (define-inline (dbr:dbstruct-inmem-set!  vec val)(vector-set! vec 5 val))
;; (define-inline (dbr:dbstruct-mtime-set!  vec val)(vector-set! vec 6 val))
;; (define-inline (dbr:dbstruct-rtime-set!  vec val)(vector-set! vec 7 val))
;; (define-inline (dbr:dbstruct-stime-set!  vec val)(vector-set! vec 8 val))
;; (define-inline (dbr:dbstruct-inuse-set!  vec val)(vector-set! vec 9 val))
;; (define-inline (dbr:dbstruct-refdb-set!  vec val)(vector-set! vec 10 val))
;; (define-inline (dbr:dbstruct-locdbs-set! vec val)(vector-set! vec 11 val))
;; (define-inline (dbr:dbstruct-olddb-set!  vec val)(vector-set! vec 12 val))
;; (define-inline (dbr:dbstruct-main-path-set! vec val)(vector-set! vec 13 val))
;; (define-inline (dbr:dbstruct-rundb-path-set! vec val)(vector-set! vec 14 val))
;; 
; (define-inline (dbr:dbstruct-run-id-set! vec val)(vector-set! vec 13 val))

;; constructor for dbstruct
;;
;; (define (make-dbr:dbstruct #!key (path #f)(local #f))
;;   (let ((v (make-vector 15 #f)))
;;     (dbr:dbstruct-path-set! v path)
;;     (dbr:dbstruct-local-set! v local)
;;     (dbr:dbstruct-locdbs-set! v (make-hash-table))
;;     v))


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

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

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

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

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

;; Test record utility functions

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

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

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

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

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

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

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

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


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

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

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