Megatest

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

NOTE: This file gets copied occasionally into the wiki as "Roadmap DONE".
      Do not make changes in the wiki, they will be lost!

DONE
====

WW14
. Streamline compilation - DONE, all non-official egg modules are now bundled.

WW15
. syscheck; touch file in home, tmp, runs, links and start xterm [DONE]

WW16
. archiving improvements/extentions [DONE]
.. -get-data, -put-data [DONE]
.. use MT_ vars if defined and no switch present [DONE]
.. fix archive "first run" bug [DONE]
.. areas path1 path2 ... -> search path for archives [NOT NEEDED - use -start-dir]
.. -propagate -> move archive data forward when it is found in older bundles [NOT NEEDED - simply repost the data]

# make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)'
# rm <files>.o ; make install CSCOPTS='-profile' ; ... ;  chicken-profile | less
SHELL=/bin/bash
PREFIX=$(PWD)
CSCOPTS=
INSTALL=install
SRCFILES = common.scm items.scm launch.scm ods.scm runconfig.scm	\

           server.scm configf.scm db.scm keys.scm margs.scm		\
           process.scm runs.scm tasks.scm tests.scm genexample.scm	\
           http-transport.scm filedb.scm tdb.scm client.scm mt.scm	\

           ezsteps.scm lock-queue.scm sdb.scm rmt.scm api.scm		\
           subrun.scm portlogger.scm archive.scm env.scm		\
           diff-report.scm cgisetup/models/pgdb.scm

# module source files
MSRCFILES = 
# ftail.scm rmtmod.scm commonmod.scm removed
# MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm	\
#             mtargs.scm commonmod.scm dbmod.scm adjutant.scm ulex.scm	\





#             rmtmod.scm apimod.scm

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

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

MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o))
# compiled import files
MOIMPFILES = $(MSRCFILES:%.scm=%.import.o)

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

# I'm not sure the cp is a good idea, changed a lot of things and it may not have been necessary...
# mofiles/%.o  %.import.scm : %.scm megatest-fossil-hash.scm
#	@[ -e mofiles ] || mkdir -p mofiles
#	csc $(CSCOPTS) -I mofiles -I $* -J -c $< -o $*.o
#	cp $*.o mofiles/$*.o
#	@touch $*.import.scm # ensure it is touched after the .o is made

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

ADTLSCR=mt_laststep mt_runstep mt_ezstep
HELPERS=$(addprefix $(PREFIX)/bin/,$(ADTLSCR))
DEPLOYHELPERS=$(addprefix deploytarg/,$(ADTLSCR))
MTESTHASH=$(shell fossil info|grep checkout:| awk '{print $$2}')

ifeq ($(MTESTHASH),)
$(error MTESTHASH is broken!)
endif

# CSIPATH=$(shell which csi)
# CKPATH=$(shell dirname $(shell dirname $(CSIPATH)))
# ARCHSTR=$(shell uname -m)_$(shell uname -r)
# 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)

# all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut ndboard
all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut tcmt

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

showmtesthash:
	@echo $(MTESTHASH)

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




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

# include makefile.inc

TCMTOBJS = \
	api.o \
	archive.o \
	cgisetup/models/pgdb.o \
	client.o \
	common.o \
	configf.o \
	db.o \
	env.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 \
	server.o \
	tasks.o \
	tdb.o \
	tests.o \
	subrun.o \
        ezsteps.o

#        mofiles/rmtmod.o \
#        mofiles/commonmod.o \

tcmt : $(TCMTOBJS) tcmt.scm megatest-version.scm
	csc $(CSCOPTS) $(TCMTOBJS) $(MOFILES) $(MOIMPFILES) tcmt.scm -o tcmt

# install documentation to $(PREFIX)/docs
# DOES NOT REBUILD DOCS
#
$(PREFIX)/share/docs/megatest_manual.html : docs/manual/megatest_manual.html
	mkdir -p $(PREFIX)/share/docs
	$(INSTALL) docs/manual/megatest_manual.html $(PREFIX)/share/docs/megatest_manual.html
	for png in $(PNGFILES);do $(INSTALL) docs/manual/$$png $(PREFIX)/share/docs/$$png;done

# add a fake dependency so this doens't copy everytime
$(PREFIX)/share/js/jquery-3.1.0.slim.min.js : # .fslckout
	mkdir -p $(PREFIX)/share/js
	fossil wiki export java-script-lib > $(PREFIX)/share/js/jquery-3.1.0.slim.min.js

$(PREFIX)/share/db/mt-pg.sql : mt-pg.sql
	mkdir -p $(PREFIX)/share/db
	$(INSTALL) mt-pg.sql $(PREFIX)/share/db/mt-pg.sql

# Special dependencies for the includes
$(MOFILE) $(MOIMPFILES) : megatest-fossil-hash.scm

# common.o : mofiles/commonmod.o megatest-fossil-hash.scm


# commonmod.o dashboard.o megatest.o tcmt.o apimod.o : megatest-fossil-hash.scm


tests.o db.o launch.o runs.o dashboard-tests.o				\
dashboard-context-menu.o dashboard-guimonitor.o dashboard-main.o	\
monitor.o dashboard.o archive.o megatest.o : db_records.scm megatest-fossil-hash.scm

tests.o runs.o dashboard.o dashboard-tests.o dashboard-context-menu.o dashboard-main.o  : run_records.scm

db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm

tests.o tasks.o dashboard-tasks.o : task_records.scm

runs.o : test_records.scm

megatest.o : megatest-fossil-hash.scm megatest-version.scm

rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm megatest-version.scm

common_records.scm : altdb.scm

# mofiles/stml2.o : mofiles/cookie.o
# configf.o : mofiles/commonmod.o

vg.o dashboard.o : vg_records.scm megatest-version.scm

dcommon.o : run_records.scm

mofiles/stml2.o : mofiles/cookie.o

# # special include based modules
# mofiles/pkts.o      : pkts/pkts.scm
# mofiles/stml2.o     : cookie.o
# # mofiles/mtargs.o    : mtargs/mtargs.scm
# # mofiles/mtconfigf.o : mtconfigf/mtconfigf.scm
# mofiles/ulex.o      : ulex/ulex.scm
# mofiles/mutils.o    : mutils/mutils.scm
# mofiles/cookie.o    : stml2/cookie.scm
# mofiles/stml2.o     : stml2/stml2.scm

# Temporary while transitioning to new routine
# runs.o : run-tests-queue-classic.scm  run-tests-queue-new.scm

# for the modularized stuff
mofiles/rmtmod.o : mofiles/commonmod.o

megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm

$(PREFIX)/bin/.$(ARCHSTR)/tcmt : tcmt
	$(INSTALL) tcmt $(PREFIX)/bin/.$(ARCHSTR)/tcmt

$(PREFIX)/bin/tcmt : $(PREFIX)/bin/.$(ARCHSTR)/tcmt utils/mk_wrapper
	utils/mk_wrapper $(PREFIX) tcmt $(PREFIX)/bin/tcmt
	chmod a+x $(PREFIX)/bin/tcmt












$(PREFIX)/bin/mt_laststep : utils/mt_laststep
	$(INSTALL) $< $@
	chmod a+x $@

$(PREFIX)/bin/mt_runstep : utils/mt_runstep
	$(INSTALL) $< $@
	chmod a+x $@

	$(INSTALL) $< $@
	chmod a+x $@

$(PREFIX)/bin/mtrunner : utils/mtrunner
	$(INSTALL) $< $@
	chmod a+x $@





deploytarg/nbfake : utils/nbfake
	$(INSTALL) $< $@
	chmod a+x $@

deploytarg/viewscreen : utils/viewscreen
	$(INSTALL) $< $@
	chmod a+x $@

	mkdir -p ext-tests
	cd ext-tests;fossil open --nested $(MTQA_FOSSIL)

$(MTQA_FOSSIL) :
	fossil clone https://www.kiatoa.com/fossils/megatest_qa $(MTQA_FOSSIL)

clean : 
	rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS)		\
            $(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil mtut	\
            tcmt readline-fix.scm serialize-env dboard *.o		\
            megatest-fossil-hash.* altdb.scm mofiles/*.o                \
            mofiles/*.o vg.o cookie.o dashboard-main.o	                \
            ducttape-lib.o ftail.o mutils.o pkts.o rmtmod.o stml2.o	\
            tcmt.o *.import.scm *.import.o
	rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS)		\
            $(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil mtut	\
            tcmt ftail.import.scm readline-fix.scm serialize-env	\
            dboard dboard.o megatest.o dashboard.o			\
            megatest-fossil-hash.* altdb.scm mofiles/*.o vg.o
	rm -rf share

#======================================================================
# Make the records files
#======================================================================

# vg_records.scm : records.sh
#	./records.sh

#======================================================================
# Deploy section (not complete yet)
#======================================================================

$(DEPLOYHELPERS) : utils/mt_*
	$(INSTALL) $< $@
	chmod a+X $@

deploytarg/apropos.so : Makefile
	chicken-install -p deploytarg -deploy -keep-installed $(EGGS)







deploy : deploytarg/mtest deploytarg/dboard $(DEPLOYHELPERS) deploytarg/nbfake deploytarg/remrun deploytarg/viewsceen deploytarg/nbfind deploytarg/apropos.so







# puts deployed megatest in directory "megatest"
deploytarg/mtest : $(OFILES) megatest.o deploytarg/apropos.so
	csc -deploy $(CSCOPTS) $(OFILES) megatest.scm -o deploytarg
	mv deploytarg/deploytarg deploytarg/mtest

deploytarg/dboard :  $(OFILES) $(GOFILES) dashboard.scm deploytarg/apropos.so
	csc -deploy $(OFILES) $(GOFILES) dashboard.scm -o deploytarg
	mv deploytarg/deploytarg deploytarg/dboard



datashare-testing/sd : datashare.scm $(OFILES)
	csc $(CSCOPTS) datashare.scm $(OFILES) -o datashare-testing/sd

datashare-testing/sdat: sharedat.scm $(OFILES)
	csc $(CSCOPTS) sharedat.scm $(OFILES) -o datashare-testing/sdat

sd : datashare-testing/sd
	mkdir -p /tmp/$(USER)/datashare/disk1 /tmp/$(USER)/basepath

xterm : sd
	(export BASEPATH=/tmp/$(USER)/basepath ; export PATH="$(PWD)/datashare-testing:$(PATH)" ; xterm &)

datashare-testing/spublish : spublish.scm $(OFILES) megatest-version.scm
	csc $(CSCOPTS) spublish.scm margs.o process.o common.o  -o datashare-testing/spublish

datashare-testing/sretrieve : sretrieve.scm $(OFILES) megatest-version.scm
	csc $(CSCOPTS) sretrieve.scm margs.o process.o common.o  -o datashare-testing/sretrieve


datashare-testing/sauthorize : sauthorize.scm $(OFILES) megatest-version.scm
	 csc $(CSCOPTS) sauthorize.scm margs.o process.o common.o  -o datashare-testing/sauthorize

sauth-init:
	mkdir -p  datashare-testing
	rm  datashare-testing/sauthorize
	rm  datashare-testing/sretrieve 
	rm  datashare-testing/spublish

sauth : sauth-init datashare-testing/sauthorize datashare-testing/sretrieve datashare-testing/spublish 








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

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

portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o 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 client.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

# create a pdf dot graphviz diagram from notations in rmt.scm
rmt.pdf : rmt.scm
	grep ';;DOT' rmt.scm | sed -e 's/.*;;DOT //' > rmt.dot;dot -Tpdf rmt.dot -o rmt.pdf

buildmanual:
	cd docs/manual && make

#  Copyright 2006-2020, 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/>.

TODO
====

WW15
. fill newview matrix with data, filter pipeline gui elements
. improve [script], especially indent handling

WW16
. split db into megatest.db (runs etc.) db/<something>.db
. release basic newview implementation

WW18
. release split db implementation
. mtutil calls from dashboard (for remote control)
. logs browser (esp. for surfacing mtutil related activities)

WW19
. break command line into sections; all, run control, queries, utilities etc.
. pull in ftfplan (not integrated, just code pulled in)

WW20
. ./configure => ubuntu, sles11, sles12, rh7
. Jenkins junit XML support
. Add output flushing in teamcity support
. Switch to using simple runs query everywhere
. Add end_time to runs and add a rollup call that sets state, status and end_time

Future
. Switch to scsh-process pipeline management for job execution/control
. Use call-with-environment-variables more.

Migration to inmem db plus per run db
-------------------------------------

. Re-work the dbstruct data structure?
.. Move main.db to global?
.. [ run-id.db inmemdb last-mod last-read last-sync inuse ]
. Re-work all queries to use run-id to dereference server
. Open main.db directly in calls to -runtests etc. No need to talk remote?
. remove common:faux-lock

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

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

(declare (unit adjutant))

(module adjutant *

(import scheme chicken data-structures extras files)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69
	md5 message-digest
	regex srfi-1)

(define (adjutant-run)
  (print "Running the adjutant!"))

)

    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-run-name-from-id
    get-runs
    simple-get-runs
    get-num-runs

    read-test-data*
    login
    tasks-get-last
    testmeta-get-record
    have-incompletes?
    ;; synchash-get
    get-changed-record-ids
    get-run-record-ids 
    get-not-completed-cnt))

(define api:write-queries
  '(
    get-keys-write ;; dummy "write" query to force server start

    ;; SERVERS
    start-server
    kill-server

    ;; TESTS
    test-set-state-status-by-id
    delete-test-records
    delete-old-deleted-test-records
    test-set-state-status
    test-set-top-process-pid
    set-state-status-and-roll-up-items
    
    update-pass-fail-counts
    top-test-set-per-pf-counts ;; (db:top-test-set-per-pf-counts (db:get-db *db* 5) 5 "runfirst")

    ;; RUNS
    register-run
    set-tests-state-status
    delete-run

    csv->test-data

    ;; MISC
    sync-inmem->db
    drop-all-triggers
    create-all-triggers
    update-tesdata-on-repilcate-db 

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

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

;; These are called by the server on recipt of /api calls
;;    - keep it simple, only return the actual result of the call, i.e. no meta info here
;;
;;    - returns #( flag result )
;;
(define (api:execute-requests dbstruct dat)
  (handle-exceptions
   exn
   (let ((call-chain (get-call-chain)))
     (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an exception from peer, dat=" dat ", exn=" exn)
     (print-call-chain (current-error-port))
     (debug:print 0 *default-log-port* " message: "  ((condition-property-accessor 'exn 'message) exn))       
     (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens
   (cond
    ((not (vector? dat))                    ;; it is an error to not receive a vector
     (vector #f (vector #f "remote must be called with a vector")))
    ((> *api-process-request-count* 20) ;; 20)

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

                   ;; 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
                   ((tasks-add)                 (apply tasks:add dbstruct params))   
                   ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params))
                   ((tasks-get-last)            (apply tasks:get-last dbstruct params))

		   ;; NO SYNC DB
		   ((no-sync-set)               (apply db:no-sync-set         *no-sync-db* params))
		   ((no-sync-get/default)       (apply db:no-sync-get/default *no-sync-db* params))
		   ((no-sync-del!)              (apply db:no-sync-del!        *no-sync-db* params))
		   ((no-sync-get-lock)          (apply db:no-sync-get-lock    *no-sync-db* params))
		   
                   ;; ARCHIVES
                   ;; ((archive-get-allocations)   
                   ((archive-register-disk)     (apply db:archive-register-disk dbstruct params))
                   ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params))
                   ;; ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey))

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

                   ((get-run-info)                 (apply db:get-run-info dbstruct params))
                   ((get-run-status)               (apply db:get-run-status dbstruct params))
                   ((get-run-state)                (apply db:get-run-state dbstruct params))
                   ((set-run-status)               (apply db:set-run-status dbstruct params))
                   ((set-run-state-status)  			 (apply db:set-run-state-status dbstruct params))
                   ((update-tesdata-on-repilcate-db) (apply db:update-tesdata-on-repilcate-db  dbstruct params)) 
                   ((get-tests-for-run)            (apply db:get-tests-for-run dbstruct params))
                   ((get-tests-for-run-state-status) (apply db:get-tests-for-run-state-status dbstruct params))
                   ((get-test-id)                  (apply db:get-test-id dbstruct params))
                   ((get-tests-for-run-mindata)    (apply db:get-tests-for-run-mindata dbstruct params))
                   ;; ((get-tests-for-runs-mindata)   (apply db:get-tests-for-runs-mindata dbstruct params))
                   ((get-runs)                     (apply db:get-runs dbstruct params))
                   ((simple-get-runs)              (apply db:simple-get-runs dbstruct params))
                   ((get-num-runs)                 (apply db:get-num-runs dbstruct params))
                   ((get-runs-cnt-by-patt)         (apply db:get-runs-cnt-by-patt dbstruct params))

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

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

(declare (unit apimod))
(declare (uses commonmod))
(declare (uses ulex))

(module apimod
	*
	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18)
(import commonmod)
(import (prefix ulex ulex:))


(define (api:execute-requests params)
  #f)

)

	(hash-table-ref blockid-cache key)
	(let* ((pscript     (configf:lookup *configdat* "archive" "pathscript"))
	       (pscript-cmd (conc pscript " " testsuite-name " " target " " run-name " " test-name))
	       (apath       (if pscript
				(handle-exceptions
				 exn
				 (begin
				   (debug:print 0 *default-log-port* "ERROR: script \"" pscript-cmd "\" failed to run properly. exn=" exn)
				   (exit 1))
				 (with-input-from-pipe
				  pscript-cmd
				  read-line))
				#f)) ;; this is the user-calculated archive path
	       (adisks    (archive:get-archive-disks))
	       (best-disk (common:get-disk-with-most-free-space adisks dneeded)))

		(rmt:test-set-archive-block-id run-id test-id archive-id)
		(if (member (symbol->string archive-command) '("save-remove"))
                    (begin 
                     (debug:print-info 0 *default-log-port* "remove testdat")
		    (runs:remove-test-directory test-dat 'archive-remove)))))
	    (hash-table-ref test-groups test-base)))))
       (hash-table-keys disk-groups))

    #t))

(define (archive:megatest-db target-patt run-patt)
 (let* ((blockid-cache  (make-hash-table))
        (tsname         (common:get-testsuite-name))
        (min-space      (string->number (or (configf:lookup *configdat* "archive" "minspace") "1000")))
        (bup-exe        (or (configf:lookup *configdat* "archive" "bup") "bup"))

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


#======================================================================
# Chicken build
#======================================================================

# CHICKEN_BIN_DIR=$(shell dirname $(shell which csi))
# if have csi on path use that, else use default
# CSIPATH=$(shell which csi)
# CKPATH=$(shell dirname $(shell dirname $(CSIPATH)))
sCHICKEN_PREFIX=$(or $(CKPATH),$(PREFIX)/bin/.$(ARCHSTR))

whatever :
	@echo "CHICKEN_PREFIX=$(CHICKEN_PREFIX)"

tgz-$(USER)/postgresql-9.6.4.tar.gz :
	mkdir -p tgz-$(USER)
	wget -c https://ftp.postgresql.org/pub/source/v9.6.4/postgresql-9.6.4.tar.gz
	mv postgresql-9.6.4.tar.gz tgz-$(USER)/

tgz-$(USER)/sqlite-autoconf-3090200.tar.gz :
	mkdir -p tgz-$(USER)
	curl http://www.sqlite.org/2015/sqlite-autoconf-3090200.tar.gz > tgz-$(USER)/sqlite-autoconf-3090200.tar.gz 

tgz-$(USER)/nanomsg-1.0.0.tar.gz :
	wget --no-check-certificate https://github.com/nanomsg/nanomsg/archive/1.0.0.tar.gz
	mv 1.0.0.tar.gz tgz-$(USER)/nanomsg-1.0.0.tar.gz	

tgz-$(USER)/chicken-4.13.0.tar.gz :
	mkdir -p tgz-$(USER)
	curl https://code.call-cc.org/releases/4.13.0/chicken-4.13.0.tar.gz > tgz-$(USER)/chicken-4.13.0.tar.gz

tgz-$(USER)/ffcall.tar.gz :
	wget -c -O tgz-$(USER)/ffcall.tar.gz 'http://www.kiatoa.com/fossils/ffcall/tarball?name=ffcall&uuid=trunk'

$(CHICKEN_PREFIX)/bin/pg_config : tgz-$(USER)/postgresql-9.6.4.tar.gz
	mkdir -p build-$(USER)/
	tar xfz tgz-$(USER)/postgresql-9.6.4.tar.gz -C build-$(USER)
	cd build-$(USER)/postgresql-9.6.4; ./configure --prefix=$(CHICKEN_PREFIX) --with-openssl; make; make install

build-$(USER)/sqlite-autoconf-3090200/configure : tgz-$(USER)/sqlite-autoconf-3090200.tar.gz
	mkdir -p build-$(USER);
	cd build-$(USER); tar xf ../tgz-$(USER)/sqlite-autoconf-3090200.tar.gz

$(CHICKEN_PREFIX)/lib/libnanomsg.so : tgz-$(USER)/nanomsg-1.0.0.tar.gz
	cd tgz-$(USER); tar -xzvf nanomsg-1.0.0.tar.gz
	cd tgz-$(USER)/nanomsg-1.0.0; mkdir build-$(USER); cd build-$(USER);
	cd tgz-$(USER)/nanomsg-1.0.0/build-$(USER); cmake ../ -DCMAKE_INSTALL_PREFIX=$(CHICKEN_PREFIX)
	cd tgz-$(USER)/nanomsg-1.0.0/build-$(USER); make; make install

$(CHICKEN_PREFIX)/chicken-4.13.0/LICENSE : tgz-$(USER)/chicken-4.13.0.tar.gz
	mkdir -p build-$(USER)/eggs-installed
	cd build-$(USER);tar xf ../tgz-$(USER)/chicken-4.13.0.tar.gz

tgz-$(USER)/opensrc.fossil :
	cd tgz-$(USER); fossil clone http://www.kiatoa.com/fossils/opensrc opensrc.fossil
	mkdir tgz-$(USER)/opensrc
	cd tgz-$(USER)/opensrc; fossil open --nested ../opensrc.fossil; fossil up; fossil uv sync

$(CHICKEN_PREFIX)/lib/libiupweb.so : tgz-$(USER)/opensrc.fossil
	cd tgz-$(USER)/opensrc; fossil unversioned cat libs/cd/cd-5.10_Linux26g4_64_lib.tar.gz > ../cd.tgz
	cd tgz-$(USER)/opensrc; fossil unversioned cat libs/im/im-3.11_Linux26g4_64_lib.tar.gz > ../im.tgz
	cd tgz-$(USER)/opensrc; fossil unversioned cat libs/iup/iup-3.19.1_Linux26g4_64_lib.tar.gz > ../iup.tgz
	cd tgz-$(USER); tar -xzf cd.tgz;
	cd tgz-$(USER); tar -xzf im.tgz;
	cd tgz-$(USER); tar -xzf iup.tgz;
	cp tgz-$(USER)/include/* $(CHICKEN_PREFIX)/include/
	cp tgz-$(USER)/*.so $(CHICKEN_PREFIX)/lib/
	cp tgz-$(USER)/*.a  $(CHICKEN_PREFIX)/lib/
	cp tgz-$(USER)/ftgl/lib/*/* $(CHICKEN_PREFIX)/lib/

EGGS=srfi-69 srfi-42 sqlite3 iup canvas-draw typed-records md5 regex-case base64 \
format dot-locking csv-xml z3 udp hostinfo directory-utils stack dbi crypt sha1 \
posix-extras pathname-expand csv call-with-environment-variables s11n spiffy \
uri-common intarweb http-client spiffy-request-vars spiffy-directory-listing \
ansi-escape-sequences test slice rfc3339 uuid-lib filepath srfi-19 sparse-vectors \
sql-de-lite fmt readline apropos json simple-exceptions rpc trace logpro refdb postgresql nanomsg
EGGSTARG=$(addsuffix .done,$(addprefix build-$(USER)/eggs-installed/,$(EGGS)))
EGGSTARG2=$(addsuffix .done, $(EGGS))

$(CHICKEN_PREFIX)/lib/libcallback.a : tgz-$(USER)/ffcall.tar.gz
	cd tgz-$(USER); tar -xzvf ffcall.tar.gz 
	cd tgz-$(USER)/ffcall; ./configure --prefix=$(CHICKEN_PREFIX) --enable-shared
	cd tgz-$(USER)/ffcall; make CC="gcc -fPIC"; make install	

$(CHICKEN_PREFIX)/bin/sqlite3 : build-$(USER)/sqlite-autoconf-3090200/configure 
	cd build-$(USER)/sqlite-autoconf-3090200; ./configure --prefix=$(CHICKEN_PREFIX); make; make install

$(CHICKEN_PREFIX)/bin/csi : $(CHICKEN_PREFIX)/bin/sqlite3 $(CHICKEN_PREFIX)/lib/libiupweb.so $(CHICKEN_PREFIX)/chicken-4.13.0/LICENSE
	cd build-$(USER)/chicken-4.13.0;make PLATFORM=linux PREFIX=$(CHICKEN_PREFIX) 
	cd build-$(USER)/chicken-4.13.0;make PLATFORM=linux PREFIX=$(CHICKEN_PREFIX) install

ALL_CKBIN=chicken chicken-bind chicken-bug chicken-dump			\
chicken-install chicken-profile chicken-sqlite3 chicken-status		\
chicken-uninstall csc csi feathers nanocat sqlite3 vacuumdb logpro	\
refdb

CKBIN_WRAPPERS=$(addprefix $(PREFIX)/bin/,$(ALL_CKBIN))

$(PREFIX)/bin/% : $(CHICKEN_PREFIX)/bin/% $(CHICKEN_PREFIX)/bin/csi $(EGGSTARG2)
	utils/mk_wrapper_tool $(PREFIX) $* $(PREFIX)/bin/$*
	chmod a+x $(PREFIX)/bin/$*

$(PREFIX)/bin :
	mkdir -p $(PREFIX)/bin $(CHICKEN_PREFIX)/bin

chicken : $(PREFIX)/bin $(CHICKEN_PREFIX)/bin/csi  binwrappers
	@echo "Fake target to build prefix chicken"

binwrappers : $(CKBIN_WRAPPERS)

postgresql.done : $(CHICKEN_PREFIX)/bin/pg_config
	CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib -L$(CHICKEN_PREFIX)/lib64" $(CHICKEN_PREFIX)/bin/chicken-install postgresql > postgresql.done

nanomsg.done : $(CHICKEN_PREFIX)/lib/libnanomsg.so
	CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib -L$(CHICKEN_PREFIX)/lib64" $(CHICKEN_PREFIX)/bin/chicken-install nanomsg > nanomsg.done

iup.done : $(CHICKEN_PREFIX)/lib/libcallback.a
	CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install -D no-library-checks -feature disable-iup-web -feature disable-iup-pplot -feature disable-iup-matrixex iup > iup.done

canvas-draw.done :
	CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install -D no-library-checks canvas-draw > canvas-draw.done

sqlite3.done :
	CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install sqlite3 > sqlite3.done

sql-de-lite.done :
	CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install sql-de-lite > sql-de-lite.done

dbi.done : postgresql.done sqlite3.done sql-de-lite.done
	CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install dbi > dbi.done

%.done :
	$(CHICKEN_PREFIX)/bin/chicken-install $* > $*.done

build-$(USER)/eggs-installed/%.done : $(CHICKEN_PREFIX)/bin/csi $(EGGS)
	$(CHICKEN_PREFIX)/bin/chicken-install $* > build-$(USER)/eggs-installed/$*.done

build-clean :
	rm -rf build-$(USER) bin

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

;; execute thunk, return value.  If exception thrown, trap exception, return #f, and emit nonfatal condition note to *default-log-port* .
;; arguments - thunk, message
(define (common:fail-safe thunk warning-message-on-exception)
  (handle-exceptions
   exn
   (begin
     (debug:print-info 0 *default-log-port* "notable but nonfatal condition - "warning-message-on-exception", exn=" exn)
     (debug:print-info 0 *default-log-port*
                       (string-substitute "\n?Error:" "nonfatal condition:"
                                          (with-output-to-string
                                            (lambda ()
                                              (print-error-message exn) ))))
     (debug:print-info 0 *default-log-port* "    -- continuing after nonfatal condition...")
     #f)
   (thunk)))

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

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

            (caddr argv))
           (else (car argv))))
         (fullpath (realpath this-script)))
    fullpath))
(define *common:this-exe-fullpath* (common:get-this-exe-fullpath))
(define *common:this-exe-dir*      (pathname-directory *common:this-exe-fullpath*))
(define *common:this-exe-name*     (pathname-strip-directory *common:this-exe-fullpath*))

;; when called from a wrapper I need sometimes to find the calling
;; wrapper, this is for dashboard to find the correct megatest.
;;
(define (common:find-local-megatest #!optional (progname "megatest"))
  (let ((res (filter file-exists?
		     (map (lambda (updir)
			    (let* ((lm  (car (argv)))
				   (dir (pathname-directory lm))
				   (exe (pathname-strip-directory lm)))
			      (conc (if dir (conc dir "/") "")
				    (case (string->symbol exe)
				      ((dboard)    (conc updir progname))
				      ((mtest)     (conc updir progname))
				      ((dashboard) progname)
				      (else exe)))))
			  '("../../" "../")))))
    (if (null? res)
	(begin
	  (debug:print 0 *current-log-port* "Failed to find this executable! Using what can be found on the path")
	  progname)
	(car res))))

(define *common:logpro-exit-code->status-sym-alist*
  '( ( 0 . pass )
     ( 1 . fail )
     ( 2 . warn )
     ( 3 . check )
     ( 4 . waived )

	(max-allowed (string->number (or (configf:lookup *configdat* "setup" "max-logfiles") "300")))) ;; name -> age
    (if (not (directory-exists? "logs"))(create-directory "logs"))
    (directory-fold 
     (lambda (file rem)
       (handle-exceptions
	exn
	(begin
	  (debug:print-info 2 *default-log-port* "unable to rotate log " file ", probably handled by another process, this is safe to ignore. exn=" exn)
	  (debug:print 2 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
	  ;; (print-call-chain (current-error-port)) ;; 
	  )
	(let* ((fullname  (conc "logs/" file))
	       (mod-time  (file-modification-time fullname))
	       (file-age  (- (current-seconds) mod-time))
	       (file-old  (> file-age (* 48 60 60)))

	    (for-each
	     (lambda (file)
	       (let* ((fullname (conc "logs/" file)))
		 (if (directory? fullname)
		     (debug:print-error 0 *default-log-port* fullname " in logs directory is a directory! Cannot rotate it, it is best to not put subdirectories in the logs dir.")
		     (handle-exceptions
		      exn
		      (debug:print-error 0 *default-log-port* "failed to remove " fullname ", exn=" exn)
		      (delete-file* fullname)))))
	     files)
	    (debug:print-info 0 *default-log-port* "Deleted " (length files) " files from logs, keeping " max-allowed " files."))))))
  
;; Force a megatest cleanup-db if version is changed and skip-version-check not specified
;; Do NOT check if not on homehost!
;;

             ((get-environment-variable "MT_SKIP_DB_MIGRATE") #t)
             ((and (common:file-exists? mtconf) (common:file-exists? dbfile) (not read-only)
                   (eq? (current-user-id)(file-owner mtconf))) ;; safe to run -cleanup-db
              (debug:print 0 *default-log-port* "   I see you are the owner of megatest.config, attempting to cleanup and reset to new version")
              (handle-exceptions
               exn
               (begin
                 (debug:print 0 *default-log-port* "Failed to switch versions. exn=" exn)
                 (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
                 (print-call-chain (current-error-port))
                 (exit 1))
               (common:cleanup-db dbstruct)))
             ((not (common:file-exists? mtconf))
              (debug:print 0 *default-log-port* "   megatest.config does not exist in this area.  Cannot proceed with megatest version migration.")
              (exit 1))

(define (common:read-encoded-string instr)
  (handle-exceptions
   exn
   (handle-exceptions
    exn
    (begin
      (debug:print-error 0 *default-log-port* "received bad encoded string \"" instr "\", message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
      (print-call-chain (current-error-port))
      #f)
    (read (open-input-string (base64:base64-decode instr))))
   (read (open-input-string (z3:decode-buffer (base64:base64-decode instr))))))

;; dot-locking egg seems not to work, using this for now
;; if lock is older than expire-time then remove it and try again

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

(define (common:get-testsuite-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")
      (pathname-file (or (if (string? *toppath* )
			     (pathname-file *toppath*)
			     #f)
			 (common:get-topath #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)

(define (common:get-db-tmp-area . junk)
  (if *db-cache-path*
      *db-cache-path*
      (if *toppath* ;; common:get-create-writeable-dir
	  (handle-exceptions
	      exn
	      (begin
		(debug:print-error 0 *default-log-port* "Couldn't create path to " *db-cache-path* ", exn=" exn)
		(exit 1))
	      (let* ((tsname (common:get-testsuite-name))
		     (dbpath (common:get-create-writeable-dir
			      (list (conc "/tmp/" (current-user-name)
					  "/megatest_localdb/"
					  tsname "/"
					  (string-translate *toppath* "/" "."))
				    (conc "/tmp/" (current-process-id) ;; just in case we have an issue with the dir by own user name
					  "/megatest_localdb/"
					  tsname
					  (string-translate *toppath* "/" "."))
				    ))))
		(set! *db-cache-path* dbpath)
		dbpath))
	  #f)))

(define (common:get-area-path-signature)
  (message-digest-string (md5-primitive) *toppath*))

(define (common:get-signature str)
  (message-digest-string (md5-primitive) str))

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

;; does the directory exist and do we have write access?
;;
;;    returns the directory or #f
;;
(define (common:directory-writable? path-string)
  (handle-exceptions
      exn
    (begin
      (debug:print 0 *default-log-port* "Failed to identify access to " path-string ", exn=" exn)
      #f)
   (if (and (directory-exists? path-string)
            (file-write-access? path-string))
       path-string
       #f)))

(define (common:get-linktree)
  (or (getenv "MT_LINKTREE")

	   ;; first look in config, then look in file .homehost, create it if not found
	   (homehost (or (configf:lookup *configdat* "server" "homehost" )
			 (handle-exceptions
			     exn
			     (if (> trynum 0)
				 (let ((delay-time (* (- 5 trynum) 5)))
				   (mutex-unlock! *homehost-mutex*)
				   (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Failed to read .homehost file, delaying "
						delay-time " seconds and trying again, message: "  ((condition-property-accessor 'exn 'message) exn)
						", exn=" exn)
				   (thread-sleep! delay-time)
				   (common:get-homehost trynum: (- trynum 1)))
				 (begin
				   (mutex-unlock! *homehost-mutex*)
				   (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)
						"] Failed to read .homehost file after trying five times. Giving up and exiting, message: "
						((condition-property-accessor 'exn 'message) exn))
				   (exit 1)))
			   (let ((hhf (conc *toppath* "/.homehost")))
			     (if (common:file-exists? hhf)
				 (with-input-from-file hhf read-line)
				 (if (file-write-access? *toppath*)
				     (begin
				       (with-output-to-file hhf

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

;; lazy-safe get file mod time. on any error (file not existing etc.) return 0
;;
(define (common:lazy-modification-time fpath)
  (handle-exceptions
      exn
    (begin
      (debug:print 0 *default-log-port* "Failed to get modifcation time for " fpath ", treating it as zero. exn=" exn)
      0)
    (if (file-exists? fpath)
	(file-modification-time fpath)
	0)))

;; find timestamp of newest file associated with a sqlite db file
(define (common:lazy-sqlite-db-modification-time fpath)
  (let* ((glob-list (handle-exceptions
			exn
		      (begin
			(debug:print 0 *default-log-port* "Failed to glob " fpath "*, exn=" exn)
			`(,(conc "/no/such/file, message: " ((condition-property-accessor 'exn 'message) exn))))
		      (glob (conc fpath "*"))))
         (file-list (if (eq? 0 (length glob-list))
			'("/no/such/file")
			glob-list)))
  (apply max
	 (map
	  common:lazy-modification-time 
	  file-list))))

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

(define (common:read-link-f path)
  (handle-exceptions
      exn
      (begin
	(debug:print-error 0 *default-log-port* "command \"/bin/readlink -f " path "\" failed. exn=" exn)
	path) ;; just give up
    (with-input-from-pipe
	(conc "/bin/readlink -f " path)
      (lambda ()
	(read-line)))))

(define (get-cpu-load #!key (remote-host #f))

;;
(define (common:get-cached-info key dtype #!key (age 10))
  (if *toppath*
      (let* ((fullpath (conc *toppath* "/.sysdata/" key "-" dtype ".log")))
	(if (and (file-exists? fullpath)
		 (file-read-access? fullpath))
	    (handle-exceptions
		exn
	      (begin
		(debug:print 0 *default-log-port* "failed to get cached info from " fullpath ", exn=" exn)
		#f)
	     (debug:print 2 *default-log-port* "reading file " fullpath)
	     (let ((real-age (- (current-seconds)(file-change-time fullpath)))) 
	       (if (< real-age age)
		   (handle-exceptions
		       exn
		     (begin
		       (debug:print-info 1 *default-log-port* " removing bad file " fullpath ", exn=" exn)
		       (delete-file* fullpath)
		       #f)
		     (with-input-from-file fullpath read))
		   (begin
		     (debug:print-info 2 *default-log-port* "file " fullpath " is too old (" real-age" seconds) to trust, skipping reading it")
		     #f))))
	    (begin
	      (debug:print 2 *default-log-port* "not reading file " fullpath)
	      #f)))
      #f))
 
(define (common:write-cached-info key dtype dat)
  (if *toppath*
      (let* ((fulldir  (conc *toppath* "/.sysdata"))
	     (fullpath (conc fulldir "/" key "-" dtype ".log")))
	(if (not (file-exists? fulldir))(create-directory fulldir #t))
	(handle-exceptions
	    exn
	  (begin
	    (debug:print 0 *default-log-path* "failed to write file " fullpath ", exn=" exn)
	    #f)
	  (with-output-to-file fullpath (lambda ()(pp dat)))))
      #f))

(define (common:raw-get-remote-host-load remote-host)
  (handle-exceptions
      exn
    (begin
      (debug:print 0 *default-log-port* "failed to ssh to " remote-host " and get loadavg. exn=" exn)
      #f) ;; more specific handling of errors needed
    (with-input-from-pipe 
     (conc "ssh " remote-host " cat /proc/loadavg")
     (lambda ()(list (read)(read)(read))))))

;; get cpu load by reading from /proc/loadavg, return all three values
;;
(define (common:get-cpu-load remote-host)
  (handle-exceptions
      exn
    (begin
      (debug:print 0 *default-log-port* "failed to ssh or read loadavg from host " remote-host ", exn=" exn)
      '(-99 -99 -99))
    (let* ((actual-hostname (or remote-host (get-host-name) "localhost")))
      (or (common:get-cached-info actual-hostname "cpu-load")
	  (let ((result (if remote-host
			    (map (lambda (res)
				   (if (eof-object? res) 9e99 res))
			         (with-input-from-pipe 
				  (conc "ssh " remote-host " cat /proc/loadavg")
				  (lambda ()(list (read)(read)(read)))))
			    (with-input-from-file "/proc/loadavg" 
			      (lambda ()(list (read)(read)(read)))))))
	    (match
		result
	      ((l1 l2 l3)
	       (if (and (number? l1)
		      (number? l2)
		      (number? l3))
		   (begin
		     (common:write-cached-info actual-hostname "cpu-load" result)
		     result)
		   '(-1 -1 -1))) ;; -1 is bad result
	      (else '(-2 -2 -2))))))))

;; get normalized cpu load by reading from /proc/loadavg and /proc/cpuinfo return all three values and the number of real cpus and the number of threads
;; returns alist '((adj-cpu-load . normalized-proc-load) ... etc.
;;  keys: adj-proc-load, adj-core-load, 1m-load, 5m-load, 15m-load
;;
(define (common:get-normalized-cpu-load remote-host)
  (let ((res (common:get-normalized-cpu-load-raw remote-host))

	  (thread-sleep! (random 60)) ;; we failed to get num cpus. wait a bit and try again
	  (if (> rem-tries 0)
	      (common:wait-for-normalized-load maxload msg remote-host (- rem-tries 1))
	      #f)))))

;; DO NOT CALL THIS DIRECTLY. It is called from common:wait-for-normalized-load
;;
(define (common:wait-for-cpuload maxload-in numcpus-in waitdelay #!key (count 1000) (msg #f)(remote-host #f)(force-maxload #f)(num-tries 5))
  (let* ((loadavg (common:get-cpu-load remote-host))
	 (numcpus (if (<= 1 numcpus-in) ;; not possible to have zero.  If we get 1, it's possible that we got the previous default, and we should check again
		      (common:get-num-cpus remote-host)
		      numcpus-in))
	 (maxload (if force-maxload
		      maxload-in
		      (if (number? maxload-in)
			  (max maxload-in 0.5)
			  0.5))) ;; so maxload must be greater than 0.5 for now BUG - FIXME?
	 (first   (car loadavg))
	 (next    (cadr loadavg))
	 (adjmaxload (* maxload (max 1 numcpus))) ;; possible bug where
					       ;; numcpus (or could be
					       ;; maxload) is zero,
					       ;; crude fallback is to
					       ;; at least use 1
	 (loadjmp (- first (if (> next (* numcpus 0.7)) ;; could do something with average of first and next?
			       0
			       next))) ;; we will force a conservative calculation any time next is large.
	 (first-next-avg    (/ (+ first next) 2))
	 ;; add some randomness to the time to break any alignment
	 ;; where netbatch dumps many jobs to machines simultaneously
         (adjwait           (min (+ 300 (random 10)) (abs (* (+ (random 10)
								(/ (- 1000 count) 10)
								waitdelay)
							     (- first adjmaxload) ))))
	 (load-jump-limit   (configf:lookup-number *configdat* "setup" "load-jump-limit")))
    ;; let's let the user know once in a long while that load checking
    ;; is happening but not constantly report it
    (if (common:low-noise-print 30 (conc "cpuload" (or remote-host "localhost"))) ;; (> (random 100) 75) ;; about 25% of the time
	(debug:print-info 1 *default-log-port* "Checking cpuload on " (or remote-host "localhost") ", maxload: " maxload
			  ", load: " first ", adjmaxload: " adjmaxload ", loadjmp: " loadjmp))
    (cond
     ((and (< first 0) ;; this indicates the loadavg data is bad - machine may not be reachable
	   (> num-tries 0))
      (debug:print 0 *default-log-port* "WARNING: received bad data from get-cpu-load " first ", we'll sleep 10s and try " num-tries " more times.")
      (thread-sleep! 10)
      (common:wait-for-cpuload maxload-in numcpus-in waitdelay
			       count: count remote-host: remote-host force-maxload: force-maxload num-tries: (- num-tries 1)))
     ((and (> first adjmaxload)
	   (> count 0))
      (debug:print-info 0 *default-log-port*
			"Delaying " adjwait
			" seconds due to load " first
			" exceeding max of " adjmaxload
			" on server " (or remote-host (get-host-name))
			" (normalized load-limit: " maxload ") " (if msg msg ""))
      (thread-sleep! adjwait)
      (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host))
     ((and (> loadjmp (cond
		       (load-jump-limit load-jump-limit)
		       ((> numcpus 8)(/ numcpus 2))
		       ((> numcpus 4)(/ numcpus 1.2))
		       (else 0.5)))
	   (> count 0))
      (debug:print-info 0 *default-log-port* "waiting " adjwait " seconds due to possible load jump " loadjmp ". "
			(if msg msg ""))
      (thread-sleep! adjwait)
      (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host))
     (else
      (if (> num-tries 0)
	  (if (common:low-noise-print 30 (conc (round first) "-load-acceptable-" (or remote-host "localhost")))
	      (debug:print 0 *default-log-port* "Load on " (or remote-host "localhost") " is acceptable at " first " continuing."))
	  (debug:print 0 *default-log-port* "Load on " (or remote-host "localhost") ", "first" could not be retrieved. Giving up and continuing."))))))

(define (get-uname . params)
  (let* ((uname-res (process:cmd-run->list (conc "uname " (if (null? params) "-a" (car params)))))
	 (uname #f))
    (if (null? (car uname-res))
	"unknown"
	(caar uname-res))))

	  (let ((pktsdir (or (hash-table-ref/default *pkts-info* 'pkts-dir #f)
			     (let* ((pktsdirs (common:get-pkts-dirs mtconf use-lt))
				    (pktsdir   (car pktsdirs))) ;; assume it is there
			       (hash-table-set! *pkts-info* 'pkts-dir pktsdir)
			       pktsdir))))
            (handle-exceptions
             exn
             (debug:print-info 0 "failed to write out packet to " pktsdir ", exn=" exn) ;; don't care if this failed for now but MUST FIX - BUG!!
             (if (not (file-exists? pktsdir))
                 (create-directory pktsdir #t))
             (with-output-to-file
                 (conc pktsdir "/" uuid ".pkt")
               (lambda ()
                 (print pkt)))))))))
	

(define (common:join-backgrounded-threads)
  ;; may need to trap and ignore exceptions -- dunno how atomic threads are...
  (for-each
   (lambda (thread-name)
     (let* ((thread (hash-table-ref/default *common:thread-punchlist* thread-name #f)))
       (if thread
           (handle-exceptions
               exn
	     (begin
	       (debug:print 0 *default-log-port* "joining threads failed. exn=" exn)
               #t) ;; just ignore it, it might have died in the meantime so joining it will throw an exception
             (thread-join! thread))
           )))
   (hash-table-keys *common:thread-punchlist*)))

(define *common:telemetry-log-state* 'startup)
(define *common:telemetry-log-socket* #f)

(define (common:telemetry-log-open)

    ((_ (name arg ...) body ...)
     (define-syntax name (syntax-rules () ((name arg ...) (begin body ...)))))))

;; (define-syntax common:handle-exceptions
;;   (syntax-rules ()
;;     ((_ exn-in errstmt ...)(handle-exceptions exn-in errstmt ...))))

;; this works, why didn't I use it more?
(define-syntax common:debug-handle-exceptions
  (syntax-rules ()
    ((_ debug exn errstmt body ...)
     (if debug
	 (begin body ...)
	 (handle-exceptions exn errstmt body ...)))))

    (not (null? (lset-intersection! eq? *verbosity* n))))
   ((and (number? *verbosity*)
	 (list? n))
    (member *verbosity* n))))

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

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

(declare (unit commonmod))

(module commonmod
	*
	
(import scheme chicken data-structures extras files)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69
	md5 message-digest
	regex srfi-1)

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

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

(define (get-full-version)
  (conc megatest-version "-" megatest-fossil-hash))

(define (version-signature)
  (conc megatest-version "-" (substring megatest-fossil-hash 0 4)))


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

(define (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)
		  #f))
	    ))
      #f))

;; returns var key1=val1; key2=val2 ... as alist
(define (get-key-list cfgdat section var)
  ;; convert string a=1; b=2; c=a silly thing; d=
  (let ((valstr (lookup cfgdat section var)))
    (if valstr
	(val->alist valstr)
	'()))) ;; should it return empty list or #f to indicate not set?


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

;;======================================================================
;; misc conversion, data manipulation functions
;;======================================================================

;; if it looks like a number -> convert it to a number, else return it
;;
(define (lazy-convert inval)
  (let* ((as-num (if (string? inval)(string->number inval) #f)))
    (or as-num inval)))

;; to '((a . 1)(b . 2)(c . "a silly thing")(d . ""))
;;
(define (val->alist val #!key (convert #f))
  (let ((val-list (string-split-fields ";\\s*" val #:infix)))
    (if val-list
	(map (lambda (x)
	       (let ((f (string-split-fields "\\s*=\\s*" x #:infix)))
		 (case (length f)
		   ((0) `(,#f))  ;; null string case
		   ((1) `(,(string->symbol (car f))))
		   ((2) `(,(string->symbol (car f)) .
			  ,(let ((inval (cadr f)))
			     (if convert (lazy-convert inval) inval))))
		   (else f))))
	     (filter (lambda (x)
		       (not (string-match "^\\s*" x)))
		     val-list))
	'())))

;;======================================================================
;; testsuite and area utilites
;;======================================================================

(define (get-testsuite-name toppath configdat)
  (or (lookup configdat "setup" "area-name")
      (lookup configdat "setup" "testsuite")
      (get-environment-variable "MT_TESTSUITE_NAME")
      (if (string? toppath)
          (pathname-file toppath)
          #f)))

(define (get-area-path-signature toppath #!optional (short #f))
  (let ((res (message-digest-string (md5-primitive) toppath)))
    (if short
	(substring res 0 4)
	res)))

(define (get-area-name configdat toppath #!optional (short #f))
  ;; look up my area name in areas table (future)
  ;; generate auto name
  (conc (get-area-path-signature toppath short)
	"-"
	(get-testsuite-name toppath configdat)))

;; need generic find-record-with-var-nmatching-val
;;
(define (path->area-record cfgdat path)
  (let* ((areadat (get-cfg-areas cfgdat))
	 (all     (filter (lambda (x)
			    (let* ((keyvals (cdr x))
				   (pth     (alist-ref 'path keyvals)))
			      (equal? path pth)))
			  areadat)))
    (if (null? all)
	#f
	(car all)))) ;; return first match

;; given a config return an alist of alists
;;   area-name => data
;;
(define (get-cfg-areas cfgdat)
  (let ((adat (get-section cfgdat "areas")))
    (map (lambda (entry)
	   `(,(car entry) . 
	     ,(val->alist (cadr entry))))
	 adat)))
	 
;; (define (debug:print . params) #f)
;; (define (debug:print-info . params) #f)
;; 
;; (define (set-functions dbgp dbgpinfo)
;;   (set! debug:print dbgp)
;;   (set! debug:print-info dbgpinfo))

(define (config:eval-string-in-environment str)
  ;; (if (or (string-null? str)
  ;;	  (equal? "!" (substring str 0 1))) ;; null string or starts with ! are preserved but NOT set in the environment
      str
      (handle-exceptions
       exn
       (begin
	 (debug:print-error 0 *default-log-port* "problem evaluating \"" str "\" in the shell environment, exn=" exn)
	 #f)
       (let ((cmdres (process:cmd-run->list (conc "echo " str))))
	 (if (null? cmdres) ""
	     (caar cmdres))))) ;; )

;;======================================================================
;; Make the regexp's needed globally available

				((runconfigs-get rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
				;; ((rget)           (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
				(else "(lambda (ht)(print \"ERROR\") \"ERROR\")"))))
		;; (print "fullcmd=" fullcmd)
		(handle-exceptions
		 exn
		 (begin
		   (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\", 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 fullcmd
		       (lambda ()

		       ;;	   (not (eq? allow-processing 'return-string)))
		       ((#t #f)
			(configf:process-line inl ht allow-processing))
		       ((return-string)
			inl)
		       (else
			(configf:process-line inl ht allow-processing)))))
	    (if (and (string? res)  ;; must set to "no" to force NOT trimming trailing spaces
		     (not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "yes") "no")))
		(string-substitute "\\s+$" "" res)
		res))))))

(define (configf:cfgdat->env-alist section cfgdat-ht allow-system)
  (filter
   (lambda (pair)
     (let* ((var (car pair))

                                          (full-conf     (if (and (absolute-pathname? include-file) (file-exists? include-file))
                                                             include-file
                                                             (common:nice-path 
                                                              (conc (if curr-conf-dir
                                                                        curr-conf-dir
                                                                        ".")
                                                                    "/" include-file)))))
				     (let ((all-matches (sort (handle-exceptions exn
								(begin
								 (debug:print '(2 9) *default-log-port* "glob of " full-conf " gave no match. , exn=" exn)
								 (list))
								(glob full-conf)) string<=?)))
				       (if (null? all-matches)
					   (begin
					     (debug:print '(2 9) #f "INFO: include file(s) matching " include-file " not found (called from " path ")")
					     (debug:print 2 *default-log-port* "        " full-conf))
					   (for-each
					    (lambda (fpath)
					      ;; (push-directory conf-dir)

       (hash-table-set! ht (car section)(cdr section)))
     adat)
    ht))

;; if 
(define (configf:read-alist fname)
  (handle-exceptions
      exn
    (begin
      (debug:print 0 *default-log-port* "read of alist " fname " failed. exn=" exn)
      #f)
    (configf:alist->config
     (with-input-from-file fname read))))

(define (configf:write-alist cdat fname)
  (if (not (common:faux-lock fname))
      (debug:print 0 *default-log-port* "INFO: Could not get lock on " fname))
  (let* ((dat  (configf:config->alist cdat))
         (res
          (begin
            (with-output-to-file fname ;; first write out the file
              (lambda ()
                (pp dat)))
            
            (if (common:file-exists? fname)   ;; now verify it is readable
                (if (configf:read-alist fname)
                    #t ;; data is good.
                    (begin
                      (handle-exceptions
			  exn
			(begin
			  (debug:print 0 *default-log-port* "deleting " fname " failed, exn=" exn)
			  #f)
			(debug:print 0 *default-log-port* "WARNING: content " dat " for cache " fname " is not readable. Deleting generated file.")
			(delete-file fname))
                      #f))
                #f))))
    (common:faux-unlock fname)
    res))
  
;; convert hierarchial list to ini format
;;

#!/bin/bash

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

# Configure the build

if [[ "$1"x == "x" ]];then
    PREFIX=$PWD
else
    PREFIX=$1
fi


#======================================================================
# Configure stuff needed for eggs
#======================================================================

function configure_dependencies () {

    #======================================================================
    # libnanomsg
    #======================================================================

    if [[ ! $(ls /usr/lib/*/libnanomsg*) ]];then
	echo "libnanomsg build needed."
	echo "BUILD_NANOMSG=yes" >> makefile.inc
    fi

    #======================================================================
    # postgresql libraries
    #======================================================================

    if [[ ! $(ls /usr/lib/*/libpq.*) ]];then
	echo "Postgresql build needed."
	echo "BUILD_POSTGRES=yes" >> makefile.inc
    fi

    if [[ ! $(ls /usr/lib/*/libsqlite3.*) ]];then
    echo "Sqlite3 build needed."
	echo "BUILD_SQLITE3=yes" >> makefile.inc
    fi

}

#======================================================================
# Initialize makefile.inc
#======================================================================

echo "" > makefile.inc

#======================================================================
# Do we need Chicken?
#======================================================================

if [[ -e /usr/bin/sw_vers ]]; then
    ARCHSTR=$(/usr/bin/sw_vers -productVersion)
else
    ARCHSTR=$(lsb_release -sr)
fi

echo "CHICKEN_PREFIX=$PREFIX/.$ARCHSTR" >> makefile.inc
CHICKEN_PREFIX=$PREFIX/bin/.$ARCHSTR

if [[ ! $(type csi) ]];then
    echo "Chicken build needed."
    echo "BUILD_CHICKEN=yes" >> makefile.inc
    configure_dependencies
    echo "include chicken.makefile" >> makefile.inc
else
    echo "CSIPATH=$(which csi)" >> makefile.inc
    CSIPATH=$(which csi)
    echo "CKPATH=$(dirname $(dirname $CSIPATH))" >> makefile.inc
fi

# Make setup scripts
echo "#!/bin/bash" > setup.sh
echo "export PATH=$CHICKEN_PREFIX/bin:\$PATH" >> setup.sh
echo "export LD_LIBRARY_PATH=$CHICKEN_PREFIX/lib" >> setup.sh
echo 'exec "$@"' >> setup.sh
chmod a+x setup.sh

echo "setenv PATH $CHICKEN_PREFIX/bin:\$PATH" > setup.csh
echo "setenv LD_LIBRARY_PATH $CHICKEN_PREFIX/lib" >> setup.csh

echo "All done creating makefile.inc, feel free to edit it!"
echo "run \"setup.sh bash\" or source setup.csh to get PATH and LD_LIBRARY_PATH adjusted"

;;======================================================================
;; Copyright 2019, 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/>.

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

(declare (unit cookie))

(include "stml2/cookie.scm")

(declare (uses subrun))

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


(define (dashboard:run-menu-items  run-id test-id target runname test-name testpatt item-test-path test-info)
  (list
   (iup:menu-item

                     (runs:get-mt-env-alist run-id run-name target test-name item-path)
                     
                     (lambda ()
                       (if scheme-match
                           (begin
                             (handle-exceptions
                              exn
                              (print "error with custom menu scheme, exn=" exn)
                              (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)))

			    "/"))
	       (item-path  (db:test-get-item-path testdat))
	       ;; this next block was added to fix a bug where variables were
               ;; needed. Revisit this.
	       (runconfig  (let ((runconfigf (conc  *toppath* "/runconfigs.config"))) ;; no rush but it would be good to convert this call to use runconfig:read
	 		     (if (common:file-exists? runconfigf)
	 			 (handle-exceptions
                                     exn
				   (begin
				     (debug:print 0 *default-log-port* "failed to set up environment for " runconfigf ", exn=" exn)
                                     #f)  ;; do nothing, just keep on trucking ....
                                   (setup-env-defaults runconfigf run-id (make-hash-table) keydat environ-patt: keystring))
	 			 (make-hash-table))))
	       (testconfig    (begin
				;; (runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path)
				(runs:set-megatest-env-vars run-id inkeyvals: keydat inrunname: runname intarget: keystring testname: testname itempath: item-path) ;; these may be needed by the launching process
				(handle-exceptions
				    exn  ;; NOTE: I've no idea why this was written this way. Research, study and fix needed!
				  (begin
				    (debug:print 0 *default-log-port* "testconfig load using " item-path " failed, trying " (db:test-get-item-path testdat) ", exn=" exn)
				    (tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f allow-write-cache: #f))
				  (tests:get-testconfig (db:test-get-testname testdat) item-path test-registry #t allow-write-cache: #f))))
	       (viewlog    (lambda (x)
			     (if (common:file-exists? logfile)
					;(system (conc "firefox " logfile "&"))
				 (dcommon:run-html-viewer logfile)
				 (message-window (conc "File " logfile " not found")))))
	       (view-a-log (lambda (lfile) 
			     (let ((lfilename (conc rundir "/" lfile)))

				    (need-update   (or (and (>= curr-mod-time db-mod-time)
							    (> (current-milliseconds)(+ last-update 250))) ;; every half seconds if db touched
						       (> (current-milliseconds)(+ last-update 10000))     ;; force update even 10 seconds
						       request-update))
				    (newtestdat (if need-update 
						    ;; NOTE: BUG HIDER, try to eliminate this exception handler
						    (handle-exceptions
							exn
						      (begin
							(debug:print-info 0 *default-log-port* "test db access issue in examine test for run-id " run-id
									  ", test-id " test-id ": " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
							#f)
						      (rmt:get-test-info-by-id run-id test-id)))))
			       ;; (print "INFO: need-update= " need-update " curr-mod-time = " curr-mod-time)
			       (cond
				((and need-update newtestdat)
				 (set! testdat newtestdat)
				 (set! teststeps    (augment-teststeps (tests:get-compressed-steps run-id test-id)))
				 (set! logfile      (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat)))
				 (set! rundir       ;; (filedb:get-path *fdb* 

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

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

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

			"-main"
			"-v"
			"-q"
			"-use-db-cache"
			"-skip-version-check"
			"-repl"
                        "-rh5.11" ;; fix to allow running on rh5.11
			"-:p"     ;; ignore the built in chicken profiling switch


			)
		 args:arg-hash
		 0))

;; check for MT_* environment variables and exit if found
(if (not (args:get-arg "-test"))
    (begin

  ((tests-by-name (make-hash-table)) : hash-table) ;; hash of testfullname => testdat
  key-vals
  ((last-update   0)                 : number)    ;; last query to db got records from before last-update
  ((last-db-time  0)                 : number)    ;; last timestamp on megatest.db
  ((data-changed  #f)                : boolean)   
  ((run-data-offset  0)              : number)      ;; get only 100 items per call, set back to zero when received less than 100 items
  (db-path #f))

;; for the new runs view lets build up a few new record types and then consolidate later
;;
;; this is a two level deep pipeline for the incoming data:
;;   sql query data ==> filters ==> data for display
;;
(defstruct dboard:rdat
  ;; view related items
  (runnum    0) ;; which column we are processing, index into runsbynum, we sweep across all these runs then start over
  (leftcol   0) ;; number of the leftmost visible column
  (toprow    0) ;; topmost visible row
  (numcols  24) ;; number of columns visible
  (numrows  20) ;; number of rows visible
  
  ;; 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

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

  ;; test sql filter
  (testname-sql-filt    "%")
  (itempath-sql-filt    "%")
  (test-state-sql-filt  "%")
  (test-status-sql-filt "%")

  ;; other sql related fields
  (last-updates (make-sparse-vector 0))  ;; run-id -> timestamp of the last update from sql db, set to zero on any field changes

  ;; filtered data
  (cols  (make-sparse-vector))   ;; columnnum => run-id
  (tests (make-hash-table))      ;; test[/itempath] => (vector columnnum => test rec)

  ;; various
  (prev-run-ids  '())            ;; push previously looked at runs on this
  (view-changed #f)

  ;; widgets
  (runs-tree #f)                 ;; 
  )

(define (dboard:rdat-push-run-id rdat run-id)
  (dboard:rdat-prev-run-ids-set! rdat (cons run-id (dboard:rdat-prev-run-ids rdat))))

(defstruct dboard:runrec
  id
  target  ;; a/b/c...
  tdef    ;; for future use
  )
     
(defstruct dboard:testrec
  id
  runid
  testname  ;; test[/itempath]
  state
  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:
                 (cons dboard:rundat?
                       (lambda (tabdat-item)
                         (filter

 ;;	 (dboard:tabdat-logs-textbox-set! tabdat logs-tb)
 ;;	 logs-tb))

;; browse runs as a tree. Used in both "Runs" tab and
;; in the runs control panel.
;;
(define (dboard:runs-tree-browser commondat tabdat)
  (let* ((txtbox (iup:textbox
		  #:action (lambda (val a b)
			     (debug:catch-and-dump
			      (lambda ()
				;; for the Runs view we put the list
				;; of keyvals into tabdat target for
				;; the Run Controls we put then update
				;; the run-command
				(if b (dboard:tabdat-target-set! tabdat
								 (string-split b "/")))
				(dashboard:update-run-command tabdat))
			      "command-testname-selector tb action"))
		  #:value (dboard:test-patt->lines
			   (dboard:tabdat-test-patts-use tabdat))
		  #:expand "HORIZONTAL"
		  ;; #:size "10x30"
		  ))
	 (tb
          (iup:treebox
           #:value 0
           #:title "Runs"     ;;  was #:name -- iup 3.19 changed
			      ;;  this... "Changed: [DEPRECATED
			      ;;  REMOVED] removed the old attribute
			      ;;  NAMEid from IupTree to avoid
			      ;;  conflict with the common attribute
			      ;;  NAME. Use the TITLEid attribute."
           #:expand "YES"
           #:addexpanded "YES"
           #:size "10x"
           #:selection-cb
           (lambda (obj id state)
             (debug:catch-and-dump
              (lambda ()
                (let* ((run-path (tree:node->path obj id))
                       (run-id    (tree-path->run-id tabdat (cdr run-path))))
                  ;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ??
                  ;; done below when run-id is a number
                  (dboard:tabdat-target-set! tabdat (cdr run-path)) ;; (print
								    ;; "run-path:
								    ;; "
								    ;; run-path)
		  (iup:attribute-set! txtbox "VALUE"
				      (string-intersperse (cdr run-path) "/"))
		  (dashboard:update-run-command tabdat)
                  (dboard:tabdat-layout-update-ok-set! tabdat #f)
                  (if (number? run-id)
                      (begin
                        ;; capture last two in tabdat.
                        (dboard:tabdat-prev-run-id-set!
                         tabdat
                         (dboard:tabdat-curr-run-id tabdat))
                        (dboard:tabdat-curr-run-id-set! tabdat run-id)
                        (dboard:tabdat-view-changed-set! tabdat #t))
                      (debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id))))
              "treebox"))
           ;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
           )))
    (dboard:tabdat-runs-tree-set! tabdat tb)
    (iup:detachbox
     (iup:vbox 
      txtbox
      tb
      ))))

;; browse runs as a tree. Used in both "Runs" tab and
;; in the runs control panel.
;;
;;  THIS IS THE NEW ONE
;;
(define (dboard:runs-tree-new-browser commondat rdat)
  (let* ((txtbox (iup:textbox
		  #:action (lambda (val a b)
			     (debug:catch-and-dump
			      (lambda ()
				;; for the Runs view we put the list
				;; of keyvals into tabdat target for
				;; the Run Controls we put then update
				;; the run-command
				(if b (dboard:rdat-targ-sql-filt-set! rdat
								 (string-split b "/")))
				#;(dashboard:update-run-command tabdat))
			      "command-testname-selector tb action"))
		  ;; #:value (dboard:test-patt->lines  ;; This seems like it was wrong, BUG in code where it was copied from?
	          ;;		   (dboard:tabdat-test-patts-use tabdat))
		  #:expand "HORIZONTAL"
		  ;; #:size "10x30"
		  ))
	 (tb
          (iup:treebox
           #:value 0
           #:title "Runs"     ;;  was #:name -- iup 3.19 changed
			      ;;  this... "Changed: [DEPRECATED
			      ;;  REMOVED] removed the old attribute
			      ;;  NAMEid from IupTree to avoid
			      ;;  conflict with the common attribute
			      ;;  NAME. Use the TITLEid attribute."
           #:expand "YES"
           #:addexpanded "YES"
           #:size "10x"
           #:selection-cb
           (lambda (obj id state)
             (debug:catch-and-dump
              (lambda ()
                (let* ((run-path (tree:node->path obj id))
                       (run-id    (new-tree-path->run-id rdat (cdr run-path))))
                  ;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ??
                  ;; done below when run-id is a number
                  (dboard:rdat-targ-sql-filt-set! rdat (cdr run-path)) ;; (print
								    ;; "run-path:
								    ;; "
								    ;; run-path)
		  (iup:attribute-set! txtbox "VALUE"
				      (string-intersperse (cdr run-path) "/"))
		  #;(dashboard:update-run-command tabdat)
                  #;(dboard:tabdat-layout-update-ok-set! tabdat #f)
                  (if (number? run-id)
                      (begin
                        ;; capture last two in tabdat.
                        (dboard:rdat-push-run-id rdat run-id)
			(dboard:rdat-view-changed-set! rdat #t))
                      (debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id))))
              "treebox"))
           ;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
           )))
    (dboard:rdat-runs-tree-set! rdat tb)
    (iup:detachbox
     (iup:vbox 
      txtbox
      tb
      ))))

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

;;
;; display and manage a single run at a time

(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)
      #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" "%/%")
;; 					     (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat))  ;; '()

	 (result-child #f))
    (if (and (common:file-exists? source)
	     (file-read-access? 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))
	 (load source))
	(begin
	  (debug:print 0 *default-log-port* "ERROR: cannot find file to load: \"" source "\" for user view " view-name)))
    ;; now run the user supplied definition for the tab view
    (if success
	(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 call procedure " viewgen
			", with; tab-num=" tab-num ", view-name=" view-name
			", and views-cfgdat and megatest configdat as parameters. To debug try loading in the repl: megatest -repl")
	   (set! success #f))
	 (print "Adding tab " view-name " with proc " viewgen)
	 ;; (iup:child-add! tabs
	 (set! result-child 
	       ((eval (string->symbol viewgen)) commondat tabs tab-num view-name views-cfgdat *configdat*))))
    ;; and finally set the updater
    (if success
	(dboard:commondat-add-updater commondat
				      (lambda ()
					(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 call procedure \"" updater
							"\", with; tabnum=" tab-num ", view-name=" view-name
							", and views-cfgdat and megatest configdat as parameters. To debug try loading in the repl: megatest -repl")
					   (set! success #f))
					 (debug:print 4 *default-log-port* "Running updater for tab " view-name " with proc " updater " and tab-num: " tab-num)
					 ((eval (string->symbol updater)) commondat tabs tab-num view-name views-cfgdat *configdat*)))
				      tab-num: tab-num))

				      (debug:print 6 *default-log-port* "(dboard:tabdat-start-run-offset tabdat) " (dboard:tabdat-start-run-offset tabdat) " maxruns: " maxruns ", val: " val " oldmax: " oldmax)
				      (iup:attribute-set! obj "MAX" (* maxruns 10))))
		#:expand "HORIZONTAL"
		#:max (* 10 (max (hash-table-size (dboard:tabdat-allruns-by-id tabdat)) 10))
		#:min 0
		#:step 0.01))

;; make-simple-run                   procedure (target3772 id3773 runname3774 state3775 status3776 owner3777 event_time3778)
;; rmt:simple-get-runs               procedure (runpatt1001 count1002 offset1003 target1004)
;; simple-run-event_time             procedure (x3834)
;; simple-run-event_time-set!        procedure (x3830 val3831)
;; simple-run-id                     procedure (x3794)
;; simple-run-id-set!                procedure (x3790 val3791)
;; simple-run-owner                  procedure (x3826)
;; simple-run-owner-set!             procedure (x3822 val3823)
;; simple-run-runname                procedure (x3802)
;; simple-run-runname-set!           procedure (x3798 val3799)
;; simple-run-state                  procedure (x3810)
;; simple-run-state-set!             procedure (x3806 val3807)
;; simple-run-status                 procedure (x3818)
;; simple-run-status-set!            procedure (x3814 val3815)
;; simple-run-target                 procedure (x3786)
;; simple-run-target-set!            procedure (x3782 val3783)
;; simple-run?                       procedure (x3780)


;;======================================================================
;; Extracting the data to display for runs
;;
;; This needs to be re-entrant such that it does one column per call
;; on the zeroeth call update runs data
;; on each subsequent call update one run (configurable - could do two, three ... or update until tdelta exceeded
;; on last run reset to zeroeth
;;
;;   1. select with run filters; area, target, runname, runstate, runstatus, starttime, duration
;;       - put this information into two data structures:
;;         a. hash of area/target/runname => runstruct #< ordernun, id, area, target, runname, state,
;;                                                        status, starttime, duration, non-deleted testcount>
;;            ordernum reflects order as received from sql query
;;         b. sparsevec of id => runstruct
;;   2. for each run in runshash ordered by ordernum do:
;;         retrieve data since last update for that run
;;         if there is a deleted test - retrieve full data
;;         if there are non-deleted tests register this run in the columns sparsevec
;;         if this is the zeroeth column regenerate the rows sparsevec
;;         if this column is in the visible zone update visible cells
;;
;; Other factors:
;;   1. left index handling:
;;       - add test/itempaths to left index as discovered, re-order and
;;         update row -> test/itempath mapping on each read run
;;======================================================================

;; runs is <vec header runs>
;;   get ALL runs info
;;   update rdat-targ-run-id
;;   update rdat-runs
;;
(define (dashboard:update-runs-data rdat)
  (let* ((tb               (dboard:rdat-runs-tree rdat))
	 (targ-sql-filt    (dboard:rdat-targ-sql-filt    rdat))
	 (runname-sql-filt (dboard:rdat-runname-sql-filt rdat))
	 (state-sql-filt   (dboard:rdat-run-state-sql-filt   rdat))
	 (status-sql-filt  (dboard:rdat-run-status-sql-filt  rdat))
	 ;; Use (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
	 (data             (rmt:simple-get-runs runname-sql-filt #f #f targ-sql-filt #f))
	 (numruns          (length data)))
    ;; store in the runsbynum vector
    (dboard:rdat-runsbynum-set! rdat (list->vector data))
    ;; update runs       id              => runrec
    ;; update targ-runid target/runname  => run-id
    (for-each
     (lambda (runrec)
       (let* ((run-id (simple-run-id runrec))
	      (full-targ-runname (conc (simple-run-target runrec) "/"
				       (simple-run-runname runrec))))
	 (debug:print 0 *default-log-port* "Update run  " run-id)
	 (sparse-vector-set! (dboard:rdat-runs rdat) run-id runrec)
	 (hash-table-set! (dboard:rdat-targ-runid rdat) full-targ-runname run-id)
	 ))
     data)
    numruns))

;; NOTE: runnum is NOT the run-id, it is a pointer into the runsbynum vector
;;
(define (dashboard:update-run-data runnum rdat)
  (let* ((curr-time            (current-seconds))
	 (runrec               (vector-ref (dboard:rdat-runsbynum rdat) runnum))
	 (run-id               (simple-run-id runrec))
	 (last-update          (sparse-vector-ref (dboard:rdat-last-updates rdat) run-id))
	 ;; filters
	 (testname-sql-filt    (dboard:rdat-testname-sql-filt    rdat))
	 ;; (itempath-sql-filt    (dboard:rdat-itempath-sql-filt    rdat))
	 (test-state-sql-filt  (dboard:rdat-test-state-sql-filt  rdat))  ;; not used yet
	 (test-status-sql-filt (dboard:rdat-test-status-sql-filt rdat))  ;; not used yet
	 (tests                (rmt:get-tests-for-run-state-status run-id
						      testname-sql-filt
						      last-update                ;; last-update
						      )))
    (sparse-vector-set! (dboard:rdat-last-updates rdat) run-id (- curr-time 1))
    (debug:print 0 *default-log-port* "Got " (length tests) " tests for run-id "
		 run-id " testname-sql-filt " testname-sql-filt " and last-update " last-update) 
    (length tests)))

(define (new-runs-updater commondat rdat)
  (let* ((runnum           (dboard:rdat-runnum          rdat))
	 (start-time       (current-milliseconds))
	 (tot-runs         #f))
    (if (eq? runnum 0)(dashboard:update-runs-data rdat))
    (set! tot-runs (vector-length (dboard:rdat-runsbynum rdat)))
    (let loop ((rn   runnum))
      (if (and (< (- (current-milliseconds) start-time) 250)
	       (< rn tot-runs))
	  (let* ((newrn (if (>= runnum (vector-length (dboard:rdat-runsbynum rdat)))
			    0 ;; start over
			    (+ rn 1)))) ;; (+ runnum 1)))
	    (dashboard:update-run-data rn rdat)
	    (dboard:rdat-runnum-set! rdat newrn)
	    (if (> newrn 0)
		(loop newrn)))))
    (if (>=  (dboard:rdat-runnum rdat) tot-runs)
	(dboard:rdat-runnum-set! rdat 0))
    ;; (dboard:rdat-runnum-set! rdat rn))) ;; not needed as it is set above
    ;; (dboard:rdat-last-update-set! rdat (- (current-seconds) 10))
    ;;    	 (tree:add-node tb "Runs" (string-split full-targ-runname "/"))
    '()))

(define (dboard:runs-new-matrix commondat rdat)
  (iup:matrix
   #:alignment1 "ALEFT"
   ;; #:expand "YES" ;; "HORIZONTAL"
   #:scrollbar "YES"
   #:numcol 10
   #:numlin 20
   #:numcol-visible 5 ;; (min 8)
   #:numlin-visible 1
   #:click-cb
   (lambda (obj row col status)
     (let* ((cell (conc row ":" col)))
       #f))
   ))
	 
(define (make-runs-view commondat rdat tab-num)
  ;; register an updater
  (dboard:commondat-add-updater
   commondat
   (lambda ()
     (new-runs-updater commondat rdat))
   tab-num: tab-num)

  (iup:vbox
   (iup:split
    #:orientation "VERTICAL" ;; "HORIZONTAL"
    #:value 100
    (dboard:runs-tree-new-browser commondat rdat)
    (dboard:runs-new-matrix commondat rdat)
    )))

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

	 (btn-height      (dboard:tabdat-runs-btn-height runs-dat))
	 (btn-fontsz      (dboard:tabdat-runs-btn-fontsz runs-dat))
	 (cell-width      (dboard:tabdat-runs-cell-width runs-dat)))
    ;; controls (along bottom)
    ;; (set! controls (dboard:make-controls commondat runs-dat))
    
    ;; create the left most column for the run key names and the test names 
    (set! lftlst
	  (list (iup:hbox
		 (iup:label) ;; (iup:valuator)
		 (apply iup:vbox 
			(map (lambda (x)		
			       (let ((res (iup:hbox
					   #:expand "HORIZONTAL"
					   (iup:label x
						      #:size (conc 40 btn-height)
						      #:fontsize btn-fontsz
						      #:expand "NO") ;; "HORIZONTAL")
					   (iup:textbox
					    #:size (conc 35 btn-height)
					    #:fontsize btn-fontsz
					    #:value "%"
					    #:expand "NO" ;; "HORIZONTAL"
					    #:action (lambda (obj unk val)
						       ;; each field
						       ;; (field name is "x" var) live updates
						       ;; the search filter as it is typed
						       (dboard:tabdat-target-set! runs-dat #f)
						       ;; ensure fields text boxes are used
						       ;; and not the info from the tree
						       (mark-for-update runs-dat)
						       (update-search commondat runs-dat x val))))))
				 (set! i (+ i 1))
				 res))
			     keynames)))))
    (let loop ((testnum  0)
	       (res      '()))
      (cond
       ((>= testnum ntests)
	;; now lftlst will be an hbox with the test keys and the test name labels
	(set! lftlst
	      (append
	       lftlst
	       (list
		(iup:hbox
		 #:expand "HORIZONTAL"
		 (iup:valuator
		  #:valuechanged_cb
		  (lambda (obj)
		    (let ((val (string->number (iup:attribute obj "VALUE")))
			  (oldmax  (string->number (iup:attribute obj "MAX")))
			  (newmax  (* 10 (length (dboard:tabdat-all-test-names runs-dat)))))
		      (dboard:commondat-please-update-set! commondat #t)
		      (dboard:tabdat-start-test-offset-set! runs-dat
							    (inexact->exact (round (/ val 10))))
		      (debug:print 6 *default-log-port*
				   "(dboard:tabdat-start-test-offset runs-dat) "
				   (dboard:tabdat-start-test-offset runs-dat) " val: " val
				   " newmax: " newmax " oldmax: " oldmax)
		      (if (< val 10)
			  (iup:attribute-set! obj "MAX" newmax))
		      ))
		  #:expand "VERTICAL" 
		  #:orientation "VERTICAL"
		  #:min 0
		  #:step 0.01)
		 (apply iup:vbox (reverse res)))))))
       (else
	(let ((labl  (iup:button
		      "" ;; the testname labels
		      #:flat "YES" 
		      #:alignment "ALEFT"
					; #:image img1
					; #:impress img2
		      #:size  (conc cell-width btn-height)
		      #:expand  "HORIZONTAL"
		      #:fontsize btn-fontsz
		      #:action (lambda (obj)
				 (mark-for-update runs-dat)
				 (toggle-hide testnum (dboard:commondat-uidat commondat)))))) 
	  (vector-set! lftcol testnum labl)
	  (loop (+ testnum 1)(cons labl res))))))
    ;; These are the headers for each row
    (let loop ((runnum  0)
	       (keynum  0)
	       (keyvec  (make-vector nkeys))
	       (res    '()))

		    (result  '()))
		(for-each
		 (lambda (view-name)
		   (debug:print 0 *default-log-port* "Adding view " view-name)
		   (let* ((cfgtype (configf:lookup views-cfgdat view-name "type"))) ;; what type of view?
		     (if (not (string? cfgtype))
			 (debug:print-info 0 *default-log-port* "WARNING: view \"" view-name
					   "\" is missing needed sections. "
					   "Please consult the documenation and update ~/.mtviews.config or "
					   *toppath* "/.mtviews.config")
			 (case (string->symbol cfgtype)
			   ;; 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)
		       (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)
					      (debug:catch-and-dump
					       (lambda ()
						 (let* ((tab-num (dboard:commondat-curr-tab-num commondat))
							(tabdat  (dboard:common-get-tabdat commondat tab-num: tab-num)))

						   (dboard:tabdat-layout-update-ok-set! tabdat #f))
						 (dboard:commondat-curr-tab-num-set! commondat curr)
						 (let* ((tab-num (dboard:commondat-curr-tab-num commondat))
							(tabdat  (dboard:common-get-tabdat commondat tab-num: tab-num)))

						   (dboard:commondat-please-update-set! commondat #t)
						   (dboard:tabdat-layout-update-ok-set! tabdat #t)))
					       "tabchangepos"))
			  (dashboard:summary commondat stats-dat tab-num: 0)
			  runs-view
			  ;; (make-runs-view commondat runs2-dat 2)
			  (dashboard:runs-summary commondat onerun-dat tab-num: 2)

			  (dashboard:run-controls commondat runcontrols-dat tab-num: 3)
			  (dashboard:run-times commondat runtimes-dat tab-num: 4)

			  additional-views)))
	;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
	(iup:attribute-set! tabs "TABTITLE0" "Summary")
	(iup:attribute-set! tabs "TABTITLE1" "Runs")
	;; (iup:attribute-set! tabs "TABTITLE2" "Runs2")
	(iup:attribute-set! tabs "TABTITLE2" "Run Summary")
	(iup:attribute-set! tabs "TABTITLE3" "Run Control")
	(iup:attribute-set! tabs "TABTITLE4" "Run Times")
	;; (iup:attribute-set! tabs "TABTITLE3" "New View")
	;; (iup:attribute-set! tabs "TABTITLE4" "Run Control")

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

	(iup:vbox
	 tabs
	 ;; controls

;; 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
     (debug:print 2 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: "
		  ((condition-property-accessor 'exn 'message) exn) " db-dir="dbdir ", exn=" exn)
     (current-seconds)) ;; something went wrong - just print an error and return current-seconds
   (common:max (map (lambda (filen)
		      (file-modification-time filen))
		    (glob (conc dbdir "/*.db*"))))))

(define (dashboard:monitor-changed? commondat tabdat)
  (let* ((run-update-time (current-seconds))

       fres))))

(define (dashboard:runs-tab-updater commondat tab-num)
  (debug:catch-and-dump 
   (lambda ()
     (let* ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))
	    (dbkeys (dboard:tabdat-dbkeys tabdat)))




       (dashboard:do-update-rundat tabdat)



       (let ((uidat (dboard:commondat-uidat commondat)))

	 (update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat)))
       ))
   "dashboard:runs-tab-updater"))

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

	(dboard:commondat-uidat-set! commondat (make-dashboard-buttons commondat))
	(dboard:commondat-curr-tab-num-set! commondat 0)
	(dboard:commondat-add-updater 
	 commondat 
	 (lambda ()
	   (dashboard:runs-tab-updater commondat 1))
	 tab-num: 1)
        ;; may not want this alive (manually merged it from v1.66)
	(dboard:commondat-add-updater 
	 commondat 
	 (lambda ()
	   (dashboard:runs-tab-updater commondat 1))
	 tab-num: 2)
	(iup:callback-set! *tim*
			   "ACTION_CB"
			   (lambda (time-obj)
			     (let ((update-is-running #f))
			     (mutex-lock! (dboard:commondat-update-mutex commondat))
			     (set! update-is-running (dboard:commondat-updating commondat))
			     (if (not update-is-running)

(declare (uses mt))

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


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

;;======================================================================
;;  R E C O R D S
;;======================================================================

  (handle-exceptions
   exn
   (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
     ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn)
     (if (eq? err-status 'done)
	 default
	 (begin
	   (debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
	   (print-call-chain (current-error-port))
	   default)))
   (apply sqlite3:first-result db stmt params)))

;; Get/open a database
;;    if run-id => get run specific db
;;    if #f     => get main db

      dbdat))

(define (db:dbdat-get-path dbdat)
  (if (pair? dbdat)
      (cdr dbdat)
      #f))






(define-inline (db:generic-error-printout exn . message)




  (print-call-chain (current-error-port))


  (apply debug:print-error 0 *default-log-port* message)
  (debug:print-error 0 *default-log-port* "   params: " params
		     ", error: "     ((condition-property-accessor 'exn 'message)   exn)
		     ", arguments: " ((condition-property-accessor 'exn 'arguments) exn)
		     ", location: "  ((condition-property-accessor 'exn 'location)  exn)
		     ))

;; (db:with-db dbstruct run-id sqlite3:exec "select blah fgrom blaz;")
;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no
;;
(define (db:with-db dbstruct run-id r/w proc . params)
  (let* ((have-struct (dbr:dbstruct? dbstruct))
         (dbdat     (if have-struct 
			(db:get-db dbstruct)
			#f))
	 (db        (if have-struct
			(db:dbdat-get-db dbdat)
			dbstruct))
	 (fname     (db:dbdat-get-path dbdat))
	 (use-mutex (> *api-process-request-count* 25))) ;; was 25
    (if (and use-mutex
	     (common:low-noise-print 120 "over-50-parallel-api-requests"))
	(debug:print-info 0 *default-log-port* *api-process-request-count* " parallel api requests being processed in process " (current-process-id) ", throttling access"))
    (if (common:low-noise-print 600 (conc "parallel-api-requests" *max-api-process-requests*))
	(debug:print-info 2 *default-log-port* "Parallel api request count: " *api-process-request-count* " max parallel requests: " *max-api-process-requests*))
    (condition-case

     (begin




       (if use-mutex (mutex-lock! *db-with-db-mutex*))
       (let ((res (apply proc db params)))
	 (if use-mutex (mutex-unlock! *db-with-db-mutex*))
	 ;; (if (vector? dbstruct)(db:done-with dbstruct run-id r/w))
	 (if dbdat (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat))
	 res))
     (exn (io-error)
	  (db:generic-error-printout exn "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again."))
     (exn (corrupt)
	  (db:generic-error-printout exn "ERROR: database " fname " is corrupt. Repair it to proceed."))
     (exn (busy)
	  (db:generic-error-printout exn "ERROR: database " fname
				     " is locked. Try copying to another location, remove original and copy back."))
     (exn (permission)(db:generic-error-printout exn "ERROR: database " fname " has some permissions problem."))
     (exn ()
	  (db:generic-error-printout exn "ERROR: Unknown error with database " fname " message: "
		       ((condition-property-accessor 'exn 'message) exn))))))
      
;;======================================================================
;; K E E P   F I L E D B   I N   dbstruct
;;======================================================================

;; (define (db:get-filedb dbstruct run-id)
;;   (let ((db (vector-ref dbstruct 2)))
;;     (if db

                (set! *db-write-access* #f)
                (dbr:dbstruct-read-only-set! dbstruct #t)))
          (dbr:dbstruct-mtdb-set!   dbstruct mtdb)
          (dbr:dbstruct-tmpdb-set!  dbstruct tmpdb)
          (dbr:dbstruct-dbstack-set! dbstruct (make-stack)) ;; BB: why a stack?  Why would the number of db's be indeterminate?  Is this a legacy of 1.db 2.db .. ?
          (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb) ;; olddb is already a (cons db path)
          (dbr:dbstruct-refndb-set! dbstruct refndb)

          (if (and  (or (not dbfexists)
			(and modtimedelta
			     (> modtimedelta max-stale-tmp))) ;; if db in tmp is over ten seconds older than the file in MTRA then do a sync back
		    do-sync)
	      (begin
		(debug:print 1 *default-log-port* "filling db " (db:dbdat-get-path tmpdb) " with data \n    from " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta)
		(db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb refndb tmpdb)

    (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb)))

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

;; close all opened run-id dbs
(define (db:close-all dbstruct)
  (if (dbr:dbstruct? dbstruct)
      (handle-exceptions
	  exn
	  (begin
	    (debug:print 0 *default-log-port* "WARNING: Finalizing failed, "  ((condition-property-accessor 'exn 'message) exn) ", note - exn=" exn)
	    (print-call-chain *default-log-port*))
	;; (db:sync-touched dbstruct 0 force-sync: #t) ;; NO. Do not do this here. Instead we rely on a server to be started when there are writes, even if the server itself is not going to be used as a server.
        (let ((tdbs       (map db:dbdat-get-db 
			       (stack->list (dbr:dbstruct-dbstack dbstruct))))
              (mdb        (db:dbdat-get-db (dbr:dbstruct-mtdb   dbstruct)))
              (rdb        (db:dbdat-get-db (dbr:dbstruct-refndb dbstruct)))
	      (stmt-cache (dbr:dbstruct-stmt-cache dbstruct)))
          (map (lambda (db)
		 (db:safely-close-sqlite3-db db stmt-cache))
	       tdbs)
          (db:safely-close-sqlite3-db mdb stmt-cache)     ;; (if (sqlite3:database? mdb) (sqlite3:finalize! mdb))
          (db:safely-close-sqlite3-db rdb stmt-cache))))) ;; (if (sqlite3:database? rdb) (sqlite3:finalize! rdb))))))

;;   (let ((locdbs (dbr:dbstruct-locdbs dbstruct)))
;;     (if (hash-table? locdbs)
;; 	(for-each (lambda (run-id)
;; 		    (db:close-run-db dbstruct run-id))
;; 		  (hash-table-keys locdbs)))))

     ;; 
     ;;  NOPE: apply this same approach to all db files
     ;;
     (else ;; ((equal? fname "megatest.db") ;; this file can be regenerated if needed
      (handle-exceptions
       exn
       (begin
	 (print "Problems trying to repair the db, exn=" exn)
	 ;; (db:move-and-recreate-db dbdat)
	 (if (> numtries 0)
	     (db:repair-db dbdat numtries: (- numtries 1))
	     #f)
	 (debug:print 0 *default-log-port* "FATAL: file " dbpath " was found corrupted, an attempt to fix has been made but you must start over.")
	 (debug:print 0 *default-log-port*
		      "   check the following:\n"

     (let ((stmts       (make-hash-table)) ;; table-field => stmt
	   (all-stmts   '())              ;; ( ( stmt1 value1 ) ( stml2 value2 ))
	   (numrecs     (make-hash-table))
	   (start-time  (current-milliseconds))
	   (tot-count   0))
       (for-each ;; table
	(lambda (tabledat)

	  (let* ((tablename        (car tabledat))
		 (fields           (cdr tabledat))
		 (has-last-update  (member "last_update" fields))
		 (use-last-update  (cond
				    ((and has-last-update
					  (member "last_update" fields))
				     #t) ;; if given a number, just use it for all fields

              (thread-sleep! delay-handicap)
              (debug:print-info 0 *default-log-port* "synthetic sync delay of "delay-handicap" seconds completed")
              )
            
	    ;; first pass implementation, just insert all changed rows
	    (for-each 
	     (lambda (targdb)

	       (let* ((db     (db:dbdat-get-db targdb))
                      (drp-trigger (if (member "last_update" field-names)
                                      (db:drop-trigger db tablename) 
                                       #f))
                       (is-trigger-dropped (if (member "last_update" field-names)
                                              (db:is-trigger-dropped db tablename) #f)) 
		      (stmth  (sqlite3:prepare db full-ins)))
		 ;; (db:delay-if-busy targdb) ;; NO WAITING
                 (if (member "last_update" field-names)
                     (debug:print-info 3 *default-log-port* "is-trigger-dropped: " is-trigger-dropped)) 
		 (for-each
		  (lambda (fromdat-lst)
		    (sqlite3:with-transaction
		     db
		     (lambda ()
		       (for-each ;; 
			(lambda (fromrow)

          ;; /tmp/bjbarcla/megatest_localdb/fullrun/.nfs.pdx.disks.icf_env_disk001.bjbarcla.gwa.issues.mtdev.matt-bisect.megatest.ext-tests.runs.all.v1.65.1.6524.dev.bb-24-justrollup-f8.rollup.fullrun/megatest.db.lock
          (delete-file* (common:get-sync-lock-filepath))
          )
	 
	 ;; clear out junk records
	 ;;
	 ((dejunk)
	  ;; (db:delay-if-busy mtdb) ;; ok to delay on mtdb
	  (when (file-write-access? (db:dbdat-get-path mtdb)) (db:clean-up mtdb))
	  (db:clean-up tmpdb)
	  (db:clean-up refndb))

	 ;; sync runs, test_meta etc.
	 ;;
	 ((old2new)

	;; archive disk areas, cached info from [archive-disks]
	(sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_disks (
                                id INTEGER PRIMARY KEY,
                                archive_area_name TEXT,
                                disk_path TEXT,
                                last_df INTEGER DEFAULT -1,
                                last_df_time TIMESTAMP DEFAULT (strftime('%s','now')),
                                creation_time TIMESTAMP DEFAULT (strftime('%s','now')));")
	;; individual bup (or tar) data chunks
	(sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_blocks (
                                id INTEGER PRIMARY KEY,
                                archive_disk_id INTEGER,
                                disk_path TEXT,
                                last_du INTEGER DEFAULT -1,
                                last_du_time TIMESTAMP DEFAULT (strftime('%s','now')),
                                creation_time TIMESTAMP DEFAULT (strftime('%s','now')));")
	;; tests allocated to what chunks. reusing a chunk for a test/item_path is very efficient
	;; NB// the per run/test recording of where the archive is stored is done in the test
	;;      record. 
	(sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_allocations (
                                id INTEGER PRIMARY KEY,
                                archive_block_id INTEGER,
                                testname TEXT,
                                item_path TEXT,
                                creation_time TIMESTAMP DEFAULT (strftime('%s','now')));")
	;; move this clean up call somewhere else
	(sqlite3:execute db "DELETE FROM tasks_queue WHERE state='done' AND creation_time < ?;" (- (current-seconds)(* 24 60 60))) ;; remove older than 24 hrs
	(sqlite3:execute db (conc "CREATE INDEX IF NOT EXISTS runs_index ON runs (runname" (if havekeys "," "") keystr ");"))
	;; (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;")
	(sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);")
	(sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT,
                                  CONSTRAINT metadat_constraint UNIQUE (var));")

         )
    (debug:print-info 4  *default-log-port* "running-deadtime = " running-deadtime)
    (debug:print-info 4  *default-log-port* "deadtime-trim = " deadtime-trim)

    (db:with-db 
     dbstruct #f #f
     (lambda (db)
       (let* ((stmth1 (db:get-cache-stmth
		       dbstruct db
		       "SELECT id,rundir,uname,testname,item_path,event_time,run_duration FROM tests 
                           WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?)
                                          AND state IN ('RUNNING');"))
	      (stmth2 (db:get-cache-stmth
		       dbstruct db
		       "SELECT id,rundir,uname,testname,item_path,event_time,run_duration FROM tests 
                           WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?)
                                          AND state IN ('REMOTEHOSTSTART');"))
	      (stmth3 (db:get-cache-stmth
		       dbstruct db
		       "SELECT id,rundir,uname,testname,item_path FROM tests
                           WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400
                                          AND state IN ('LAUNCHED');")))
	 ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes
	 ;;
	 ;; HOWEVER: this code in run:test seems to work fine
	 ;;              (> (- (current-seconds)(+ (db:test-get-event_time testdat)
	 ;;                     (db:test-get-run_duration testdat)))
	 ;;                    600) 
	 ;; (db:delay-if-busy dbdat)
	 (sqlite3:for-each-row 
	  (lambda (test-id run-dir uname testname item-path event-time run-duration)
	    (if (and (equal? uname "n/a")
		     (equal? item-path "")) ;; this is a toplevel test
		;; what to do with toplevel? call rollup?
		(begin
		  (set! toplevels   (cons (list test-id run-dir uname testname item-path run-id) toplevels))
		  (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id))
		(begin
		  (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted))
		  (debug:print-info 0 *default-log-port* "Found old test in RUNNING state, test-id="
				    test-id" exceeded running-deadtime "running-deadtime" now="(current-seconds)
				    " event-time="event-time" run-duration="run-duration))))
	  stmth1
	  run-id running-deadtime) ;; default time 720 seconds
       

	 (sqlite3:for-each-row 
	  (lambda (test-id run-dir uname testname item-path event-time run-duration)
	    (if (and (equal? uname "n/a")
		     (equal? item-path "")) ;; this is a toplevel test
		;; what to do with toplevel? call rollup?
		(begin
		  (set! toplevels   (cons (list test-id run-dir uname testname item-path run-id) toplevels))
		  (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id))
		(begin
		  (debug:print-info 0 *default-log-port* "Found old test in REMOTEHOSTSTART state, test-id=" test-id
				    " exceeded running-deadtime "running-deadtime" now="(current-seconds)" event-time="event-time
				    " run-duration="run-duration)
		  (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted)))))

	  stmth2
	  run-id remotehoststart-deadtime) ;; default time 230 seconds
	 
	 ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config
	 ;;
	 ;; (db:delay-if-busy dbdat)
	 (sqlite3:for-each-row
	  (lambda (test-id run-dir uname testname item-path)
	    (if (and (equal? uname "n/a")
		     (equal? item-path "")) ;; this is a toplevel test
		;; what to do with toplevel? call rollup?
		(set! toplevels   (cons (list test-id run-dir uname testname item-path run-id) toplevels))
		(begin
		  (debug:print-info 0 *default-log-port* "Found old test in LAUNCHED state, test-id=" test-id
				    " 1 day since event_time marked")
                (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched)))))


	  stmth3
	  run-id)
       
	 (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, "
			   (length toplevels) " old LAUNCHED toplevel tests and "
			   (length incompleted) " tests marked RUNNING but apparently dead."))

	 ;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE.
       ;;
	 ;; (db:delay-if-busy dbdat)







	 (let* ((min-incompleted-ids (map car incompleted)) ;; do 'em all
		(all-ids             (append min-incompleted-ids (map car oldlaunched))))
	   (if (> (length all-ids) 0)
	       (begin
		 ;; (launch:is-test-alive "localhost" 435)
		 (debug:print 0 *default-log-port* "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ")
			      " as DEAD")
		 (for-each
                  (lambda (test-id)
                    (let* (;; (run-dir (db:test-get-rundir-from-test-id dbstruct run-id test-id))
			   (tinfo   (db:get-test-info-by-id dbstruct run-id test-id))
			   (run-dir (db:test-get-rundir     tinfo))
			   (host    (db:test-get-host       tinfo))
			   (pid     (db:test-get-process_id tinfo))
			   (result (db:get-status-from-final-status-file run-dir)))
		      (if (and (list? result) (> (length result) 1) (equal? "PASS" (cadr result)) (equal? "COMPLETED" (car result))) 
			  (begin
			    (debug:print 0 *default-log-port* "INFO: test " test-id " actually passed, so marking PASS not DEAD")
			    (db:set-state-status-and-roll-up-items
			     dbstruct run-id test-id 'foo "COMPLETED" "PASS"
			     "Test stopped responding but it has PASSED; marking it PASS in the DB."))
			  (let ((is-alive (and (not (eq? pid 0))  ;; 0 is default in re-used field "attemptnum" where pid stored.
					       (launch:is-test-alive host pid))))
			    (if is-alive
				(debug:print 0 *default-log-port* "INFO: test " test-id " on host " host
					     " has a process on pid " pid ", NOT setting to DEAD.")
				(begin
				  (debug:print 0 *default-log-port* "INFO: test " test-id
					       " final state/status is not COMPLETED/PASS. It is " result)
				  (db:set-state-status-and-roll-up-items
				   dbstruct run-id test-id 'foo "COMPLETED" "DEAD"
				   "Test stopped responding while in RUNNING or REMOTEHOSTSTART; presumed dead.")))))))
		  ;; call end of eud of run detection for posthook - from merge, is it needed?
		  ;; (launch:end-of-run-check run-id)
		  all-ids)
		 ;;call end of eud of run detection for posthook
		 (launch:end-of-run-check run-id)
		 )))))))





















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

;; Clean out old junk and vacuum the database

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

(define (db:no-sync-close-db db stmtcache)
  (db:safely-close-sqlite3-db db stmtcache))

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

		       (lambda (key)
			 (set! res (cons key res)))
		       db
		       "SELECT fieldname FROM keys ORDER BY id DESC;")))
	(set! *db-keys* res)
	res)))

;; extract index number given a header/data structure
(define (db:get-index-by-header header field)
  (list-index (lambda (x)(equal? x field)) header))

;; look up values in a header/data structure
(define (db:get-value-by-header row header field)
  (if (or (null? header) (not row))
      #f
      (let loop ((hed (car header))
                 (tal (cdr header))
                 (n   0))
        (if (equal? hed field)
            (handle-exceptions
             exn
             (begin
               (debug:print 0 *default-log-port* "WARNING: attempt to read non-existant field, row=" row " header=" header " field=" field ", exn=" exn)
               #f)
             (vector-ref row n))
	    (if (null? tal) #f (loop (car tal)(cdr tal)(+ n 1)))))))

;; Accessors for the header/data structure
;; get rows and header from 
(define (db:get-header vec)(vector-ref vec 0))

(define-record simple-run target id runname state status owner event_time)
(define-record-printer (simple-run x out)
  (fprintf out "#,(simple-run ~S ~S ~S ~S)"
	   (simple-run-target x) (simple-run-id x) (simple-run-runname x) (time->string (seconds->local-time (simple-run-event_time x) ))))

;; simple get-runs
;;
(define (db:simple-get-runs dbstruct runpatt count offset target last-update)
    (let* ((res       '())
	   (keys       (db:get-keys dbstruct))
	   (runpattstr (db:patt->like "runname" runpatt))
	   (remfields  (list "id" "runname" "state" "status" "owner" "event_time"))
	   (targstr    (string-intersperse keys "||'/'||"))
	   (keystr     (conc targstr " AS target,"
			     (string-intersperse remfields ",")))
	   (qrystr     (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? "
			     ;; Generate: " AND x LIKE 'keypatt' ..."
			     " AND target LIKE '" target "'"
			     " AND state != 'deleted' "
			     (if (number? last-update)
				 (conc " AND last_update >= " last-update)
				 "")
			     " ORDER BY event_time DESC "
			     (if (number? count)
				 (conc " LIMIT " count)
				 "")
			     (if (number? offset)
				 (conc " OFFSET " offset)
				 "")))
	   )
    (debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " target: " target " offset: " offset " limit: " count)
    (db:with-db dbstruct #f #f
		(lambda (db)		
		  (sqlite3:for-each-row
		   (lambda (target id runname state status owner event_time)
		     (set! res (cons (make-simple-run target id runname state status owner event_time) res)))
		   db

						     (conc " ORDER BY " sort-by " ")
						     " ")))
				(if sort-order sort-order " ")
				(if limit  (conc " LIMIT " limit)   " ")
				(if offset (conc " OFFSET " offset) " ")
				";"
				)))

    (debug:print-info 8 *default-log-port* "db:get-tests-for-run run-id=" run-id ", qry=" qry)
    (let* ((res (db:with-db dbstruct run-id #f
			    (lambda (db)
			      ;; (let* ((stmth (db:get-cache-stmth dbstruct db qry))) ;; due to use of last-update we can't efficiently cache this query
				(reverse
				 (sqlite3:fold-row
				  (lambda (res . row)

	(sqlite3:fold-row
	 (lambda (res id testname item-path state status)
	   ;;  id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
	   (cons (vector id run-id testname state status -1         ""     -1      -1       ""    "-"  item-path -1           "-"         "-") res))
	 '()
	 stmth
	 run-id))))))

(define (db:get-tests-for-run-state-status dbstruct run-id testpatt #!optional (last-update 0))
  (let* ((res            '())
	 (tests-match-qry (tests:match->sqlqry testpatt))
	 (qry             (conc "SELECT id,testname,item_path,state,status,event_time,run_duration FROM tests WHERE run_id=? " 
				" AND last_update > ? "
				(if tests-match-qry (conc " AND (" tests-match-qry ") ") "")
				)))
    (debug:print-info 8 *default-log-port* "db:get-tests-for-run qry=" qry)
    (db:with-db dbstruct run-id #f
		(lambda (db)
		  (sqlite3:fold-row
		   (lambda (res id testname item-path state status event-time run-duration)
		     ;;            id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
		     (cons (vector id run-id testname state status event-time  ""     -1      -1       ""    "-"  item-path run-duration  "-"         "-") res))
		   '()
		   db 
		   qry
		   run-id
		   (or last-update 0))))))

(define (db:get-testinfo-state-status dbstruct run-id test-id)
  (let ((res            #f))
    (db:with-db dbstruct run-id #f
		(lambda (db)
		  (sqlite3:for-each-row
		   (lambda (run-id testname item-path state status)

  (db:with-db
   dbstruct #f #f
   (lambda (db)
     (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id))))

;; 
(define (db:delete-old-deleted-test-records dbstruct)
  (let ((targtime (- (current-seconds)
		     (or (configf:lookup-number *configdat* "setup" "keep-deleted-records")
			 (* 30 24 60 60))))) ;; one month in the past
    (db:with-db
     dbstruct
     0
     #t
     (lambda (db)
       (sqlite3:with-transaction
	db

     #f
     (lambda (db)
       (let* ((stmth (db:get-cache-stmth dbstruct db qry)))
	 (sqlite3:first-result stmth run-id))))))

;; For a given testname how many items are running? Used to determine
;; probability for regenerating html
;;
(define (db:get-count-tests-running-for-testname dbstruct run-id testname)
  (db:with-db
   dbstruct
   run-id
   #f
   (lambda (db)
     (let* ((stmt "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=? AND NOT (uname = 'n/a' AND item_path = '') AND testname=?;")

		 (newr  (if (and patt repl)
			    (begin
                              (handle-exceptions
                               exn
                               (begin
                                  (debug:print 0 *default-log-port*
                                  "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl ", exn=" exn)
                                 res)
                              (string-substitute patt repl res))


                              )
			    (begin
                              (debug:print 0 *default-log-port*

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

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

(declare (unit dbmod))

(module dbmod
	*
	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18)

(define (just-testing)
  (print "JUST TESTING"))

;; (define (debug:print . params) #f)
;; (define (debug:print-info . params) #f)
;; 
;; (define (set-functions dbgp dbgpinfo)
;;   (set! debug:print dbgp)
;;   (set! debug:print-info dbgpinfo))

)

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

(declare (unit dcommon))


(declare (uses gutils))
(declare (uses db))
;; (declare (uses synchash))

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

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

    (dboard:commondat-please-update-set! commondat #f)
    recalc))

(define (dashboard:get-youngest-run-db-mod-time dbdir)
  (handle-exceptions
   exn
   (begin
     (debug:print 2 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn)
		  " db-dir="dbdir ", exn=" exn)
     (current-seconds)) ;; something went wrong - just print an error and return current-seconds
   (common:max (map (lambda (filen)
		      (file-modification-time filen))
		    (glob (conc dbdir "/*.db*"))))))

(define (dboard:get-last-db-update tabdat context)
  (hash-table-ref/default (dboard:tabdat-last-db-update tabdat) context 0))

~~~~~~~~~~~~

Chicken scheme and a number of "eggs" are required for building
Megatest. See the script installall.sh in the utils directory of the
source distribution for an automated way to install everything
needed for building Megatest on Linux.

Megatest. In the v1.66 and beyond assistance to create the build
system is built into the Makefile.

.Installation steps (overview)
-------------------------------------
./configure
make chicken
setup.sh make -j install
-------------------------------------

Or install the needed build system manually:

. Chicken scheme from http://call-cc.org
. IUP from http://webserver2.tecgraf.puc-rio.br/iup/
. CD from http://webserver2.tecgraf.puc-rio.br/cd/
. IM from https://webserver2.tecgraf.puc-rio.br/im/
. ffcall from http://webserver2.tecgraf.puc-rio.br/iup/
. Nanomsg from https://nanomsg.org/ (NOTE: Plan is to eliminate nanomsg dependency).
. Needed eggs (look at the eggs lists in the Makefile)

Then follow these steps:

.Installation steps (self-built chicken scheme build system)
-------------------------------------
./configure
make -j install
-------------------------------------

</script>
</head>
<body class="book">
<div id="header">
<h1>The Megatest Users Manual</h1>
<span id="author">Matt Welland</span><br>
<span id="email" class="monospaced">&lt;<a href="mailto:matt@kiatoa.com">matt@kiatoa.com</a>&gt;</span><br>
<span id="revnumber">version 1.5,</span>
<span id="revdate">June 2020</span>
<div id="toc">
  <div id="toctitle">Table of Contents</div>
  <noscript><p><b>JavaScript must be enabled in your browser to display the table of contents.</b></p></noscript>
</div>
</div>
<div id="content">
<div class="sect1">
<h2 id="_preface">Preface</h2>
<div class="sectionbody">
<div class="paragraph"><p>This book is organised as three sub-books; getting started, writing tests and reference.</p></div>
<div class="listingblock">
<div class="title">License</div>
<div class="content monospaced">
<pre>    Copyright 2006-2020, Matthew Welland.

    This document 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.

<h2 id="_why_megatest">Why Megatest?</h2>
<div class="sectionbody">
<div class="paragraph"><p>The Megatest project was started for two reasons, the first was an
immediate and pressing need for a generalized tool to manage a suite
of regression tests and the second was the fact that I had written or
maintained several such tools at different companies over the years. I
thought a single open source tool, flexible enough to meet the needs
of any team doing continuous integration and or running a complex
suite of tests for release qualification would solve some problems for
me and for others.</p></div>
<div class="literalblock">
<div class="content monospaced">
<pre>-- Matt Welland, original author of the Megatest tool suite.</pre>
</div></div>
</div>

<div class="imageblock">
<div class="content">
<img src="megatest-system-architecture.png" alt="Static">
</div>
</div>
</div>
</div>
</div>
<div class="sect1">
<h2 id="_todo_road_map">TODO / Road Map</h2>
<div class="sectionbody">
<div class="paragraph"><p>Note: This road-map is a wish list and not a formal plan. Items are in
rough priority but are subject to change. Development is driven by
user requests, developer "itch" and bug reports. Please contact
<a href="mailto:matt@kiatoa.com">matt@kiatoa.com</a> with requests or bug reports. Requests from inside
Intel generally take priority.</p></div>
<div class="paragraph"><p>Dashboard and runs</p></div>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
Multi-area dashboard view
</p>
</li>
</ol></div>
<div class="paragraph"><p>Tests Support</p></div>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
Add variable $MT_RUNPATH = $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME
</p>
</li>
<li>
<p>
Improve [script], especially indent handling
</p>
</li>
</ol></div>
<div class="paragraph"><p>Scalability</p></div>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
Overflow database methodology - combine the best of the v1.63
  multi-db approach and the current db-in-tmp approach (currently
  slowness can be seen when number of tests in a db goes over 50-100k,
  with the overflow db it will be able to handle 1000&#8217;s of runs with
  50-100k tests per run). High priority - goal is to complete this by
  20Q3.
</p>
</li>
</ol></div>
<div class="paragraph"><p>Mtutils/CI</p></div>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
Enable mtutil calls from dashboard (for remote control)
</p>
</li>
<li>
<p>
Logs browser (esp. for surfacing mtutil related activities)
</p>
</li>
<li>
<p>
Embed ftfplan for distributed automation, completed activities trigger QA runs which trigger deployment etc.
</p>
</li>
<li>
<p>
Jenkins junit XML support [DONE]
</p>
</li>
<li>
<p>
Add output flushing in teamcity support
</p>
</li>
</ol></div>
<div class="paragraph"><p>Build system</p></div>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
./configure &#8658; ubuntu, sles11, sles12, rh7 [WIP]
</p>
</li>
<li>
<p>
Switch to using simple runs query everywhere
</p>
</li>
<li>
<p>
Add end_time to runs and add a rollup call that sets state, status and end_time
</p>
</li>
</ol></div>
<div class="paragraph"><p>Code refactoring/quality/performance</p></div>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
Switch to scsh-process pipeline management for job execution/control
</p>
</li>
<li>
<p>
Use call-with-environment-variables where possible.
</p>
</li>
</ol></div>
<div class="paragraph"><p>Migration to inmem db and or overflow db</p></div>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
Re-work the dbstruct data structure?
</p>
<div class="olist loweralpha"><ol class="loweralpha">
<li>
<p>
[ run-id.db inmemdb last-mod last-read last-sync inuse ]
</p>
</li>
</ol></div>
</li>
</ol></div>
<div class="paragraph"><p>Some ideas for Megatest 2.0</p></div>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
Aggressive megatest.config and runconfig.config caching.
</p>
<div class="olist loweralpha"><ol class="loweralpha">
<li>
<p>
Cache the configs in $MT_RUNPATH
</p>
</li>
<li>
<p>
Following invocations of –run, -rerun* will calculate the new config but only overwrite the cached file IF changed
</p>
</li>
</ol></div>
</li>
<li>
<p>
If the cached file changes ALL existing tests go from COMPLETED &#8594; STALE, I’m not sure what to do about RUNNING tests
</p>
</li>
<li>
<p>
!VARS in runconfigs are not exported to the environment. They are accessed via rget as if the ! was not there.
</p>
</li>
<li>
<p>
Per test copy commands (example is incomplete).
</p>
</li>
</ol></div>
<div class="listingblock">
<div class="content monospaced">
<pre>[testcopy]
%/iind% unison SRC DEST
% cp –r SRC DEST</pre>
</div></div>
<div class="paragraph"><p>Add ability to move runs to other Areas (overlaps with overflow db system)</p></div>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
allow shrinking megatest.db data by moving runs to an alternate
  Megatest area with same keys.
</p>
</li>
<li>
<p>
add param -destination [area|path]. when specified runs are copied to new
  area and removed from local db.
</p>
</li>
<li>
<p>
the data move would involve these steps
</p>
<div class="olist loweralpha"><ol class="loweralpha">
<li>
<p>
copy the run data to destination area megatest.db
</p>
</li>
<li>
<p>
mark the run records as deleted, do not remove the run data on disk
</p>
</li>
</ol></div>
</li>
<li>
<p>
accessing the data would be by running dashboard in the satellite area
</p>
</li>
<li>
<p>
future versions of Megatest dashboard should support displaying areas in a
  merged way.
</p>
</li>
<li>
<p>
some new controls would be supported in the config
</p>
<div class="olist loweralpha"><ol class="loweralpha">
<li>
<p>
[setup] &#8658; allow-runs [no|yes]  &#8656;= used to disallow runs
</p>
</li>
<li>
<p>
[setup] &#8658; auto-migrate=[areaname|path]  &#8656;= used to automatically
   migrate data to a satellite area.
</p>
</li>
</ol></div>
</li>
</ol></div>
<div class="paragraph"><p>Eliminate ties to homehost (part of overflow db system)</p></div>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
Server creates captain pkt
</p>
</li>
<li>
<p>
Create a lock in the db
</p>
</li>
<li>
<p>
Relinquish db when done
</p>
</li>
</ol></div>
<div class="paragraph"><p>Tasks - better management of run manager processes etc.</p></div>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
adjutant queries tasks table for next action <span class="red">[Migrate into mtutil]</span>
</p>
<div class="olist loweralpha"><ol class="loweralpha">
<li>
<p>
Task table used for tracking runner process <span class="red">[Replaced by mtutil]</span>
</p>
</li>
<li>
<p>
Task table used for jobs to run <span class="red">[Replaced by mtutil]</span>
</p>
</li>
<li>
<p>
Task table used for queueing runner actions (remove runs,
   cleanRunExecute, etc)  <span class="red">[Replaced by mtutil</span>]
</p>
</li>
</ol></div>
</li>
<li>
<p>
adjutant (server/task dispatch/execution manager)
</p>
</li>
</ol></div>
<div class="paragraph"><p>Stale propagation</p></div>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
Mark dependent tests for clean/rerun -rerun-downstream
</p>
</li>
<li>
<p>
On run start check for defunct tests in RUNNING, LAUNCHED or REMOTEHOSTSTART and correct or notify
</p>
</li>
<li>
<p>
Fix: refresh of gui sometimes fails on last item (race condition?)
</p>
</li>
</ol></div>
<div class="paragraph"><p>Bin list</p></div>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
Rerun step and or subsequent steps from gui [DONE?]
</p>
</li>
<li>
<p>
Refresh test area files from gui
</p>
</li>
<li>
<p>
Clean and re-run button
</p>
</li>
<li>
<p>
Clean up STATE and STATUS handling.
</p>
<div class="olist loweralpha"><ol class="loweralpha">
<li>
<p>
Dashboard and Test control panel are reverse order - choose and fix
</p>
</li>
<li>
<p>
Move seldom used states and status to drop down selector
</p>
</li>
</ol></div>
</li>
<li>
<p>
Access test control panel when clicking on Run Summary tests
</p>
</li>
<li>
<p>
Feature: -generate-index-tree
</p>
</li>
<li>
<p>
Change specifing of state and status to use STATE1/STATUS1,STATE2/STATUS2
</p>
</li>
<li>
<p>
rest api available for use with Perl, Ruby etc. scripts
</p>
</li>
<li>
<p>
megatest.config setup entries for:
</p>
<div class="olist loweralpha"><ol class="loweralpha">
<li>
<p>
run launching (e.g. /bin/sh %CMD% &gt; /dev/null)
</p>
</li>
<li>
<p>
browser "konqueror %FNAME%
</p>
</li>
</ol></div>
</li>
<li>
<p>
refdb: Add export of csv, json and sexp
</p>
</li>
<li>
<p>
Convert to using call-with-environment-variables where possible. Should allow handling of parallel runs in same process.
</p>
</li>
<li>
<p>
Re-work text interface wizards. Several bugs on record. Possibly convert to gui based.
</p>
</li>
<li>
<p>
Add to testconfig requirements section; launchlimiter scriptname, calls scriptname to check if ok to launch test
</p>
</li>
<li>
<p>
Refactor Run Summary view, currently very clumsy
</p>
</li>
<li>
<p>
Add option to show steps in Run Summary view
</p>
</li>
<li>
<p>
Refactor guis for resizeablity
</p>
</li>
<li>
<p>
Add filters to Run Summary view and Run Control view
</p>
</li>
<li>
<p>
Add to megatest.config or testconfig; rerunok STATE/STATUS,STATE/STATUS&#8230;
</p>
</li>
<li>
<p>
Launch gates for diskspace; /path/one&gt;1G,/path/two&gt;200M,/tmp&gt;5G,#{scheme <strong>toppath</strong>}&gt;1G
</p>
</li>
<li>
<p>
Tool tips
</p>
</li>
<li>
<p>
Filters on Run Summary, Summary and Run Control panel
</p>
</li>
<li>
<p>
Built in log viewer (partially implemented)
</p>
</li>
<li>
<p>
Refactor the test control panel
   Help and documentation
</p>
</li>
<li>
<p>
Complete the user manual (I’ve been working on this lately).
</p>
</li>
<li>
<p>
Online help in the gui
   Streamlined install
</p>
</li>
<li>
<p>
Deployed or static build
</p>
</li>
<li>
<p>
Added option to compile IUP (needed for VMs)
</p>
</li>
<li>
<p>
Server side run launching
</p>
</li>
<li>
<p>
Wizards for creating tests, regression areas (current ones are text only and limited).
</p>
</li>
<li>
<p>
Fully functional built in web service (currently you can browse runs but it is very simplistic).
</p>
</li>
<li>
<p>
Gui panels for editing megatest.config and runconfigs.config
</p>
</li>
<li>
<p>
Fully isolated tests (no use of NFS to see regression area files)
</p>
</li>
<li>
<p>
Windows version
</p>
</li>
</ol></div>
</div>
</div>
<div class="sect1">
<h2 id="_installation">Installation</h2>
<div class="sectionbody">
<div class="sect2">
<h3 id="_dependencies">Dependencies</h3>
<div class="paragraph"><p>Chicken scheme and a number of "eggs" are required for building
Megatest. In the v1.66 and beyond assistance to create the build
system is built into the Makefile.</p></div>
<div class="listingblock">
<div class="title">Installation steps (overview)</div>
<div class="content monospaced">
<pre>./configure
make chicken
setup.sh make -j install</pre>
</div></div>
<div class="paragraph"><p>Or install the needed build system manually:</p></div>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
Chicken scheme from <a href="http://call-cc.org">http://call-cc.org</a>
</p>
</li>
<li>
<p>
IUP from <a href="http://webserver2.tecgraf.puc-rio.br/iup/">http://webserver2.tecgraf.puc-rio.br/iup/</a>
</p>
</li>
<li>
<p>
CD from <a href="http://webserver2.tecgraf.puc-rio.br/cd/">http://webserver2.tecgraf.puc-rio.br/cd/</a>
</p>
</li>
<li>
<p>
IM from <a href="https://webserver2.tecgraf.puc-rio.br/im/">https://webserver2.tecgraf.puc-rio.br/im/</a>
</p>
</li>
<li>
<p>
ffcall from <a href="http://webserver2.tecgraf.puc-rio.br/iup/">http://webserver2.tecgraf.puc-rio.br/iup/</a>
</p>
</li>
<li>
<p>
Nanomsg from <a href="https://nanomsg.org/">https://nanomsg.org/</a> (NOTE: Plan is to eliminate nanomsg dependency).
</p>
</li>
<li>
<p>
Needed eggs (look at the eggs lists in the Makefile)
</p>
</li>
</ol></div>
<div class="paragraph"><p>Then follow these steps:</p></div>
<div class="listingblock">
<div class="title">Installation steps (self-built chicken scheme build system)</div>
<div class="content monospaced">
<pre>./configure
make -j install</pre>
</div></div>
</div>
</div>
</div>
<div class="sect1">
<h2 id="_getting_started">Getting Started</h2>
<div class="sectionbody">
<div class="listingblock">

# script that takes path as parameter and returns number of bytes available:
free-space-script check-space.sh</pre>
</div></div>
</div>
<div class="sect2">
<h3 id="_trim_trailing_spaces">Trim trailing spaces</h3>
<div class="admonitionblock">
<table><tr>
<td class="icon">
<img src="/nfs/pdx/disks/ice.disk.002/icfadm/pkgs/asciidoc/8.6.7/images/icons/note.png" alt="Note">
</td>
<td class="content">As of Megatest version v1.6548 trim-trailing-spaces defaults to yes.</td>
</tr></table>
</div>
<div class="listingblock">
<div class="content monospaced">
<pre>[configf:settings trim-trailing-spaces no]
#                 |&lt;== next line padded with spaces to here
DEFAULT_INDENT
[configf:settings trim-trailing-spaces no]</pre>
</div></div>
<div class="paragraph"><p>The variable DEFAULT_INDENT would be a string of 3 spaces</p></div>
</div>
<div class="sect2">
<h3 id="_job_submission_control">Job Submission Control</h3>
<div class="sect3">
<h4 id="_submit_jobs_to_host_types_based_on_test_name_2">Submit jobs to Host Types based on Test Name</h4>
<div class="listingblock">
<div class="title">In megatest.config</div>

<h3 id="_wait_on_other_tests">Wait on Other Tests</h3>
<div class="listingblock">
<div class="content monospaced">
<pre># A normal waiton waits for the prior tests to be COMPLETED
# and PASS, CHECK or WAIVED
waiton test1 test2</pre>
</div></div>
<div class="admonitionblock">
<table><tr>
<td class="icon">
<img src="/nfs/pdx/disks/ice.disk.002/icfadm/pkgs/asciidoc/8.6.7/images/icons/note.png" alt="Note">
</td>
<td class="content">Dynamic waiton lists must be capable of being calculated at the
beginning of a run. This is because Megatest walks the tree of waitons
to create the list of tests to execute.</td>
</tr></table>
</div>
<div class="listingblock">
<div class="title">This works</div>
<div class="content monospaced">
<pre>waiton [system somescript.sh]</pre>
</div></div>
<div class="listingblock">
<div class="title">This does NOT work (the full context for the test is not available so #{shell &#8230;} is NOT enabled to evaluate.</div>
<div class="content monospaced">
<pre>waiton #{shell somescript.sh}</pre>
</div></div>
<div class="listingblock">
<div class="title">This does NOT work</div>
<div class="content monospaced">
<pre>waiton [system somescript_that_depends_on_a_prior_test.sh]</pre>
</div></div>
</div>
<div class="sect2">
<h3 id="_mode">Mode</h3>
<div class="paragraph"><p>The default (i.e. if mode is not specified) is normal. All pre-dependent tests
must be COMPLETED and PASS, CHECK or WAIVED before the test will start</p></div>
<div class="listingblock">
<div class="content monospaced">

<h3 id="_disks">Disks</h3>
<div class="paragraph"><p>A disks section in testconfig will override the disks section in
megatest.config. This can be used to allocate disks on a per-test or per item
basis.</p></div>
</div>
<div class="sect2">
<h3 id="_controlled_waiver_propagation">Controlled waiver propagation</h3>
<div class="paragraph"><p>If test is FAIL and previous test in run with same MT_TARGET is WAIVED
or if the test/itempath is listed under the matching target in the
waivers roll forward file (see below for file spec) then apply the
following rules from the testconfig: If a waiver check is specified in
the testconfig apply the check and if it passes then set this FAIL to
WAIVED</p></div>
<div class="paragraph"><p>Waiver check has two parts, 1) a list of waiver, rulename,
filepatterns and 2) the rulename script spec (note that "diff" and
"logpro" are predefined)</p></div>
<div class="listingblock">
<div class="content monospaced">
<pre>###### EXAMPLE FROM testconfig #########
# matching file(s) will be diff'd with previous run and logpro applied
# if PASS or WARN result from logpro then WAIVER state is set
#
[waivers]
# logpro_file    rulename      input_glob
waiver_1         logpro        lookittmp.log

[waiver_rules]

# This builtin rule is the default if there is no &lt;waivername&gt;.logpro file
# diff   diff %file1% %file2%

# This builtin rule is applied if a &lt;waivername&gt;.logpro file exists
# logpro diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html</pre>
</div></div>
<div class="sect3">
<h4 id="_waiver_roll_forward_files">Waiver roll-forward files</h4>
<div class="paragraph"><p>To transfer waivers from one Megatest area to another it is possible
to dump waivers into a file and reference that file in another area.</p></div>
<div class="listingblock">
<div class="title">Dumping the waivers</div>
<div class="content monospaced">
<pre>megatest -list-waivers -runname %-a &gt; mywaivers.dat</pre>
</div></div>
<div class="listingblock">
<div class="title">Referencing the saved waivers</div>
<div class="content monospaced">
<pre># In megatest.config, all files listed will be loaded - recomended to use
# variables to select directorys to minimize what gets loaded.
[setup]
waivers-dirs /path/to/waiver/files /another/path/to/waiver/files</pre>
</div></div>
<div class="listingblock">
<div class="title">Waiver files format</div>
<div class="content monospaced">
<pre>[the/target/here]
# comments are fine
testname1/itempath A comment about why it was waived
testname2          A comment for a non-itemized test</pre>
</div></div>
</div>
</div>
<div class="sect2">
<h3 id="_ezsteps">Ezsteps</h3>
<div class="listingblock">
<div class="title">Example ezsteps with logpro rules</div>
<div class="content monospaced">
<pre>[ezsteps]

<div class="sectionbody">
<div class="imageblock graphviz">
<div class="content">
<img src="server.png" alt="server.png">
</div>
</div>
</div>


































































































































































































































































































































































</div>
<div class="sect1">
<h2 id="_index">Index</h2>
<div class="sectionbody">
</div>
</div>
</div>
<div id="footnotes"><hr></div>
<div id="footer">
<div id="footer-text">
Version 1.5<br>
Last updated 2020-06-29 08:09:27 PDT
</div>
</div>
</body>
</html>

The Megatest Users Manual
=========================
Matt Welland <matt@kiatoa.com>
v1.5, June 2020
:doctype: book


[preface]
Preface
-------

This book is organised as three sub-books; getting started, writing tests and reference.

.License
----------------------------
    Copyright 2006-2020, Matthew Welland.

    This document 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.

-------------

The Megatest project was started for two reasons, the first was an
immediate and pressing need for a generalized tool to manage a suite
of regression tests and the second was the fact that I had written or
maintained several such tools at different companies over the years. I
thought a single open source tool, flexible enough to meet the needs
of any team doing continuous integration and or running a complex
suite of tests for release qualification would solve some problems for
me and for others.

 -- Matt Welland, original author of the Megatest tool suite.

Megatest Design Philosophy
--------------------------

which can launch jobs on local and remote Linux hosts. Currently
megatest uses the network filesystem to call home to your master
sqlite3 database. Megatest has been used with the Intel Netbatch and
lsf (also known as openlava) batch systems and it should be
straightforward to use it with other similar systems.

include::overview.txt[]

include::plan.txt[]

include::installation.txt[]

include::getting_started.txt[]

include::study_plan.txt[]

// :leveloffset: 0

include::writing_tests.txt[]

include::howto.txt[]

include::reference.txt[]


Megatest Internals
------------------

["graphviz", "server.png"]
----------------------------------------------------------------------
include::server.dot[]
----------------------------------------------------------------------

// include::plan.txt[]
// to allow the getting_started.txt to be a stand-alone document use level
// shifting, note that the preceding blank line is needed.
// :leveloffset: 2


// [appendix]
// Example Appendix
// ================
// One or more optional appendixes go here at section level zero.

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

// Copyright 2006-2020, Matthew Welland.

TODO / Road Map
---------------

Note: This road-map is a wish list and not a formal plan. Items are in
rough priority but are subject to change. Development is driven by
user requests, developer "itch" and bug reports. Please contact
matt@kiatoa.com with requests or bug reports. Requests from inside
Intel generally take priority.

Dashboard and runs

. Multi-area dashboard view

Tests Support

. Add variable $MT_RUNPATH = $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME
. Improve [script], especially indent handling

Scalability

. Overflow database methodology - combine the best of the v1.63
  multi-db approach and the current db-in-tmp approach (currently
  slowness can be seen when number of tests in a db goes over 50-100k,
  with the overflow db it will be able to handle 1000's of runs with
  50-100k tests per run). High priority - goal is to complete this by
  20Q3.

Mtutils/CI

. Enable mtutil calls from dashboard (for remote control)
. Logs browser (esp. for surfacing mtutil related activities)
. Embed ftfplan for distributed automation, completed activities trigger QA runs which trigger deployment etc.
. Jenkins junit XML support [DONE]
. Add output flushing in teamcity support

Build system

. ./configure => ubuntu, sles11, sles12, rh7 [WIP]
. Switch to using simple runs query everywhere
. Add end_time to runs and add a rollup call that sets state, status and end_time

Code refactoring/quality/performance

. Switch to scsh-process pipeline management for job execution/control
. Use call-with-environment-variables where possible.

Migration to inmem db and or overflow db

. Re-work the dbstruct data structure?
.. [ run-id.db inmemdb last-mod last-read last-sync inuse ]

Some ideas for Megatest 2.0

.   Aggressive megatest.config and runconfig.config caching.
..  Cache the configs in $MT_RUNPATH
..  Following invocations of –run, -rerun* will calculate the new config but only overwrite the cached file IF changed
. If the cached file changes ALL existing tests go from COMPLETED -> STALE, I’m not sure what to do about RUNNING tests
. !VARS in runconfigs are not exported to the environment. They are accessed via rget as if the ! was not there.
. Per test copy commands (example is incomplete).
----------------
[testcopy]
%/iind% unison SRC DEST
% cp –r SRC DEST
----------------






Add ability to move runs to other Areas (overlaps with overflow db system)


. allow shrinking megatest.db data by moving runs to an alternate
  Megatest area with same keys.





. add param -destination [area|path]. when specified runs are copied to new
  area and removed from local db.
. the data move would involve these steps
.. copy the run data to destination area megatest.db
.. mark the run records as deleted, do not remove the run data on disk
. accessing the data would be by running dashboard in the satellite area
. future versions of Megatest dashboard should support displaying areas in a
  merged way.
. some new controls would be supported in the config
.. [setup] => allow-runs [no|yes]  <== used to disallow runs
.. [setup] => auto-migrate=[areaname|path]  <== used to automatically
   migrate data to a satellite area.


Eliminate ties to homehost (part of overflow db system)




. Server creates captain pkt


























. Create a lock in the db



. Relinquish db when done




Tasks - better management of run manager processes etc.


































. adjutant queries tasks table for next action [red]#[Migrate into mtutil]#
.. Task table used for tracking runner process [red]#[Replaced by mtutil]#
.. Task table used for jobs to run [red]#[Replaced by mtutil]#
.. Task table used for queueing runner actions (remove runs,
   cleanRunExecute, etc)  [red]#[Replaced by mtutil#]
. adjutant (server/task dispatch/execution manager)  

Stale propagation

 . Mark dependent tests for clean/rerun -rerun-downstream
 . On run start check for defunct tests in RUNNING, LAUNCHED or REMOTEHOSTSTART and correct or notify
 . Fix: refresh of gui sometimes fails on last item (race condition?)
 
Bin list

 . Rerun step and or subsequent steps from gui [DONE?]
 . Refresh test area files from gui
 . Clean and re-run button
 . Clean up STATE and STATUS handling.
 .. Dashboard and Test control panel are reverse order - choose and fix
 .. Move seldom used states and status to drop down selector
 . Access test control panel when clicking on Run Summary tests
 . Feature: -generate-index-tree
 . Change specifing of state and status to use STATE1/STATUS1,STATE2/STATUS2
 



 . rest api available for use with Perl, Ruby etc. scripts
 . megatest.config setup entries for:
 .. run launching (e.g. /bin/sh %CMD% > /dev/null)
 .. browser "konqueror %FNAME%


















 . refdb: Add export of csv, json and sexp
 . Convert to using call-with-environment-variables where possible. Should allow handling of parallel runs in same process.

 . Re-work text interface wizards. Several bugs on record. Possibly convert to gui based.
 . Add to testconfig requirements section; launchlimiter scriptname, calls scriptname to check if ok to launch test
 . Refactor Run Summary view, currently very clumsy
 . Add option to show steps in Run Summary view
  . Refactor guis for resizeablity
 . Add filters to Run Summary view and Run Control view
 . Add to megatest.config or testconfig; rerunok STATE/STATUS,STATE/STATUS...
 . Launch gates for diskspace; /path/one>1G,/path/two>200M,/tmp>5G,#{scheme *toppath*}>1G












 . Tool tips
 . Filters on Run Summary, Summary and Run Control panel
 . Built in log viewer (partially implemented)
 . Refactor the test control panel
   Help and documentation
 . Complete the user manual (I’ve been working on this lately).
 . Online help in the gui
   Streamlined install
 . Deployed or static build

 . Added option to compile IUP (needed for VMs)
 . Server side run launching


 . Wizards for creating tests, regression areas (current ones are text only and limited).
 . Fully functional built in web service (currently you can browse runs but it is very simplistic).

 . Gui panels for editing megatest.config and runconfigs.config
 . Fully isolated tests (no use of NFS to see regression area files)
 . Windows version

# script that takes path as parameter and returns number of bytes available:
free-space-script check-space.sh
-------------------

Trim trailing spaces
~~~~~~~~~~~~~~~~~~~~

NOTE: As of Megatest version v1.6548 trim-trailing-spaces defaults to yes.

------------------
[configf:settings trim-trailing-spaces no]
#                 |<== next line padded with spaces to here
DEFAULT_INDENT
[configf:settings trim-trailing-spaces no]
------------------

The variable DEFAULT_INDENT would be a string of 3 spaces

Job Submission Control
~~~~~~~~~~~~~~~~~~~~~~

Submit jobs to Host Types based on Test Name
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

~~~~~~~~~~~~~~~~~~~

-------------------
# A normal waiton waits for the prior tests to be COMPLETED 
# and PASS, CHECK or WAIVED
waiton test1 test2
-------------------

NOTE: Dynamic waiton lists must be capable of being calculated at the
beginning of a run. This is because Megatest walks the tree of waitons
to create the list of tests to execute.

.This works
-------------------
waiton [system somescript.sh]
-------------------

.This does NOT work (the full context for the test is not available so #{shell ...} is NOT enabled to evaluate.
-------------------
waiton #{shell somescript.sh}
-------------------

.This does NOT work
-------------------
waiton [system somescript_that_depends_on_a_prior_test.sh]
-------------------

Mode
~~~~

The default (i.e. if mode is not specified) is normal. All pre-dependent tests
must be COMPLETED and PASS, CHECK or WAIVED before the test will start

A disks section in testconfig will override the disks section in
megatest.config. This can be used to allocate disks on a per-test or per item
basis.

Controlled waiver propagation
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

If test is FAIL and previous test in run with same MT_TARGET is WAIVED
or if the test/itempath is listed under the matching target in the
waivers roll forward file (see below for file spec) then apply the
following rules from the testconfig: If a waiver check is specified in
the testconfig apply the check and if it passes then set this FAIL to
WAIVED

Waiver check has two parts, 1) a list of waiver, rulename,
filepatterns and 2) the rulename script spec (note that "diff" and
"logpro" are predefined)

-----------------
###### EXAMPLE FROM testconfig #########
# matching file(s) will be diff'd with previous run and logpro applied
# if PASS or WARN result from logpro then WAIVER state is set
#
[waivers]
# logpro_file    rulename      input_glob
waiver_1         logpro        lookittmp.log

[waiver_rules]

# This builtin rule is the default if there is no <waivername>.logpro file
# diff   diff %file1% %file2%

# This builtin rule is applied if a <waivername>.logpro file exists
# logpro diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html
-----------------

Waiver roll-forward files
^^^^^^^^^^^^^^^^^^^^^^^^^

To transfer waivers from one Megatest area to another it is possible
to dump waivers into a file and reference that file in another area.

.Dumping the waivers
---------------------------
megatest -list-waivers -runname %-a > mywaivers.dat
---------------------------

.Referencing the saved waivers
---------------------------
# In megatest.config, all files listed will be loaded - recomended to use
# variables to select directorys to minimize what gets loaded.
[setup]
waivers-dirs /path/to/waiver/files /another/path/to/waiver/files
---------------------------

.Waiver files format
---------------------------
[the/target/here]
# comments are fine
testname1/itempath A comment about why it was waived
testname2          A comment for a non-itemized test 
---------------------------

Ezsteps
~~~~~~~

.Example ezsteps with logpro rules
-----------------
[ezsteps]
lookittmp   ls /tmp

#FIG 3.2  Produced by xfig version 3.2.5-alpha5
Landscape
Center
Inches
Letter  
100.00
Single
-2
1200 2
6 150 5475 1650 9675
2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5
	 150 5475 1650 5475 1650 9675 150 9675 150 5475
2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5
	 225 5550 1575 5550 1575 6075 225 6075 225 5550
2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5
	 225 6150 1575 6150 1575 6675 225 6675 225 6150
2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5
	 225 6750 1575 6750 1575 7275 225 7275 225 6750
2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5
	 225 7350 1575 7350 1575 7875 225 7875 225 7350
-6
6 3900 5550 5400 9750
2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5
	 3900 5550 5400 5550 5400 9750 3900 9750 3900 5550
2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5
	 3975 5625 5325 5625 5325 6150 3975 6150 3975 5625
2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5
	 3975 6225 5325 6225 5325 6750 3975 6750 3975 6225
2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5
	 3975 6825 5325 6825 5325 7350 3975 7350 3975 6825
2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5
	 3975 7425 5325 7425 5325 7950 3975 7950 3975 7425
-6
6 8325 5700 9525 9825
2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
	 8325 6000 9525 6000 9525 6825 8325 6825 8325 6000
2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
	 8325 6900 9525 6900 9525 7725 8325 7725 8325 6900
2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
	 8325 7800 9525 7800 9525 8625 8325 8625 8325 7800
2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
	 8325 8700 9525 8700 9525 9525 8325 9525 8325 8700
4 0 0 50 -1 0 12 0.0000 4 120 405 8475 5850 tests\001
4 0 0 50 -1 0 12 0.0000 4 165 600 8400 6375 startup\001
4 0 0 50 -1 0 12 0.0000 4 195 375 8400 7275 opt1\001
4 0 0 50 -1 0 12 0.0000 4 195 375 8400 8025 opt2\001
4 0 0 50 -1 0 12 0.0000 4 195 585 8400 9075 opt1v2\001
4 0 0 50 -1 0 12 0.0000 4 15 180 8775 9825 ...\001
-6
2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
	 4800 450 6000 450 6000 1275 4800 1275 4800 450
2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
	 1050 2100 2250 2100 2250 2925 1050 2925 1050 2100
2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
	 2925 2100 4125 2100 4125 2925 2925 2925 2925 2100
2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
	 4950 2100 6150 2100 6150 2925 4950 2925 4950 2100
2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
	 7200 2100 8400 2100 8400 2925 7200 2925 7200 2100
2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
	 9375 2100 10575 2100 10575 2925 9375 2925 9375 2100
2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
	 2025 4050 3225 4050 3225 4875 2025 4875 2025 4050
2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
	 6525 3975 7725 3975 7725 4800 6525 4800 6525 3975
2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2
	0 0 1.00 60.00 120.00
	 5400 1275 1500 2100
2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2
	0 0 1.00 60.00 120.00
	 5325 1275 3525 2100
2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2
	0 0 1.00 60.00 120.00
	 5325 1275 5475 2100
2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2
	0 0 1.00 60.00 120.00
	 5250 1275 7800 2100
2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2
	0 0 1.00 60.00 120.00
	 5325 1275 9900 2100
2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2
	0 0 1.00 60.00 120.00
	 1650 2925 2550 4050
2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2
	0 0 1.00 60.00 120.00
	 3525 2925 2550 4050
2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2
	0 0 1.00 60.00 120.00
	 3525 2925 7050 3975
2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2
	0 0 1.00 60.00 120.00
	 5550 2925 6975 3975
2 2 2 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5
	 750 1650 10875 1650 10875 3450 750 3450 750 1650
2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 0 3
	0 0 1.00 60.00 120.00
	 1050 2700 450 2700 450 5550
2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 0 3
	0 0 1.00 60.00 120.00
	 4125 2700 4650 2700 4650 5550
2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
	 2100 5475 3300 5475 3300 8700 2100 8700 2100 5475
2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
	 2175 6000 3225 6000 3225 6525 2175 6525 2175 6000
2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2
	0 0 1.00 60.00 120.00
	 1500 6375 2325 6300
2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2
	0 0 1.00 60.00 120.00
	 4200 6525 3000 6225
2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2
	0 0 1.00 60.00 120.00
	 7800 2925 7050 3975
2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2
	0 0 1.00 60.00 120.00
	 9975 2925 7125 3900
4 0 0 50 -1 0 12 0.0000 4 165 600 4875 975 startup\001
4 0 0 50 -1 0 12 0.0000 4 15 180 5325 2550 ...\001
4 0 0 50 -1 0 12 0.0000 4 195 2100 900 675 p1278/2/cpdk_r0.5/none\001
4 0 0 50 -1 0 12 0.0000 4 150 675 150 2475 subruns\001
4 0 0 50 -1 0 12 0.0000 4 195 585 2175 4500 opt1v2\001
4 0 0 50 -1 0 12 0.0000 4 195 375 1200 2625 opt1\001
4 0 0 50 -1 0 12 0.0000 4 195 375 3150 2550 opt2\001
4 0 0 50 -1 0 12 0.0000 4 150 2100 3075 150 SUBRUN for Multistack\001
4 0 0 50 -1 0 12 0.0000 4 150 225 300 6375 ftc\001
4 0 0 50 -1 0 12 0.0000 4 150 225 4050 6450 ftc\001
4 0 0 50 -1 0 12 0.0000 4 195 2220 600 5250 p1278/2/cpdk_r0.5/x-opt1\001
4 0 0 50 -1 0 12 0.0000 4 195 2220 4800 5325 p1278/2/cpdk_r0.5/y-opt2\001

;;======================================================================
;; Copyright 2019, 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/>.

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

(declare (unit ducttape-lib))

(include "ducttape/ducttape-lib.scm")

help:
	@echo ""
	@echo "make targets:"
	@echo "============="
	@echo "install      - build and install general_lib egg as icfadm"
	@echo "test         - run unit tests on ducttape-lib.scm (tests code, not egg)"
	@echo "eggs-info     - show chicken-install commands to get eggs upon which ducttape-lib depends"
	@echo "test_example - compile an example scm against installed general_lib egg"
	@echo "clean        - remove binaries and other build artifacts"
	@echo ""

clean:
	rm -f *.so *.import.scm test_ducttape test_example foo *.c *.o

install:
	chicken-install

test:
	echo '(handle-exceptions exn (begin (print-call-chain) (exit 1)) (load "ducttape-lib.scm") (inote "hello")) (exit 0)'  | csi
	chicken-install -no-install
	csc test_ducttape.scm

	./test_ducttape
	rm -f foo

test_example:
	@csc test_example.scm
	@./test_example
	@rm test_example

eggs-info:
	@echo chicken-install ansi-escape-sequences
	@echo chicken-install slice
	@echo chicken-install rfc3339

This directory holds the "ducttape" chicken scheme egg used by megatest.

Run "make test" to ensure this egg works on your system.

Run "make install" as your admin user with chicken on your $PATH to install this egg.

;;; ducttape-lib.meta -*- Hen -*-

((egg "ducttape-lib.egg")
 (synopsis "Miscellaneous tool and standard print routines.")
 (category env)
 (author "Brandon Barclay")
 (doc-from-wiki)
 (license "GPL-2")
 ;; srfi-69, posix, srfi-18
 (depends regex)
 (test-depends test)
 ; suspicious - (files "ducttape-lib")
 )

(module ducttape-lib
    (
     runs-ok
     ducttape-debug-level
     ducttape-debug-regex-filter
     ducttape-silent-mode
     ducttape-quiet-mode
     ducttape-log-file
     ducttape-color-mode
     iputs-preamble
     script-name
     idbg
     ierr
     iwarn
     inote
     iputs
     re-match?
                                        ;     launch-repl
     keyword-skim
     skim-cmdline-opts-noarg-by-regex
     skim-cmdline-opts-withargs-by-regex
     get-cli-arg
     get-cli-switch
     concat-lists
     ducttape-process-command-line
     ducttape-append-logfile
     ducttape-activate-logfile
     isys
     do-or-die
     counter-maker
     dir-is-writable?
     mktemp
     get-tmpdir
     sendmail
     find-exe

     zeropad
     string-leftpad
     string-rightpad
     seconds->isodate
     seconds->wwdate
     seconds->wwdate-values
     isodate->seconds
     isodate->wwdate
     wwdate->seconds
     wwdate->isodate
     current-wwdate
     current-isodate
     *this-exe-dir*
     *this-exe-name*
     *this-exe-fullpath*
     )

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

    ;; plugs a hole in posix-extras in latter chicken versions
  (use posix-extras pathname-expand files)
  (define ##sys#expand-home-path pathname-expand)
  (define (realpath x) (resolve-pathname  (pathname-expand (or x "/dev/null")) ))

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

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

(define ducttape_ext2mimetype '(("ez" . "application/andrew-inset")
("aw" . "application/applixware")
("atom" . "application/atom+xml")
("atomcat" . "application/atomcat+xml")
("atomsvc" . "application/atomsvc+xml")
("ccxml" . "application/ccxml+xml")
("cdmia" . "application/cdmi-capability")
("cdmic" . "application/cdmi-container")
("cdmid" . "application/cdmi-domain")
("cdmio" . "application/cdmi-object")
("cdmiq" . "application/cdmi-queue")
("cu" . "application/cu-seeme")
("davmount" . "application/davmount+xml")
("dbk" . "application/docbook+xml")
("dssc" . "application/dssc+der")
("xdssc" . "application/dssc+xml")
("ecma" . "application/ecmascript")
("emma" . "application/emma+xml")
("epub" . "application/epub+zip")
("exi" . "application/exi")
("pfr" . "application/font-tdpfr")
("gml" . "application/gml+xml")
("gpx" . "application/gpx+xml")
("gxf" . "application/gxf")
("stk" . "application/hyperstudio")
("ink" . "application/inkml+xml")
("ipfix" . "application/ipfix")
("jar" . "application/java-archive")
("ser" . "application/java-serialized-object")
("class" . "application/java-vm")
("js" . "application/javascript")
("json" . "application/json")
("jsonml" . "application/jsonml+json")
("lostxml" . "application/lost+xml")
("hqx" . "application/mac-binhex40")
("cpt" . "application/mac-compactpro")
("mads" . "application/mads+xml")
("mrc" . "application/marc")
("mrcx" . "application/marcxml+xml")
("ma" . "application/mathematica")
("mathml" . "application/mathml+xml")
("mbox" . "application/mbox")
("mscml" . "application/mediaservercontrol+xml")
("metalink" . "application/metalink+xml")
("meta4" . "application/metalink4+xml")
("mets" . "application/mets+xml")
("mods" . "application/mods+xml")
("m21" . "application/mp21")
("mp4s" . "application/mp4")
("doc" . "application/msword")
("mxf" . "application/mxf")
("bin" . "application/octet-stream")
("oda" . "application/oda")
("opf" . "application/oebps-package+xml")
("ogx" . "application/ogg")
("omdoc" . "application/omdoc+xml")
("onetoc" . "application/onenote")
("oxps" . "application/oxps")
("xer" . "application/patch-ops-error+xml")
("pdf" . "application/pdf")
("pgp" . "application/pgp-encrypted")
("asc" . "application/pgp-signature")
("prf" . "application/pics-rules")
("p10" . "application/pkcs10")
("p7m" . "application/pkcs7-mime")
("p7s" . "application/pkcs7-signature")
("p8" . "application/pkcs8")
("ac" . "application/pkix-attr-cert")
("cer" . "application/pkix-cert")
("crl" . "application/pkix-crl")
("pkipath" . "application/pkix-pkipath")
("pki" . "application/pkixcmp")
("pls" . "application/pls+xml")
("ai" . "application/postscript")
("cww" . "application/prs.cww")
("pskcxml" . "application/pskc+xml")
("rdf" . "application/rdf+xml")
("rif" . "application/reginfo+xml")
("rnc" . "application/relax-ng-compact-syntax")
("rl" . "application/resource-lists+xml")
("rld" . "application/resource-lists-diff+xml")
("rs" . "application/rls-services+xml")
("gbr" . "application/rpki-ghostbusters")
("mft" . "application/rpki-manifest")
("roa" . "application/rpki-roa")
("rsd" . "application/rsd+xml")
("rss" . "application/rss+xml")
("rtf" . "application/rtf")
("sbml" . "application/sbml+xml")
("scq" . "application/scvp-cv-request")
("scs" . "application/scvp-cv-response")
("spq" . "application/scvp-vp-request")
("spp" . "application/scvp-vp-response")
("sdp" . "application/sdp")
("setpay" . "application/set-payment-initiation")
("setreg" . "application/set-registration-initiation")
("shf" . "application/shf+xml")
("smi" . "application/smil+xml")
("rq" . "application/sparql-query")
("srx" . "application/sparql-results+xml")
("gram" . "application/srgs")
("grxml" . "application/srgs+xml")
("sru" . "application/sru+xml")
("ssdl" . "application/ssdl+xml")
("ssml" . "application/ssml+xml")
("tei" . "application/tei+xml")
("tfi" . "application/thraud+xml")
("tsd" . "application/timestamped-data")
("plb" . "application/vnd.3gpp.pic-bw-large")
("psb" . "application/vnd.3gpp.pic-bw-small")
("pvb" . "application/vnd.3gpp.pic-bw-var")
("tcap" . "application/vnd.3gpp2.tcap")
("pwn" . "application/vnd.3m.post-it-notes")
("aso" . "application/vnd.accpac.simply.aso")
("imp" . "application/vnd.accpac.simply.imp")
("acu" . "application/vnd.acucobol")
("atc" . "application/vnd.acucorp")
("air" . "application/vnd.adobe.air-application-installer-package+zip")
("fcdt" . "application/vnd.adobe.formscentral.fcdt")
("fxp" . "application/vnd.adobe.fxp")
("xdp" . "application/vnd.adobe.xdp+xml")
("xfdf" . "application/vnd.adobe.xfdf")
("ahead" . "application/vnd.ahead.space")
("azf" . "application/vnd.airzip.filesecure.azf")
("azs" . "application/vnd.airzip.filesecure.azs")
("azw" . "application/vnd.amazon.ebook")
("acc" . "application/vnd.americandynamics.acc")
("ami" . "application/vnd.amiga.ami")
("apk" . "application/vnd.android.package-archive")
("cii" . "application/vnd.anser-web-certificate-issue-initiation")
("fti" . "application/vnd.anser-web-funds-transfer-initiation")
("atx" . "application/vnd.antix.game-component")
("mpkg" . "application/vnd.apple.installer+xml")
("m3u8" . "application/vnd.apple.mpegurl")
("swi" . "application/vnd.aristanetworks.swi")
("iota" . "application/vnd.astraea-software.iota")
("aep" . "application/vnd.audiograph")
("mpm" . "application/vnd.blueice.multipass")
("bmi" . "application/vnd.bmi")
("rep" . "application/vnd.businessobjects")
("cdxml" . "application/vnd.chemdraw+xml")
("mmd" . "application/vnd.chipnuts.karaoke-mmd")
("cdy" . "application/vnd.cinderella")
("cla" . "application/vnd.claymore")
("rp9" . "application/vnd.cloanto.rp9")
("c4g" . "application/vnd.clonk.c4group")
("c11amc" . "application/vnd.cluetrust.cartomobile-config")
("c11amz" . "application/vnd.cluetrust.cartomobile-config-pkg")
("csp" . "application/vnd.commonspace")
("cdbcmsg" . "application/vnd.contact.cmsg")
("cmc" . "application/vnd.cosmocaller")
("clkx" . "application/vnd.crick.clicker")
("clkk" . "application/vnd.crick.clicker.keyboard")
("clkp" . "application/vnd.crick.clicker.palette")
("clkt" . "application/vnd.crick.clicker.template")
("clkw" . "application/vnd.crick.clicker.wordbank")
("wbs" . "application/vnd.criticaltools.wbs+xml")
("pml" . "application/vnd.ctc-posml")
("ppd" . "application/vnd.cups-ppd")
("car" . "application/vnd.curl.car")
("pcurl" . "application/vnd.curl.pcurl")
("dart" . "application/vnd.dart")
("rdz" . "application/vnd.data-vision.rdz")
("uvf" . "application/vnd.dece.data")
("uvt" . "application/vnd.dece.ttml+xml")
("uvx" . "application/vnd.dece.unspecified")
("uvz" . "application/vnd.dece.zip")
("fe_launch" . "application/vnd.denovo.fcselayout-link")
("dna" . "application/vnd.dna")
("mlp" . "application/vnd.dolby.mlp")
("dpg" . "application/vnd.dpgraph")
("dfac" . "application/vnd.dreamfactory")
("kpxx" . "application/vnd.ds-keypoint")
("ait" . "application/vnd.dvb.ait")
("svc" . "application/vnd.dvb.service")
("geo" . "application/vnd.dynageo")
("mag" . "application/vnd.ecowin.chart")
("nml" . "application/vnd.enliven")
("esf" . "application/vnd.epson.esf")
("msf" . "application/vnd.epson.msf")
("qam" . "application/vnd.epson.quickanime")
("slt" . "application/vnd.epson.salt")
("ssf" . "application/vnd.epson.ssf")
("es3" . "application/vnd.eszigno3+xml")
("ez2" . "application/vnd.ezpix-album")
("ez3" . "application/vnd.ezpix-package")
("fdf" . "application/vnd.fdf")
("mseed" . "application/vnd.fdsn.mseed")
("seed" . "application/vnd.fdsn.seed")
("gph" . "application/vnd.flographit")
("ftc" . "application/vnd.fluxtime.clip")
("fm" . "application/vnd.framemaker")
("fnc" . "application/vnd.frogans.fnc")
("ltf" . "application/vnd.frogans.ltf")
("fsc" . "application/vnd.fsc.weblaunch")
("oas" . "application/vnd.fujitsu.oasys")
("oa2" . "application/vnd.fujitsu.oasys2")
("oa3" . "application/vnd.fujitsu.oasys3")
("fg5" . "application/vnd.fujitsu.oasysgp")
("bh2" . "application/vnd.fujitsu.oasysprs")
("ddd" . "application/vnd.fujixerox.ddd")
("xdw" . "application/vnd.fujixerox.docuworks")
("xbd" . "application/vnd.fujixerox.docuworks.binder")
("fzs" . "application/vnd.fuzzysheet")
("txd" . "application/vnd.genomatix.tuxedo")
("ggb" . "application/vnd.geogebra.file")
("ggt" . "application/vnd.geogebra.tool")
("gex" . "application/vnd.geometry-explorer")
("gxt" . "application/vnd.geonext")
("g2w" . "application/vnd.geoplan")
("g3w" . "application/vnd.geospace")
("gmx" . "application/vnd.gmx")
("kml" . "application/vnd.google-earth.kml+xml")
("kmz" . "application/vnd.google-earth.kmz")
("gqf" . "application/vnd.grafeq")
("gac" . "application/vnd.groove-account")
("ghf" . "application/vnd.groove-help")
("gim" . "application/vnd.groove-identity-message")
("grv" . "application/vnd.groove-injector")
("gtm" . "application/vnd.groove-tool-message")
("tpl" . "application/vnd.groove-tool-template")
("vcg" . "application/vnd.groove-vcard")
("hal" . "application/vnd.hal+xml")
("zmm" . "application/vnd.handheld-entertainment+xml")
("hbci" . "application/vnd.hbci")
("les" . "application/vnd.hhe.lesson-player")
("hpgl" . "application/vnd.hp-hpgl")
("hpid" . "application/vnd.hp-hpid")
("hps" . "application/vnd.hp-hps")
("jlt" . "application/vnd.hp-jlyt")
("pcl" . "application/vnd.hp-pcl")
("pclxl" . "application/vnd.hp-pclxl")
("sfd-hdstx" . "application/vnd.hydrostatix.sof-data")
("mpy" . "application/vnd.ibm.minipay")
("afp" . "application/vnd.ibm.modcap")
("irm" . "application/vnd.ibm.rights-management")
("sc" . "application/vnd.ibm.secure-container")
("icc" . "application/vnd.iccprofile")
("igl" . "application/vnd.igloader")
("ivp" . "application/vnd.immervision-ivp")
("ivu" . "application/vnd.immervision-ivu")
("igm" . "application/vnd.insors.igm")
("xpw" . "application/vnd.intercon.formnet")
("i2g" . "application/vnd.intergeo")
("qbo" . "application/vnd.intu.qbo")
("qfx" . "application/vnd.intu.qfx")
("rcprofile" . "application/vnd.ipunplugged.rcprofile")
("irp" . "application/vnd.irepository.package+xml")
("xpr" . "application/vnd.is-xpr")
("fcs" . "application/vnd.isac.fcs")
("jam" . "application/vnd.jam")
("rms" . "application/vnd.jcp.javame.midlet-rms")
("jisp" . "application/vnd.jisp")
("joda" . "application/vnd.joost.joda-archive")
("ktz" . "application/vnd.kahootz")
("karbon" . "application/vnd.kde.karbon")
("chrt" . "application/vnd.kde.kchart")
("kfo" . "application/vnd.kde.kformula")
("flw" . "application/vnd.kde.kivio")
("kon" . "application/vnd.kde.kontour")
("kpr" . "application/vnd.kde.kpresenter")
("ksp" . "application/vnd.kde.kspread")
("kwd" . "application/vnd.kde.kword")
("htke" . "application/vnd.kenameaapp")
("kia" . "application/vnd.kidspiration")
("kne" . "application/vnd.kinar")
("skp" . "application/vnd.koan")
("sse" . "application/vnd.kodak-descriptor")
("lasxml" . "application/vnd.las.las+xml")
("lbd" . "application/vnd.llamagraphics.life-balance.desktop")
("lbe" . "application/vnd.llamagraphics.life-balance.exchange+xml")
("123" . "application/vnd.lotus-1-2-3")
("apr" . "application/vnd.lotus-approach")
("pre" . "application/vnd.lotus-freelance")
("nsf" . "application/vnd.lotus-notes")
("org" . "application/vnd.lotus-organizer")
("scm" . "application/vnd.lotus-screencam")
("lwp" . "application/vnd.lotus-wordpro")
("portpkg" . "application/vnd.macports.portpkg")
("mcd" . "application/vnd.mcd")
("mc1" . "application/vnd.medcalcdata")
("cdkey" . "application/vnd.mediastation.cdkey")
("mwf" . "application/vnd.mfer")
("mfm" . "application/vnd.mfmp")
("flo" . "application/vnd.micrografx.flo")
("igx" . "application/vnd.micrografx.igx")
("mif" . "application/vnd.mif")
("daf" . "application/vnd.mobius.daf")
("dis" . "application/vnd.mobius.dis")
("mbk" . "application/vnd.mobius.mbk")
("mqy" . "application/vnd.mobius.mqy")
("msl" . "application/vnd.mobius.msl")
("plc" . "application/vnd.mobius.plc")
("txf" . "application/vnd.mobius.txf")
("mpn" . "application/vnd.mophun.application")
("mpc" . "application/vnd.mophun.certificate")
("xul" . "application/vnd.mozilla.xul+xml")
("cil" . "application/vnd.ms-artgalry")
("cab" . "application/vnd.ms-cab-compressed")
("xls" . "application/vnd.ms-excel")
("xlam" . "application/vnd.ms-excel.addin.macroenabled.12")
("xlsb" . "application/vnd.ms-excel.sheet.binary.macroenabled.12")
("xlsm" . "application/vnd.ms-excel.sheet.macroenabled.12")
("xltm" . "application/vnd.ms-excel.template.macroenabled.12")
("eot" . "application/vnd.ms-fontobject")
("chm" . "application/vnd.ms-htmlhelp")
("ims" . "application/vnd.ms-ims")
("lrm" . "application/vnd.ms-lrm")
("thmx" . "application/vnd.ms-officetheme")
("cat" . "application/vnd.ms-pki.seccat")
("stl" . "application/vnd.ms-pki.stl")
("ppt" . "application/vnd.ms-powerpoint")
("ppam" . "application/vnd.ms-powerpoint.addin.macroenabled.12")
("pptm" . "application/vnd.ms-powerpoint.presentation.macroenabled.12")
("sldm" . "application/vnd.ms-powerpoint.slide.macroenabled.12")
("ppsm" . "application/vnd.ms-powerpoint.slideshow.macroenabled.12")
("potm" . "application/vnd.ms-powerpoint.template.macroenabled.12")
("mpp" . "application/vnd.ms-project")
("docm" . "application/vnd.ms-word.document.macroenabled.12")
("dotm" . "application/vnd.ms-word.template.macroenabled.12")
("wps" . "application/vnd.ms-works")
("wpl" . "application/vnd.ms-wpl")
("xps" . "application/vnd.ms-xpsdocument")
("mseq" . "application/vnd.mseq")
("mus" . "application/vnd.musician")
("msty" . "application/vnd.muvee.style")
("taglet" . "application/vnd.mynfc")
("nlu" . "application/vnd.neurolanguage.nlu")
("ntf" . "application/vnd.nitf")
("nnd" . "application/vnd.noblenet-directory")
("nns" . "application/vnd.noblenet-sealer")
("nnw" . "application/vnd.noblenet-web")
("ngdat" . "application/vnd.nokia.n-gage.data")
("n-gage" . "application/vnd.nokia.n-gage.symbian.install")
("rpst" . "application/vnd.nokia.radio-preset")
("rpss" . "application/vnd.nokia.radio-presets")
("edm" . "application/vnd.novadigm.edm")
("edx" . "application/vnd.novadigm.edx")
("ext" . "application/vnd.novadigm.ext")
("odc" . "application/vnd.oasis.opendocument.chart")
("otc" . "application/vnd.oasis.opendocument.chart-template")
("odb" . "application/vnd.oasis.opendocument.database")
("odf" . "application/vnd.oasis.opendocument.formula")
("odft" . "application/vnd.oasis.opendocument.formula-template")
("odg" . "application/vnd.oasis.opendocument.graphics")
("otg" . "application/vnd.oasis.opendocument.graphics-template")
("odi" . "application/vnd.oasis.opendocument.image")
("oti" . "application/vnd.oasis.opendocument.image-template")
("odp" . "application/vnd.oasis.opendocument.presentation")
("otp" . "application/vnd.oasis.opendocument.presentation-template")
("ods" . "application/vnd.oasis.opendocument.spreadsheet")
("ots" . "application/vnd.oasis.opendocument.spreadsheet-template")
("odt" . "application/vnd.oasis.opendocument.text")
("odm" . "application/vnd.oasis.opendocument.text-master")
("ott" . "application/vnd.oasis.opendocument.text-template")
("oth" . "application/vnd.oasis.opendocument.text-web")
("xo" . "application/vnd.olpc-sugar")
("dd2" . "application/vnd.oma.dd2+xml")
("oxt" . "application/vnd.openofficeorg.extension")
("pptx" . "application/vnd.openxmlformats-officedocument.presentationml.presentation")
("sldx" . "application/vnd.openxmlformats-officedocument.presentationml.slide")
("ppsx" . "application/vnd.openxmlformats-officedocument.presentationml.slideshow")
("potx" . "application/vnd.openxmlformats-officedocument.presentationml.template")
("xlsx" . "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet")
("xltx" . "application/vnd.openxmlformats-officedocument.spreadsheetml.template")
("docx" . "application/vnd.openxmlformats-officedocument.wordprocessingml.document")
("dotx" . "application/vnd.openxmlformats-officedocument.wordprocessingml.template")
("mgp" . "application/vnd.osgeo.mapguide.package")
("dp" . "application/vnd.osgi.dp")
("esa" . "application/vnd.osgi.subsystem")
("pdb" . "application/vnd.palm")
("paw" . "application/vnd.pawaafile")
("str" . "application/vnd.pg.format")
("ei6" . "application/vnd.pg.osasli")
("efif" . "application/vnd.picsel")
("wg" . "application/vnd.pmi.widget")
("plf" . "application/vnd.pocketlearn")
("pbd" . "application/vnd.powerbuilder6")
("box" . "application/vnd.previewsystems.box")
("mgz" . "application/vnd.proteus.magazine")
("qps" . "application/vnd.publishare-delta-tree")
("ptid" . "application/vnd.pvi.ptid1")
("qxd" . "application/vnd.quark.quarkxpress")
("bed" . "application/vnd.realvnc.bed")
("mxl" . "application/vnd.recordare.musicxml")
("musicxml" . "application/vnd.recordare.musicxml+xml")
("cryptonote" . "application/vnd.rig.cryptonote")
("cod" . "application/vnd.rim.cod")
("rm" . "application/vnd.rn-realmedia")
("rmvb" . "application/vnd.rn-realmedia-vbr")
("link66" . "application/vnd.route66.link66+xml")
("st" . "application/vnd.sailingtracker.track")
("see" . "application/vnd.seemail")
("sema" . "application/vnd.sema")
("semd" . "application/vnd.semd")
("semf" . "application/vnd.semf")
("ifm" . "application/vnd.shana.informed.formdata")
("itp" . "application/vnd.shana.informed.formtemplate")
("iif" . "application/vnd.shana.informed.interchange")
("ipk" . "application/vnd.shana.informed.package")
("twd" . "application/vnd.simtech-mindmapper")
("mmf" . "application/vnd.smaf")
("teacher" . "application/vnd.smart.teacher")
("sdkm" . "application/vnd.solent.sdkm+xml")
("dxp" . "application/vnd.spotfire.dxp")
("sfs" . "application/vnd.spotfire.sfs")
("sdc" . "application/vnd.stardivision.calc")
("sda" . "application/vnd.stardivision.draw")
("sdd" . "application/vnd.stardivision.impress")
("smf" . "application/vnd.stardivision.math")
("sdw" . "application/vnd.stardivision.writer")
("sgl" . "application/vnd.stardivision.writer-global")
("smzip" . "application/vnd.stepmania.package")
("sm" . "application/vnd.stepmania.stepchart")
("sxc" . "application/vnd.sun.xml.calc")
("stc" . "application/vnd.sun.xml.calc.template")
("sxd" . "application/vnd.sun.xml.draw")
("std" . "application/vnd.sun.xml.draw.template")
("sxi" . "application/vnd.sun.xml.impress")
("sti" . "application/vnd.sun.xml.impress.template")
("sxm" . "application/vnd.sun.xml.math")
("sxw" . "application/vnd.sun.xml.writer")
("sxg" . "application/vnd.sun.xml.writer.global")
("stw" . "application/vnd.sun.xml.writer.template")
("sus" . "application/vnd.sus-calendar")
("svd" . "application/vnd.svd")
("sis" . "application/vnd.symbian.install")
("xsm" . "application/vnd.syncml+xml")
("bdm" . "application/vnd.syncml.dm+wbxml")
("xdm" . "application/vnd.syncml.dm+xml")
("tao" . "application/vnd.tao.intent-module-archive")
("pcap" . "application/vnd.tcpdump.pcap")
("tmo" . "application/vnd.tmobile-livetv")
("tpt" . "application/vnd.trid.tpt")
("mxs" . "application/vnd.triscape.mxs")
("tra" . "application/vnd.trueapp")
("ufd" . "application/vnd.ufdl")
("utz" . "application/vnd.uiq.theme")
("umj" . "application/vnd.umajin")
("unityweb" . "application/vnd.unity")
("uoml" . "application/vnd.uoml+xml")
("vcx" . "application/vnd.vcx")
("vsd" . "application/vnd.visio")
("vis" . "application/vnd.visionary")
("vsf" . "application/vnd.vsf")
("wbxml" . "application/vnd.wap.wbxml")
("wmlc" . "application/vnd.wap.wmlc")
("wmlsc" . "application/vnd.wap.wmlscriptc")
("wtb" . "application/vnd.webturbo")
("nbp" . "application/vnd.wolfram.player")
("wpd" . "application/vnd.wordperfect")
("wqd" . "application/vnd.wqd")
("stf" . "application/vnd.wt.stf")
("xar" . "application/vnd.xara")
("xfdl" . "application/vnd.xfdl")
("hvd" . "application/vnd.yamaha.hv-dic")
("hvs" . "application/vnd.yamaha.hv-script")
("hvp" . "application/vnd.yamaha.hv-voice")
("osf" . "application/vnd.yamaha.openscoreformat")
("osfpvg" . "application/vnd.yamaha.openscoreformat.osfpvg+xml")
("saf" . "application/vnd.yamaha.smaf-audio")
("spf" . "application/vnd.yamaha.smaf-phrase")
("cmp" . "application/vnd.yellowriver-custom-menu")
("zir" . "application/vnd.zul")
("zaz" . "application/vnd.zzazz.deck+xml")
("vxml" . "application/voicexml+xml")
("wgt" . "application/widget")
("hlp" . "application/winhlp")
("wsdl" . "application/wsdl+xml")
("wspolicy" . "application/wspolicy+xml")
("7z" . "application/x-7z-compressed")
("abw" . "application/x-abiword")
("ace" . "application/x-ace-compressed")
("dmg" . "application/x-apple-diskimage")
("aab" . "application/x-authorware-bin")
("aam" . "application/x-authorware-map")
("aas" . "application/x-authorware-seg")
("bcpio" . "application/x-bcpio")
("torrent" . "application/x-bittorrent")
("blb" . "application/x-blorb")
("bz" . "application/x-bzip")
("bz2" . "application/x-bzip2")
("cbr" . "application/x-cbr")
("vcd" . "application/x-cdlink")
("cfs" . "application/x-cfs-compressed")
("chat" . "application/x-chat")
("pgn" . "application/x-chess-pgn")
("nsc" . "application/x-conference")
("cpio" . "application/x-cpio")
("csh" . "application/x-csh")
("deb" . "application/x-debian-package")
("dgc" . "application/x-dgc-compressed")
("dir" . "application/x-director")
("wad" . "application/x-doom")
("ncx" . "application/x-dtbncx+xml")
("dtb" . "application/x-dtbook+xml")
("res" . "application/x-dtbresource+xml")
("dvi" . "application/x-dvi")
("evy" . "application/x-envoy")
("eva" . "application/x-eva")
("bdf" . "application/x-font-bdf")
("gsf" . "application/x-font-ghostscript")
("psf" . "application/x-font-linux-psf")
("otf" . "application/x-font-otf")
("pcf" . "application/x-font-pcf")
("snf" . "application/x-font-snf")
("ttf" . "application/x-font-ttf")
("pfa" . "application/x-font-type1")
("woff" . "application/x-font-woff")
("arc" . "application/x-freearc")
("spl" . "application/x-futuresplash")
("gca" . "application/x-gca-compressed")
("ulx" . "application/x-glulx")
("gnumeric" . "application/x-gnumeric")
("gramps" . "application/x-gramps-xml")
("gtar" . "application/x-gtar")
("hdf" . "application/x-hdf")
("install" . "application/x-install-instructions")
("iso" . "application/x-iso9660-image")
("jnlp" . "application/x-java-jnlp-file")
("latex" . "application/x-latex")
("lzh" . "application/x-lzh-compressed")
("mie" . "application/x-mie")
("prc" . "application/x-mobipocket-ebook")
("m3u8" . "application/x-mpegurl")
("application" . "application/x-ms-application")
("lnk" . "application/x-ms-shortcut")
("wmd" . "application/x-ms-wmd")
("wmz" . "application/x-ms-wmz")
("xbap" . "application/x-ms-xbap")
("mdb" . "application/x-msaccess")
("obd" . "application/x-msbinder")
("crd" . "application/x-mscardfile")
("clp" . "application/x-msclip")
("exe" . "application/x-msdownload")
("mvb" . "application/x-msmediaview")
("wmf" . "application/x-msmetafile")
("mny" . "application/x-msmoney")
("pub" . "application/x-mspublisher")
("scd" . "application/x-msschedule")
("trm" . "application/x-msterminal")
("wri" . "application/x-mswrite")
("nc" . "application/x-netcdf")
("nzb" . "application/x-nzb")
("p12" . "application/x-pkcs12")
("p7b" . "application/x-pkcs7-certificates")
("p7r" . "application/x-pkcs7-certreqresp")
("rar" . "application/x-rar-compressed")
("ris" . "application/x-research-info-systems")
("sh" . "application/x-sh")
("shar" . "application/x-shar")
("swf" . "application/x-shockwave-flash")
("xap" . "application/x-silverlight-app")
("sql" . "application/x-sql")
("sit" . "application/x-stuffit")
("sitx" . "application/x-stuffitx")
("srt" . "application/x-subrip")
("sv4cpio" . "application/x-sv4cpio")
("sv4crc" . "application/x-sv4crc")
("t3" . "application/x-t3vm-image")
("gam" . "application/x-tads")
("tar" . "application/x-tar")
("tcl" . "application/x-tcl")
("tex" . "application/x-tex")
("tfm" . "application/x-tex-tfm")
("texinfo" . "application/x-texinfo")
("obj" . "application/x-tgif")
("ustar" . "application/x-ustar")
("src" . "application/x-wais-source")
("der" . "application/x-x509-ca-cert")
("fig" . "application/x-xfig")
("xlf" . "application/x-xliff+xml")
("xpi" . "application/x-xpinstall")
("xz" . "application/x-xz")
("z1" . "application/x-zmachine")
("xaml" . "application/xaml+xml")
("xdf" . "application/xcap-diff+xml")
("xenc" . "application/xenc+xml")
("xhtml" . "application/xhtml+xml")
("xml" . "application/xml")
("dtd" . "application/xml-dtd")
("xop" . "application/xop+xml")
("xpl" . "application/xproc+xml")
("xslt" . "application/xslt+xml")
("xspf" . "application/xspf+xml")
("mxml" . "application/xv+xml")
("yang" . "application/yang")
("yin" . "application/yin+xml")
("zip" . "application/zip")
("adp" . "audio/adpcm")
("au" . "audio/basic")
("mid" . "audio/midi")
("mp4a" . "audio/mp4")
("m4a" . "audio/mp4a-latm")
("mpga" . "audio/mpeg")
("oga" . "audio/ogg")
("s3m" . "audio/s3m")
("sil" . "audio/silk")
("uva" . "audio/vnd.dece.audio")
("eol" . "audio/vnd.digital-winds")
("dra" . "audio/vnd.dra")
("dts" . "audio/vnd.dts")
("dtshd" . "audio/vnd.dts.hd")
("lvp" . "audio/vnd.lucent.voice")
("pya" . "audio/vnd.ms-playready.media.pya")
("ecelp4800" . "audio/vnd.nuera.ecelp4800")
("ecelp7470" . "audio/vnd.nuera.ecelp7470")
("ecelp9600" . "audio/vnd.nuera.ecelp9600")
("rip" . "audio/vnd.rip")
("weba" . "audio/webm")
("aac" . "audio/x-aac")
("aif" . "audio/x-aiff")
("caf" . "audio/x-caf")
("flac" . "audio/x-flac")
("mka" . "audio/x-matroska")
("m3u" . "audio/x-mpegurl")
("wax" . "audio/x-ms-wax")
("wma" . "audio/x-ms-wma")
("ram" . "audio/x-pn-realaudio")
("rmp" . "audio/x-pn-realaudio-plugin")
("wav" . "audio/x-wav")
("xm" . "audio/xm")
("cdx" . "chemical/x-cdx")
("cif" . "chemical/x-cif")
("cmdf" . "chemical/x-cmdf")
("cml" . "chemical/x-cml")
("csml" . "chemical/x-csml")
("xyz" . "chemical/x-xyz")
("bmp" . "image/bmp")
("cgm" . "image/cgm")
("g3" . "image/g3fax")
("gif" . "image/gif")
("ief" . "image/ief")
("jp2" . "image/jp2")
("jpeg" . "image/jpeg")
("ktx" . "image/ktx")
("pict" . "image/pict")
("png" . "image/png")
("btif" . "image/prs.btif")
("sgi" . "image/sgi")
("svg" . "image/svg+xml")
("tiff" . "image/tiff")
("psd" . "image/vnd.adobe.photoshop")
("uvi" . "image/vnd.dece.graphic")
("sub" . "image/vnd.dvb.subtitle")
("djvu" . "image/vnd.djvu")
("dwg" . "image/vnd.dwg")
("dxf" . "image/vnd.dxf")
("fbs" . "image/vnd.fastbidsheet")
("fpx" . "image/vnd.fpx")
("fst" . "image/vnd.fst")
("mmr" . "image/vnd.fujixerox.edmics-mmr")
("rlc" . "image/vnd.fujixerox.edmics-rlc")
("mdi" . "image/vnd.ms-modi")
("wdp" . "image/vnd.ms-photo")
("npx" . "image/vnd.net-fpx")
("wbmp" . "image/vnd.wap.wbmp")
("xif" . "image/vnd.xiff")
("webp" . "image/webp")
("3ds" . "image/x-3ds")
("ras" . "image/x-cmu-raster")
("cmx" . "image/x-cmx")
("fh" . "image/x-freehand")
("ico" . "image/x-icon")
("pntg" . "image/x-macpaint")
("sid" . "image/x-mrsid-image")
("pcx" . "image/x-pcx")
("pic" . "image/x-pict")
("pnm" . "image/x-portable-anymap")
("pbm" . "image/x-portable-bitmap")
("pgm" . "image/x-portable-graymap")
("ppm" . "image/x-portable-pixmap")
("qtif" . "image/x-quicktime")
("rgb" . "image/x-rgb")
("tga" . "image/x-tga")
("xbm" . "image/x-xbitmap")
("xpm" . "image/x-xpixmap")
("xwd" . "image/x-xwindowdump")
("eml" . "message/rfc822")
("igs" . "model/iges")
("msh" . "model/mesh")
("dae" . "model/vnd.collada+xml")
("dwf" . "model/vnd.dwf")
("gdl" . "model/vnd.gdl")
("gtw" . "model/vnd.gtw")
("mts" . "model/vnd.mts")
("vtu" . "model/vnd.vtu")
("wrl" . "model/vrml")
("x3db" . "model/x3d+binary")
("x3dv" . "model/x3d+vrml")
("x3d" . "model/x3d+xml")
("manifest" . "text/cache-manifest")
("appcache" . "text/cache-manifest")
("ics" . "text/calendar")
("css" . "text/css")
("csv" . "text/csv")
("html" . "text/html")
("n3" . "text/n3")
("txt" . "text/plain")
("dsc" . "text/prs.lines.tag")
("rtx" . "text/richtext")
("sgml" . "text/sgml")
("tsv" . "text/tab-separated-values")
("t" . "text/troff")
("ttl" . "text/turtle")
("uri" . "text/uri-list")
("vcard" . "text/vcard")
("curl" . "text/vnd.curl")
("dcurl" . "text/vnd.curl.dcurl")
("scurl" . "text/vnd.curl.scurl")
("mcurl" . "text/vnd.curl.mcurl")
("sub" . "text/vnd.dvb.subtitle")
("fly" . "text/vnd.fly")
("flx" . "text/vnd.fmi.flexstor")
("gv" . "text/vnd.graphviz")
("3dml" . "text/vnd.in3d.3dml")
("spot" . "text/vnd.in3d.spot")
("jad" . "text/vnd.sun.j2me.app-descriptor")
("wml" . "text/vnd.wap.wml")
("wmls" . "text/vnd.wap.wmlscript")
("s" . "text/x-asm")
("c" . "text/x-c")
("f" . "text/x-fortran")
("java" . "text/x-java-source")
("opml" . "text/x-opml")
("p" . "text/x-pascal")
("nfo" . "text/x-nfo")
("etx" . "text/x-setext")
("sfv" . "text/x-sfv")
("uu" . "text/x-uuencode")
("vcs" . "text/x-vcalendar")
("vcf" . "text/x-vcard")
("3gp" . "video/3gpp")
("3g2" . "video/3gpp2")
("h261" . "video/h261")
("h263" . "video/h263")
("h264" . "video/h264")
("jpgv" . "video/jpeg")
("jpm" . "video/jpm")
("mj2" . "video/mj2")
("ts" . "video/mp2t")
("mp4" . "video/mp4")
("mpeg" . "video/mpeg")
("ogv" . "video/ogg")
("qt" . "video/quicktime")
("uvh" . "video/vnd.dece.hd")
("uvm" . "video/vnd.dece.mobile")
("uvp" . "video/vnd.dece.pd")
("uvs" . "video/vnd.dece.sd")
("uvv" . "video/vnd.dece.video")
("dvb" . "video/vnd.dvb.file")
("fvt" . "video/vnd.fvt")
("mxu" . "video/vnd.mpegurl")
("pyv" . "video/vnd.ms-playready.media.pyv")
("uvu" . "video/vnd.uvvu.mp4")
("viv" . "video/vnd.vivo")
("dv" . "video/x-dv")
("webm" . "video/webm")
("f4v" . "video/x-f4v")
("fli" . "video/x-fli")
("flv" . "video/x-flv")
("m4v" . "video/x-m4v")
("mkv" . "video/x-matroska")
("mng" . "video/x-mng")
("asf" . "video/x-ms-asf")
("vob" . "video/x-ms-vob")
("wm" . "video/x-ms-wm")
("wmv" . "video/x-ms-wmv")
("wmx" . "video/x-ms-wmx")
("wvx" . "video/x-ms-wvx")
("avi" . "video/x-msvideo")
("movie" . "video/x-sgi-movie")
("smv" . "video/x-smv")
("ice" . "x-conference/x-cooltalk")))

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

;; procedures provided:
;; ====================
;; seconds->isodate
;; seconds->wwdate
;;
;; isodate->seconds
;; isodate->wwdate
;;
;; wwdate->seconds
;; wwdate->isodate

;; srfi-19 used extensively; this doc is better tha the eggref:
;; http://srfi.schemers.org/srfi-19/srfi-19.html

;; Author: brandon.j.barclay@intel.com 16ww18.6

(define (date->seconds date)
  (inexact->exact
   (string->number
    (date->string date "~s"))))

(define (seconds->isodate seconds)
  (let* ((date (seconds->date seconds))
         (result (date->string date "~Y-~m-~d")))
    result))

(define (isodate->seconds isodate)
  "Takes a string input of the form 'YY-MM-DD' or 'YYYY-MM-DD' and returns epoch time; for YY, assume after Y2K"
  (let* ((numlist (map string->number (string-split isodate "-")))
        (raw-year (car numlist))
        (year (if (< raw-year 100) (+ raw-year 2000) raw-year))
        (month (list-ref numlist 1))
        (day (list-ref numlist 2))
        (date (make-date 0 0 0 0 day month year))
        (seconds (date->seconds date)))

    seconds))

;; adapted from perl Intel::WorkWeek perl module
;; workweek year consists of numbered weeks starting from week 1
;;   days of week are numbered starting from 0 on sunday
;;   weeks begin on sunday- day number 0 and end saturday- day 6
;;   week 1 is defined as the week containing jan 1 of the year
;;   workweek year does not match calendar year in workweek 1
;;     since workweek 1 contains jan1 and workweek begins sunday,
;;     days prior to jan1 in workweek 1 belong to the next workweek year
(define (seconds->wwdate-values seconds)
  (define (date-difference->seconds d1 d2)
    (- (date->seconds d1) (date->seconds d2)))

  (let* ((thisdate (seconds->date seconds))
         (thisdow (string->number (date->string thisdate "~w")))

         (year (date-year thisdate))
         ;; intel workweek 1 begins on sunday of week containing jan1
         (jan1 (make-date 0 0 0 0 1 1 year))
         (jan1dow (date-week-day jan1))
         (ww01 (date-subtract-duration jan1 (seconds->time (* 60 60 24 jan1dow))))

         (ww01_delta_seconds (date-difference->seconds thisdate ww01))
         (wwnum_initial (inexact->exact (add1 (floor (/ ww01_delta_seconds 24 3600 7) ))))
         
         ;; we could be in ww1 of next year
         (this-saturday (seconds->date
                         (+ seconds
                            (* 60 60 24 (- 6 thisdow)))))
         (this-week-ends-next-year?
          (> (date-year this-saturday) year))
         (intelyear
          (if this-week-ends-next-year?
              (add1 year)
              year))
         (intelweek
          (if this-week-ends-next-year?
              1
              wwnum_initial)))
   (values intelyear intelweek thisdow)))

(define (string-leftpad in width pad-char)
  (let* ((unpadded-str (->string in))
         (padlen_temp (- width (string-length unpadded-str)))
         (padlen (if (< padlen_temp 0) 0 padlen_temp))
         (padding (make-string padlen pad-char)))
    (conc padding unpadded-str)))

(define (string-rightpad in width pad-char)
  (let* ((unpadded-str (->string in))
         (padlen_temp (- width (string-length unpadded-str)))
         (padlen (if (< padlen_temp 0) 0 padlen_temp))
         (padding (make-string padlen pad-char)))
    (conc unpadded-str padding)))

(define (zeropad num width)
  (string-leftpad num width #\0))

(define (seconds->wwdate seconds)

  (let-values (((intelyear intelweek day-of-week-num)
                (seconds->wwdate-values seconds)))
    (let ((intelyear-str
           (zeropad
            (->string
             (if (> intelyear 1999)
                 (- intelyear 2000) intelyear))
            2))
          (intelweek-str
           (zeropad (->string intelweek) 2))
          (dow-str (->string day-of-week-num)))
      (conc intelyear-str "ww" intelweek-str "." dow-str))))

(define (isodate->wwdate isodate)
  (seconds->wwdate
   (isodate->seconds isodate)))

(define (wwdate->seconds wwdate)
  (let ((match (string-match "^(\\d+)ww(\\d+).(\\d)$" wwdate)))
    (if
     (not match)
     #f
     (let* (
            (intelyear-raw (string->number (list-ref match 1)))
            (intelyear (if (< intelyear-raw 100)
                           (+ intelyear-raw 2000)
                           intelyear-raw))
            (intelww (string->number (list-ref match 2)))
            (dayofweek (string->number (list-ref match 3)))

            (day-of-seconds (* 60 60 24 ))
            (week-of-seconds (* day-of-seconds 7))
            

            ;; get seconds at ww1.0
            (new-years-date (make-date 0 0 0 0 1 1 intelyear))
            (new-years-seconds
             (date->seconds new-years-date))
            (new-years-dayofweek (date-week-day new-years-date))
            (ww1.0_seconds (- new-years-seconds
                              (* day-of-seconds
                                 new-years-dayofweek)))
            (workweek-adjustment (* week-of-seconds (sub1 intelww)))
            (weekday-adjustment (* dayofweek day-of-seconds))

            (result (+ ww1.0_seconds workweek-adjustment weekday-adjustment)))
       result))))

(define (wwdate->isodate wwdate)
  (seconds->isodate (wwdate->seconds wwdate)))

(define (current-wwdate)
  (seconds->wwdate (current-seconds)))

(define (current-isodate)
  (seconds->isodate (current-seconds)))

(define (wwdate-tests)
  (test-group
   "date conversion tests"
   (let ((test-table
          '(("16ww01.5" . "2016-01-01")
            ("16ww18.5" . "2016-04-29")
            ("1999ww33.5" . "1999-08-13")
            ("16ww18.4" . "2016-04-28")
            ("16ww18.3" . "2016-04-27")
            ("13ww01.0" . "2012-12-30")
            ("13ww52.6" . "2013-12-28")
            ("16ww53.3" . "2016-12-28"))))
     (for-each
      (lambda (test-pair)
        (let ((wwdate (car test-pair))
              (isodate (cdr test-pair)))
          (test
           (conc "(isodate->wwdate "isodate ") => "wwdate)
           wwdate
           (isodate->wwdate isodate))
          
          (test
           (conc "(wwdate->isodate "wwdate ")   => "isodate)
           isodate
           (wwdate->isodate wwdate))))
      test-table))))


(define (ext->mimetype ext)
  (let ((x (assoc ext ducttape_ext2mimetype)))
   (if x (cdr x) "text/plain")))

  
  (define ducttape-lib-version 1.00)
  (define (toplevel-command sym proc) (lambda () #f))

  ;; like shell "which" command
  (define (find-exe exe)
    (let* ((path-items
            (string-split
             (or
              (get-environment-variable "PATH") "")
             ":")))

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


  
;;;; define some handy globals
  ;; resolve fullpath to this script or binary.
  (define (__get-this-script-fullpath #!key (argv (argv)))
    (let* ((this-script
            (cond
             ((and (> (length argv) 2)
                   (string-match "^(.*/csi|csi)$" (car argv))
                   (string-match "^-(s|ss|sx|script)$" (cadr argv)))
              (caddr argv))
             (else (car argv))))
           
           ;;(foo (begin (print "hello "(find-exe "/bin/sh") #f)))
           (fullpath (or (find-exe this-script) (realpath this-script))))
      fullpath))
  
  (define *this-exe-fullpath* (__get-this-script-fullpath))
  (define *this-exe-dir*      (pathname-directory *this-exe-fullpath*))
  (define *this-exe-name*     (pathname-strip-directory *this-exe-fullpath*))
  

;;;; utility procedures


  
  ;; begin credit: megatest's process.scm
  (define (port->list fh )
    (if (eof-object? fh) #f
        (let loop ((curr (read-line fh))
                   (result '()))
          (if (not (eof-object? curr))
              (loop (read-line fh)
                    (append result (list curr)))
              result))))

  (define (conservative-read port)
    (let loop ((res ""))
      (if (not (eof-object? (peek-char port)))
          (loop (conc res (read-char port)))
          res)))
  ;; end credit: megatest's process.scm

  (define (counter-maker)
    (let ((acc 0))
      (lambda ( #!optional (increment 1) )
        (set! acc (+ increment acc))
        acc)))

  (define (port->string port #!optional ) ; todo - add newline 
    (let ((linelist (port->list port)))
      (if linelist
          (string-join linelist "\n")
          "")))


  (define (outport->foreach outport foreach-thunk)
    (let loop ((line (foreach-thunk)))
      (if line
          (begin
            (write-line line outport)
            (loop (foreach-thunk))
            )
          (begin
            ;;http://bugs.call-cc.org/ticket/766
            ;;close-[input|output]-port implicitly calling process-wait on process pipe ports. This leads to errors like
            ;;Error: (process-wait) waiting for child process failed - No child processes: 10872
            (close-output-port outport)
            #f))))
  
  ;; weird - alist-ref arg order changes signature csc vs. csi... explitly defining.
  (define (my-alist-ref key alist)
    (let ((res (assoc key alist)))
      (if res (cdr res) #f)))

  (define (keyword-skim-alist args alist)
    (let loop ((result-alist '()) (result-args args) (rest-alist alist))
      (cond
       ((null? rest-alist) (values result-alist result-args))
       (else
        (let ((keyword (caar rest-alist))
              (defval (cdar rest-alist)))
          (let-values (((kwval result-args2)
                        (keyword-skim
                         keyword
                         defval
                         result-args)))
            (loop
             (cons (cons keyword kwval) result-alist)
             result-args2
             (cdr rest-alist))))))))
  
  (define (isys command . rest-args)
    (let-values
        (((opt-alist args)
          (keyword-skim-alist
           rest-args
           '( ( foreach-stdout-thunk: . #f )
              ( foreach-stdin-thunk: . #f )
              ( stdin-proc: . #f ) ) )))
      (let* ((foreach-stdout-thunk
              (my-alist-ref foreach-stdout-thunk: opt-alist))
             (foreach-stdin-thunk
              (my-alist-ref foreach-stdin-thunk: opt-alist))
             (stdin-proc
              (if foreach-stdin-thunk
                  (lambda (port)
                    (outport->foreach port foreach-stdin-thunk))
                  (my-alist-ref stdin-proc: opt-alist))))

        ;; TODO: support command is list.
        
        (let-values (((stdout stdin pid stderr)
                      (if (null? args)
                          (process* command)
                          (process* command args))))
          
                                        ;(if foreach-stdin-thunk
                                        ;    (set! stdin-proc
                                        ;          (lambda (port)
                                        ;            (outport->foreach port foreach-stdin-thunk))))
          
          (if stdin-proc
              (stdin-proc stdin))
          
          (let ((stdout-res 
                 (if foreach-stdout-thunk  ;; don't accumulate stdout if we have a thunk; probably doing this because stdout is BIG so lets not waste memory
                     (begin
                       (port-for-each foreach-stdout-thunk (lambda () (read-line stdout)))
                       "foreach-stdout-thunk ate stdout"
                       )
                     (if stdin-proc
                         "foreach-stdin-thunk/stdin-proc blocks stdout"
                         (port->string stdout))))
                (stderr-res
                 (if stdin-proc
                     "foreach-stdin-thunk/stdin-proc blocks stdout"
                     (port->string stderr))))

            ;; if we've used a stdin-proc, we've closed stdin port, which unfortunately causes a wait-pid internally, causing stdout and stderr ports to auto-close.  don't close them again.  (so sad - we lost stdout and stderr contents when we write to stdin)
            ;; see - http://bugs.call-cc.org/ticket/766
            (if (not stdin-proc)
                (close-input-port stdout)
                (close-input-port stderr))
            
            (let-values (((anotherpid normalexit? exitstatus)  (process-wait pid)))
              (values exitstatus stdout-res stderr-res)))))))
  
  (define (do-or-die command   #!key nodie (foreach-stdout #f) (stdin-proc #f))
    (let-values (((exit-code stdout-str stderr-str) (isys command foreach-stdout-thunk: foreach-stdout stdin-proc: stdin-proc )))
      (if (equal? 0 exit-code)
          stdout-str
          (begin
            (ierr (conc "Command  > " command " "  "< failed with " exit-code " because: \n" stderr-str) )
            (if nodie #f (exit exit-code))))))


  ;; runs-ok: evaluate expression while suppressing exceptions.
                                        ;    on caught exception, returns #f
                                        ;    otherwise, returns expression value
  (define (runs-ok thunk)
    (handle-exceptions exn #f (begin (thunk) #t)))

  ;; concat-lists: result list = lista + listb
  (define (concat-lists lista listb) ;; ok, I just reimplemented append...
    (foldr cons listb lista))
  

;;; setup general_lib env var parameters

  ;; show warning/note/error/debug prefixes using ansi colors
  (define ducttape-color-mode
    (make-parameter (get-environment-variable "DUCTTAPE_COLORIZE")))

  ;; if defined, has number value.  if number value > 0, show debug messages
  ;; value should be decremented in subshells -- idea is raising debug level will show debug messages deeper and deeper in process call stack
  (define ducttape-debug-level
    (make-parameter
     (let ( (raw-debug-level (get-environment-variable "DUCTTAPE_DEBUG_LEVEL")) )
       (if raw-debug-level
           (let ((num-debug-level (runs-ok (string->number raw-debug-level))))
             (if (integer? num-debug-level)
                 (begin
                   (let ((new-num-debug-level (- num-debug-level 1)))
                     (if (> new-num-debug-level 0) ;; decrement
                         (setenv "DUCTTAPE_DEBUG_LEVEL" (number->string new-num-debug-level))
                         (unsetenv "DUCTTAPE_DEBUG_LEVEL")))
                   num-debug-level) ; it was set and > 0, mode is value
                 (begin
                   (unsetenv "DUCTTAPE_DEBUG_LEVEL") ;; value was invalid, unset it
                   #f))) ; value was invalid, mode is f
           #f)))) ; var not set, mode is f


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

  ;; ducttape-debug-regex-filter suppresses non-matching debug messages
  (define ducttape-debug-regex-filter
    (make-parameter
     (let ((raw-debug-pattern (get-environment-variable "DUCTTAPE_DEBUG_PATTERN")))
       (if raw-debug-pattern
           raw-debug-pattern
           "."))))

  ;; silent mode suppresses Note and Warning type messages
  (define ducttape-silent-mode
    (make-parameter (get-environment-variable "DUCTTAPE_SILENT_MODE")))

  ;; quiet mode suppresses Note type messages
  (define ducttape-quiet-mode
    (make-parameter (get-environment-variable "DUCTTAPE_QUIET_MODE")))

  ;; if log file is defined, warning/note/error/debug messages are appended
  ;; to named logfile.
  (define ducttape-log-file
    (make-parameter (get-environment-variable "DUCTTAPE_LOG_FILE")))




  
  
;;; standard messages printing implementation

                                        ; get the name of the current script/binary being run
  (define (script-name)
    (car (reverse (string-split (car (argv)) "/"))))

  (define (ducttape-timestamp)
    (rfc3339->string (time->rfc3339 (seconds->local-time))))


  (define (iputs-preamble msg-type #!optional (suppress-color #f))
    (let ((do-color (and
                     (not suppress-color)
                     (ducttape-color-mode)
                     (terminal-port? (current-error-port)))))
      (case msg-type
        ((note)
         (if do-color
             (set-text (list 'fg-green 'bg-black 'bold) "Note:")
             "Note:"
             ))
        ((warn)
         (if do-color
             (set-text (list 'fg-yellow 'bg-black 'bold) "Warning:")
             "Warning:"
             ))
        ((err)
         (if do-color
             (set-text (list 'fg-red 'bg-black 'bold) "Error:")
             "Error:"
             ))
        ((dbg)
         (if do-color
             (set-text (list 'fg-blue 'bg-magenta) "Debug:")
             "Debug:"
             )))))

  (define (ducttape-append-logfile msg-type message #!optional (suppress-preamble #f))
    (let
        ((txt 
          (string-join 
           (list 
            (ducttape-timestamp) 
            (script-name)
            (if suppress-preamble
                message
                (string-join  (list (iputs-preamble msg-type #t) message) " ")))
           " | ")))

      (if (ducttape-log-file)
          (runs-ok
           (call-with-output-file (ducttape-log-file)
             (lambda (output-port)
               (format output-port "~A ~%" txt)
               )
             #:append))
          #t)))

  (define (ducttape-activate-logfile #!optional (logfile #f))
    ;; from python ducttape-lib.py
                                        ; message = "START - pid=%d ppid=%d argv=(%s) pwd=%s user=%s host=%s"%(pid,ppid," ".join("'"+x+"'" for x in sys.argv),os.environ['PWD'],os.getenv('USER','nouser'),os.getenv('HOST','nohost') )
    (let ((pid (number->string (current-process-id)))
          (ppid (number->string (parent-process-id)))
          (argv 
           (string-join 
            (map 
             (lambda (x) 
               (string-join (list "\"" x "\"")  "" ))
             (argv))
            " "))
          (pwd (or (get-environment-variable "PWD") "nopwd"))
          (user (or (get-environment-variable "USER") "nouser"))
          (host (or (get-environment-variable "HOST") "nohost")))
      (if logfile
          (begin
            (ducttape-log-file logfile)
            (setenv "DUCTTAPE_LOG_FILE" (ducttape-log-file))))
      (ducttape-append-logfile 'note (format #f "START - pid=~A ppid=~A argv=(~A) pwd=~A user=~A host=~A" pid ppid argv pwd user host) #t)))         


  ;; log exit code
  (define (set-ducttape-log-exit-handler)
    (let ((orig-exit-handler (exit-handler)))
      (exit-handler 
       (lambda (exitcode) 
         (ducttape-append-logfile 'note (format #f "Exit ~A by sys.exit" exitcode) #t)
         (orig-exit-handler exitcode)))))


  (define (idbg first-message  . rest-args)
    (let* ((debug-level-threshold
            (if (> (length rest-args) 0) (car rest-args) 1))
           (message-list
            (if (> (length rest-args) 1)
                (cons first-message (cdr rest-args))
                (list first-message)) )
           (message (apply conc
                  (map ->string message-list))))

      (ducttape-append-logfile 'dbg message)
      (if (ducttape-debug-level)
          (if (<= debug-level-threshold (ducttape-debug-level))
              (if (string-search (ducttape-debug-regex-filter) message)
                  (begin 
                    (format (current-error-port) "~A ~A (~A)~%" (iputs-preamble 'dbg) message (script-name))))))))

  (define (ierr message-first  . message-rest)
    (let* ((message
            (apply conc
             (map ->string (cons message-first message-rest)))))
      (ducttape-append-logfile 'err message)
      (format (current-error-port) "~A ~A (~A)~%" (iputs-preamble 'err) message (script-name))))

  (define (iwarn message-first  . message-rest)
    (let* ((message
            (apply conc
             (map ->string (cons message-first message-rest)))))
      (ducttape-append-logfile 'warn message)
      (if (not (ducttape-silent-mode))
          (begin
            (format (current-error-port) "~A ~A (~A)~%" (iputs-preamble 'warn) message (script-name))))))

  (define (inote message-first  . message-rest)
    (let* ((message
            (apply conc
             (map ->string (cons message-first message-rest)))))
      (ducttape-append-logfile 'note message)
      (if (not (or (ducttape-silent-mode) (ducttape-quiet-mode)))
          (begin 
            (format (current-error-port) "~A ~A (~A)~%" (iputs-preamble 'note) message (script-name))))))

  
  (define (iputs kind message #!optional (debug-level-threshold 1))
    (cond
     ((member kind (string-split "NOTE/Note/note/n/N" "/")) (inote message))
     ((member kind (string-split "Error/ERROR/error/Err/ERR/err/E/e" "/")) (ierr message))
     ((member kind
              (string-split "Warning/WARNING/warning/Warn/WARN/warn/W/w" "/"))
      (iwarn message))
     ((member kind (string-split "Debug/DEBUG/debug/Dbg/DBG/dbg/D/d" "/"))
      (idbg message debug-level-threshold))))

  (define (mkdir-recursive path-so-far hier-list-to-create)
    (if (null? hier-list-to-create)
        path-so-far
        (let* ((next-hier-item (car hier-list-to-create))
               (rest-hier-items (cdr hier-list-to-create))
               (path-to-mkdir (string-concatenate (list path-so-far "/" next-hier-item))))
          (if (runs-ok (lambda () (create-directory path-to-mkdir)))
              (mkdir-recursive path-to-mkdir rest-hier-items)
              #f))))

                                        ; ::mkdir-if-not-exists::
                                        ; make a dir recursively if it does not 
                                        ; already exist.
                                        ; on success - returns path
                                        ; on fail - returns #f
  (define (mkdirp-if-not-exists the-dir)
    (let ( (path-list (string-split the-dir "/")))
      (mkdir-recursive "/" path-list)))

                                        ; ::mkdir-if-not-exists::
                                        ; make a dir recursively if it does not 
                                        ; already exist.
                                        ; on success - returns path
                                        ; on fail - returns #f


  (define (mkdirp-if-not-exists the-dir)
    (let ( (path-list (string-split the-dir "/")))
      (mkdir-recursive "/" path-list)))

  (define (dir-is-writable? the-dir)
    (let ((dummy-file (string-concatenate (list the-dir "/.dummyfile"))))
      (and
       (file-exists? the-dir)
       (cond 
        ((runs-ok (lambda ()(with-output-to-file dummy-file (lambda () (print "foo")))))
         (begin
           (runs-ok (lambda () (delete-file dummy-file) ))
           the-dir))
        (else #f)))))


  (define (get-tmpdir )
    (let* ((tmproot
            (dir-is-writable?
             (or 
              (get-environment-variable "TMPDIR") 
              "/tmp")))

           (user
            (or
             (get-environment-variable "USER")
             "USER_Envvar_not_set"))
           (tmppath
            (string-concatenate 
             (list tmproot "/env21-general-" user ))))

      (dir-is-writable?
       (mkdirp-if-not-exists
        tmppath))))

  (define (mktemp
           #!optional
           (prefix "general_lib_tmpfile")
           (dir #f))
    (let-values
        (((fd path) 
          (file-mkstemp 
           (conc 
            (if dir  dir  (get-tmpdir))
            "/" prefix ".XXXXXX"))))
      (close-output-port (open-output-file* fd))
      path))



  ;;http://stackoverflow.com/questions/11134857/using-sendmail-for-html-body-and-binary-attachment
  ;; write send-email using:
  ;;   - isys-foreach-stdin-line
  ;;   - formatting in http://stackoverflow.com/questions/11134857/using-sendmail-for-html-body-and-binary-attachment
  (define (sendmail to_addr subject body
                    #!key
                    (from_addr "admin")
                    cc_addr
                    bcc_addr
                    more-headers
                    use_html
                    (attach-files-list '())
                    (images-with-content-id-alist '())
                    )

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

      (define (get-uuid)
        (string-upcase (uuid->string (uuid-generate))))

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

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


        (define (email-mime-header)
          (wl (conc "From: " from_addr))
          (wl (conc "To: " to_addr))
          (if cc_addr
              (wl (conc "Cc: " cc_addr)))
          (if bcc_addr
              (wl (conc "Bcc: " bcc_addr)))
          (if more-headers
              (wl more-headers))
          (wl (conc "Subject: " subject))
          (wl "MIME-Version: 1.0")
          (wl (conc "Content-Type: multipart/mixed; boundary=\"" mailpart-uuid "\""))
          (wl "")
          (boundary)
          (wl (conc "Content-Type: multipart/alternative; boundary=\"" mailpart-body-uuid "\""))
          (wl "")
          )

        
        (define (email-text-body)
          (body-boundary)
          (wl "Content-Type: text/plain; charset=ISO-8859-1")
          (wl "Content-Disposition: inline")
          (wl "")
          (wl body)
          (body-boundary))
        
        (define (email-html-body)
          (body-boundary)
          (wl "Content-Type: text/plain; charset=ISO-8859-1")
          (wl "")
          (wl "You need to enable HTML option for email")
          (body-boundary)
          (wl "Content-Type: text/html; charset=ISO-8859-1")
          (wl "Content-Disposition: inline")
          (wl "")
          (wl body)
          (body-boundary))

        (define (attach-file file #!key (content-id #f))
          (let* ((filename
                  (filepath:take-file-name file))
                 (ext-with-dot
                  (filepath:take-extension file))
                 (ext (string-take-right
                       ext-with-dot
                       (- (string-length ext-with-dot) 1)))
                 (mimetype (ext->mimetype ext))
                 (uuencode-command (conc "uuencode " file " " filename)))
            (boundary)
            (wl (conc "Content-Type: " mimetype "; name=\"" filename "\""))
            (wl "Content-Transfer-Encoding: uuencode")
            (if content-id
                (wl (conc "Content-Id: " content-id)))
            (wl (conc "Content-Disposition: attachment; filename=\"" filename "\""))
            (wl "")
            (do-or-die
             uuencode-command
             foreach-stdout:
             (lambda (line)
               (wl line)))))

        (define (embed-image file+content-id)
          (let ((file (car file+content-id))
                (content-id (cdr file+content-id)))
            (attach-file file content-id: content-id)))
        
        ;; send the email
        (email-mime-header)
        (if use_html
            (email-html-body)
            (email-text-body))
        (for-each attach-file attach-files-list)
        (for-each embed-image images-with-content-id-alist)
        (boundary)
        (close-output-port sendmail-port)))
    
    (do-or-die "/usr/sbin/sendmail -t"
               stdin-proc: sendmail-proc))


;;;; process command line options

  ;; get command line switches (have no subsequent arg; eg. [-foo])
  ;;  assumes these are switches without arguments
  ;;  will return list of matches
  ;;  removes matches from command-line-arguments parameter
  (define (skim-cmdline-opts-noarg-by-regex switch-pattern)
    (let* (
           (irr (irregex switch-pattern))
           (matches (filter
                     (lambda (x)
                       (irregex-match irr x))
                     (command-line-arguments)))
           (non-matches (filter
                         (lambda (x)
                           (not (member x matches)))
                         (command-line-arguments))))

      (command-line-arguments non-matches)
      matches))

  (define (keyword-skim keyword default args #!optional (eqpred equal?))
    (let loop ( (kwval default) (args-remaining args) (args-to-return '()) )
      (cond 
       ((null? args-remaining)
        (values
         (if (list? kwval) (reverse kwval) kwval)
         (reverse args-to-return)))
       ((and (> (length args-remaining) 1) (eqpred keyword (car args-remaining)))
        (if (list? default)
            (if (equal? default kwval)
                (loop (list (cadr args-remaining)) (cddr args-remaining) args-to-return)
                (loop (cons (cadr args-remaining) kwval) (cddr args-remaining) args-to-return))
            (loop (cadr args-remaining) (cddr args-remaining) args-to-return)))
       (else (loop kwval (cdr args-remaining) (cons (car args-remaining) args-to-return))))))


  (define (get-cli-arg arg #!key (default #f) (is-list #f))
    (let* ((temp    (skim-cmdline-opts-withargs-by-regex arg)))
      (if (> (length temp) 0)
          (if is-list
              temp
              (car temp))
          default)))

  (define (get-cli-switch arg)
    (let ((temp (skim-cmdline-opts-noarg-by-regex arg)))
      (if (> (length temp) 0)
          (car temp)
          #f)))
  



  ;; get command line switches (have a subsequent arg; eg. [-foo bar])
  ;;  assumes these are switches without arguments
  ;;  will return list of arguments to matches
  ;;  removes matches from command-line-arguments parameter

  (define (re-match? re str)
    (irregex-match re str))

  (define (skim-cmdline-opts-withargs-by-regex switch-pattern)
    (let-values
        (((result new-cmdline-args)
          (keyword-skim switch-pattern
                        '()
                        (command-line-arguments)
                        re-match?
                        )))
      (command-line-arguments new-cmdline-args)
      result))
  
  

  ;; recognize ducttape-lib command line switches (--quiet, --silent, --color, -d.., -dp.., -logfile)
  ;;    - reset parameters; reset DUCTTAPE_* env vars to match user specified intent
  ;;    - mutate (command-line-arguments) parameter to subtract these recognized and handled switches
  ;;       * beware -- now (argv) and (command-line-arguments) are inconsistent... cannot mutate (argv) alas.  Use (command-line-arguments)
  ;; WARNING: this defines command line arguments that may clash with your program.  Only call this if you
  ;; are sure they can coexist.
  (define (ducttape-process-command-line)

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

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

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

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

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

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


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


  ;;; following code commented out; side effects not wanted on startup
  ;; immediately activate logfile (will be noop if logfile disabled)
  ;;(ducttape-activate-logfile)
  ;;(set-ducttape-log-exit-handler)
  
  ;; TODO: hook exception handler so we can log exception before we sign off.

  ;; handle command line immediately; 
  ;;(process-command-line)                    


  ) ; end module