Megatest

# 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 = autoload.scm dbi.scm 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)

#	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

# module dependencies
mofiles/stml2.o : mofiles/dbi.o
mofiles/dbi.o   : mofiles/autoload.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!)

;;     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.base)
(import (prefix sqlite3 sqlite3:) typed-records srfi-18 srfi-69
	md5 message-digest
	regex srfi-1)

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

)

;; optional alternate db setup
(define *available-db* (make-hash-table))
(import postgresql)(hash-table-set! *available-db* 'postgresql #t)

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

;; (use srfi-69 posix)
;; 
;; (declare (unit api))
;; (declare (uses rmt))
;; (declare (uses db))
;; (declare (uses tasks))

;; allow these queries through without starting a server
;;
(define api:read-only-queries
  '(get-key-val-pairs
    get-var
    get-keys

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

;;  strftime('%m/%d/%Y %H:%M:%S','now','localtime')
;; 
;; (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 format md5 message-digest srfi-18)
;; 
;; (declare (unit archive))
;; (declare (uses db))
;; (declare (uses common))
;; 
;; (include "common_records.scm")
;; (include "db_records.scm")
;; 
;;======================================================================
;; 
;;======================================================================

;; NOT CURRENTLY USED
;;
;; (define (archive:main linktree target runname testname itempath options)
;;   (let ((testdir (conc linktree "/" target "/" runname "/" testname "/" itempath))
;; 	(flavor  'plain) ;; type of machine to run jobs on
;; 	(maxload 1.5)   ;; max allowed load for this work
;; 	(adisks  (archive:get-archive-disks)))
;;     ;; get testdir size
;;     ;;   - hand off du to job mgr
;;     (if (and (common:file-exists? testdir)
;; 	     (file-writable? testdir))
;; 	(let* ((dused  (jobrunner:run-job 
;; 			flavor  ;; machine type
;; 			maxload ;; max allowed load
;; 			'()     ;; prevars - environment vars to set for the job
;; 			common:get-disk-space-used  ;; if a proc call it, if a string it is a unix command
;; 			(list testdir)))
;; 	       (apath  (archive:get-archive testname itempath dused)))
;; 	  (jobrunner:run-job
;; 	   flavor
;; 	   maxload
;; 	   '()
;; 	   archive:run-bup
;; 	   (list testdir apath))))))
	  
;; Get archive disks from megatest.config
;;
(define (archive:get-archive-disks)
  (let ((section (configf:get-section *configdat* "archive-disks")))
    (if section
	section

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

(require-library srfi-4 iup)
(import srfi-4 iup
	;; iup-pplot
	iup-glcanvas) ;; iup-web

(define (popup dlg . args)
  (apply show dlg #:modal? 'yes args)
  (destroy! dlg))

(define (properties ih)
  (popup (element-properties-dialog ih))
  'default)

(define dlg
  (dialog
    (vbox
      (hbox ; headline
        (fill)
        (frame (label " Inspect control and dialog classes "
                      fontsize: 15))
        (fill)
        margin: '0x0)

      (label "") 
      (label "Dialogs" fontsize: 12)
      (hbox
        (button "dialog"
                action: (lambda (self) (properties (dialog (vbox)))))
        (button "color-dialog"
                action: (lambda (self) (properties (color-dialog))))
        (button "file-dialog"
                action: (lambda (self) (properties (file-dialog))))
        (button "font-dialog"
                action: (lambda (self) (properties (font-dialog))))
        (button "message-dialog"
                action: (lambda (self) (properties (message-dialog))))
        (fill)
        margin: '0x0)
      (hbox
        (button "layout-dialog"
                action: (lambda (self) (properties (layout-dialog))))
        (button "element-properties-dialog"
                action: (lambda (self)
                          (properties
                            (element-properties-dialog (create 'user)))))
        (fill)
        margin: '0x0)

      (label "") 
      (label "Composition widgets" fontsize: 12)
      (hbox
        (button "fill"
                action: (lambda (self) (properties (fill))))
        (button "hbox"
                action: (lambda (self) (properties (hbox))))
        (button "vbox"
                action: (lambda (self) (properties (vbox))))
        (button "zbox"
                action: (lambda (self) (properties (zbox))))
        (button "radio"
                action: (lambda (self) (properties (radio (vbox)))))
        (button "normalizer"
                action: (lambda (self) (properties (normalizer))))
        (button "cbox"
                action: (lambda (self) (properties (cbox))))
        (button "sbox"
                action: (lambda (self) (properties (sbox (vbox)))))
        (button "split"
                action: (lambda (self) (properties (split (vbox) (vbox)))))
        (fill)
        margin: '0x0)

      (label "") 
      (label "Standard widgets" fontsize: 12)
      (hbox
        (button "button"
                action: (lambda (self) (properties (button))))
        (button "canvas"
                action: (lambda (self) (properties (canvas))))
        (button "frame"
                action: (lambda (self) (properties (frame))))
        (button "label"
                action: (lambda (self) (properties (label))))
        (button "listbox"
                action: (lambda (self) (properties (listbox))))
        (button "progress-bar"
                action: (lambda (self) (properties (progress-bar))))
        (button "spin"
                action: (lambda (self) (properties (spin))))
        (fill)
        margin: '0x0)
      (hbox
        (button "tabs"
                action: (lambda (self) (properties (tabs))))
        (button "textbox"
                action: (lambda (self) (properties (textbox))))
        (button "toggle"
                action: (lambda (self) (properties (toggle))))
        (button "treebox"
                action: (lambda (self) (properties (treebox))))
        (button "valuator"
                action: (lambda (self) (properties (valuator ""))))
        (fill)
        margin: '0x0)

      (label "") 
      (label "Additional widgets" fontsize: 12)
      (hbox
        (button "cells"
                action: (lambda (self) (properties (cells))))
        (button "color-bar"
                action: (lambda (self) (properties (color-bar))))
        (button "color-browser"
                action: (lambda (self) (properties (color-browser))))
        (button "dial"
                action: (lambda (self) (properties (dial ""))))
        (button "matrix"
                action: (lambda (self) (properties (matrix))))
        (fill)
        margin: '0x0)
      (hbox
        #;(button "pplot"
                action: (lambda (self) (properties (pplot))))
        (button "glcanvas"
                action: (lambda (self) (properties (glcanvas))))
        ;; (button "web-browser"
        ;;         action: (lambda (self) (properties (web-browser))))
        (fill)
        margin: '0x0)

      (label "") 
      (label "Menu widgets" fontsize: 12)
      (hbox
        (button "menu"
                action: (lambda (self) (properties (menu))))
        (button "menu-item"
                action: (lambda (self) (properties (menu-item))))
        (button "menu-separator"
                action: (lambda (self) (properties (menu-separator))))
        (fill)
        margin: '0x0)

      (label "") 
      (label "Images" fontsize: 12)
      (hbox
        (button "image/palette"
                action: (lambda (self)
                          (properties
                            (image/palette 1 1 (u8vector->blob (u8vector 0))))))
        (button "image/rgb"
                action: (lambda (self)
                          (properties
                            (image/rgb 1 1 (u8vector->blob (u8vector 0))))))
        (button "image/rgba"
                action: (lambda (self)
                          (properties
                            (image/rgba 1 1 (u8vector->blob (u8vector 0))))))
        (button "image/file"
                action: (lambda (self)
                          (properties
                            ;; same attributes as image/palette
                            (image/palette 1 1 (u8vector->blob (u8vector 0))))))
                            ;; needs a file in current directory
                            ;(image/file "chicken.ico")))) ; ok
                            ;(image/file "chicken.png")))) ; doesn't work
        (fill)
        margin: '0x0)

      (label "") 
      (label "Other widgets" fontsize: 12)
      (hbox
        (button "clipboard"
                action: (lambda (self) (properties (clipboard))))
        (button "timer"
                action: (lambda (self) (properties (timer))))
        (button "spinbox"
                action: (lambda (self) (properties (spinbox (vbox)))))
        (fill)
        margin: '0x0)

      (fill)
      (button "E&xit"
              expand: 'horizontal
              action: (lambda (self) 'close))
      )
    margin: '15x15
    title: "Iup inspector"))

(show dlg)
(main-loop)
(exit 0)

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

(include "autoload/autoload.scm")

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

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

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

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

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

(module autoload (autoload)

(import scheme (chicken base))

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

)

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

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

(define (call-with-environment-variables variables thunk)
  @("Sets up environment variable via dynamic-wind which are taken down after thunk."
    (variables "An alist of the form {{'((\"var\" . \"value\") ...)}}")
    (thunk "The thunk to execute with a modified environment"))
  (let ((pre-existing-variables
         (map (lambda (var-value)
                (let ((var (car var-value)))
                  (cons var (get-environment-variable var))))
              variables)))
    (dynamic-wind
        (lambda () (void))
        (lambda ()
;;           (use posix)
          (for-each (lambda (var-value)
                      (setenv (car var-value) (cdr var-value)))
            variables)
          (thunk))
        (lambda ()
          (for-each (lambda (var-value)
                      (let ((var (car var-value))
                            (value (cdr var-value)))
                        (if value
                            (setenv var value)
                            (unsetenv var))))
            pre-existing-variables)))))

((synopsis "Set up and take down environment vars")
 (author "Peter Danenberg")
 (email "pcd@roxygen.org")
 (user "klutometis")
 (repo "https://github.com/klutometis/call-with-environment-variables")
 (category os)
 (license "BSD")
 (depends (hahn "0.9.3")
          setup-helper)
 (test-depends test)
 (foreign-depends))

(repo git "git://github.com/klutometis/{egg-name}.git")
(uri targz "https://github.com/klutometis/{egg-name}/tarball/{egg-release}")
(release "0.1")
(release "0.1.1")
(release "0.1.2")
(release "0.1.3")
(release "0.1.4")
(release "0.1.5")
(release "0.1.6")
(release "0.1.7")

(module
 call-with-environment-variables
 (call-with-environment-variables)

 (import scheme
	 chicken.base
	 chicken.process-context
	 )

 (include "call-with-environment-variables/call-with-environment-variables-core.scm"))

(use hahn setup-helper-mod)

(verify-extension-name "call-with-environment-variables")

(setup-shared-extension-module
 'call-with-environment-variables
 (extension-version "0.1.6")
 compile-options: '(-X hahn))

(run-hahn -o call-with-environment-variables.wiki call-with-environment-variables-core.scm)

== call-with-environment-variables

Set up and take down environment vars
[[toc:]]
=== {{call-with-environment-variables}}
<procedure>(call-with-environment-variables variables thunk) → unspecified</procedure>
Sets up environment variable via dynamic-wind which are taken down after thunk.
; {{variables}} : An alist of the form {{'(("var" . "value") ...)}}
; {{thunk}} : The thunk to execute with a modified environment
<enscript highlight="scheme">(define (call-with-environment-variables variables thunk)
  (let ((pre-existing-variables
          (map (lambda (var-value)
                 (let ((var (car var-value)))
                   (cons var (get-environment-variable var))))
               variables)))
    (dynamic-wind
      (lambda () (void))
      (lambda ()
        (use posix)
        (for-each
          (lambda (var-value) (setenv (car var-value) (cdr var-value)))
          variables)
        (thunk))
      (lambda ()
        (for-each
          (lambda (var-value)
            (let ((var (car var-value)) (value (cdr var-value)))
              (if value (setenv var value) (unsetenv var))))
          pre-existing-variables)))))
</enscript>
=== About this egg

==== Author

[[/users/klutometis|Peter Danenberg]]
==== Repository
[[https://github.com/klutometis/call-with-environment-variables]]
==== License
BSD
==== Dependencies
* [[(hahn 0.9.3)]]
* [[setup-helper]]

==== Versions
; [[https://github.com/klutometis/call-with-environment-variables/releases/tag/0.1|0.1]] : Initial release
; [[https://github.com/klutometis/call-with-environment-variables/releases/tag/0.1.1|0.1.1]] : Add the actual code.
; [[https://github.com/klutometis/call-with-environment-variables/releases/tag/0.1.2|0.1.2]] : Fix versions.
; [[https://github.com/klutometis/call-with-environment-variables/releases/tag/0.1.3|0.1.3]] : Update docs.
; [[https://github.com/klutometis/call-with-environment-variables/releases/tag/0.1.4|0.1.4]] : With a note about cock-utils
; [[https://github.com/klutometis/call-with-environment-variables/releases/tag/0.1.5|0.1.5]] : Docs
; [[https://github.com/klutometis/call-with-environment-variables/releases/tag/0.1.6|0.1.6]] : Use hahn.
==== Colophon

Documented by [[/egg/hahn|hahn]].

;;     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 pgdb))
;; (declare (uses configf))
;; 
;; ;; I don't know how to mix compilation units and modules, so no module here.
;; ;;
;; ;; (module pgdb
;; ;;     (
;; ;;      open-pgdb
;; ;;      )
;; ;; 
;; ;; (import scheme)
;; ;; (import data-structures)
;; ;; (import chicken)
;; 
;; (use typed-records (prefix dbi dbi:))

;; given a configdat lookup the connection info and open the db
;;
(define (pgdb:open configdat #!key (dbname #f)(dbispec #f))  
  (let ((pgconf (or dbispec
		    (args:get-arg "-pgsync")
		    (if configdat

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

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

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

;; client:get-signature
(define (client:get-signature)
  (if *my-client-signature* *my-client-signature*
      (let ((sig (conc (get-host-name) " " (current-process-id))))
	(set! *my-client-signature* sig)
	*my-client-signature*)))

			  (thread-sleep! 1)
			  (client:setup-http areapath remaining-tries: (- remaining-tries 1))
			  )))
		  (begin    ;; no server registered
		    ;; (server:kind-run areapath)
		    (server:start-and-wait areapath)
		    (debug:print-info 0 *default-log-port* "client:setup, no server registered, remaining-tries=" remaining-tries)
		    (thread-sleep! 1) ;; (+ 5 (pseudo-random-integer (- 20 remaining-tries))))  ;; give server a little time to start up, randomize a little to avoid start storms.
		    (client:setup-http areapath remaining-tries: (- remaining-tries 1)))))))))

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

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

;; (use srfi-1 data-structures posix regex-case (prefix base64 base64:)
;;      format dot-locking csv-xml z3 udp ;; sql-de-lite
;;      hostinfo md5 message-digest typed-records directory-utils stack
;;      matchable regex posix (srfi 18) extras ;; tcp 
;;      (prefix nanomsg nmsg:)
;;      (prefix sqlite3 sqlite3:)
;;      pkts (prefix dbi dbi:)

;;      )
;; 
;; (declare (unit common))
;; ;; (declare (uses commonmod))
;; ;; (import commonmod)
;; 
;; (include "common_records.scm")


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

;; (define old-exit exit)
;; 

(define *server-kind-run*   (make-hash-table))
(define *home-host*         #f)
;; (define *total-non-write-delay* 0)
(define *heartbeat-mutex*   (make-mutex))
(define *api-process-request-count* 0)
(define *max-api-process-requests* 0)
(define *server-overloaded*  #f)
(define *writes-total-delay*  0)

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

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

(define *launch-setup-mutex* (make-mutex))     ;; need to be able to call launch:setup often so mutex it and re-call the real deal only if *toppath* not set
(define *homehost-mutex*     (make-mutex))

;; Miscellaneous
(define *triggers-mutex*     (make-mutex))     ;; block overlapping processing of triggers
(define *numcpus-cache* (make-hash-table))

;; (use posix-extras pathname-expand files)

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

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

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

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

(define (common:get-linktree)
  (or (getenv "MT_LINKTREE")
      (if *configdat*
	  (configf:lookup *configdat* "setup" "linktree")

				   (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-writable? *toppath*)
				     (begin
				       (with-output-to-file hhf
					 (lambda ()
					   (print bestadrs)))
				       (begin
					 (mutex-unlock! *homehost-mutex*)
					 (car (common:get-homehost))))

  (if *toppath*
      (let* ((fullpath (conc *toppath* "/.sysdata/" key "-" dtype ".log"))
	     (delfile  (lambda (exn)
			 (debug:print-info 1 *default-log-port* " removing bad file " fullpath ", exn=" exn)
			 (delete-file* fullpath)
			 #f)))
	(if (and (file-exists? fullpath)
		 (file-readable? 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)

         (hh     (if hh-dat (car hh-dat) #f)))
    (common:wait-for-normalized-load maxnormload msg hh)))

(define (common:get-num-cpus remote-host)
  (let* ((actual-host (or remote-host (get-host-name))))
    ;; hosts had better not be changing the number of cpus too often!
    (or (hash-table-ref/default *numcpus-cache* actual-host #f)
	(let* ((numcpus (or (common:get-cached-info actual-host "num-cpus" age: (+ 2592000 (pseudo-random-integer 3600)))
			    (let* ((proc   (lambda ()
					     (let loop ((numcpu 0)
							(inl    (read-line)))
					       (if (eof-object? inl)
						   (if (> numcpu 0)
						       numcpu
						       #f) ;; if zero return #f so caller knows that things are not working

;; wait for normalized cpu load to drop below maxload
;;
(define (common:wait-for-normalized-load maxnormload msg remote-host #!optional (rem-tries 5))
  (let ((num-cpus (common:get-num-cpus remote-host)))
    (if num-cpus
	(common:wait-for-cpuload maxnormload num-cpus 15 msg: msg remote-host: remote-host)
	(begin
	  (thread-sleep! (pseudo-random-integer 60)) ;; we failed to get num cpus. wait a bit and try again
	  (if (> rem-tries 0)
	      (common:wait-for-normalized-load maxnormload msg remote-host (- rem-tries 1))
	      #f)))))

;;======================================================================
;; DO NOT CALL THIS DIRECTLY. It is called from common:wait-for-normalized-load
;;   count     - count down to zero, at some point we'd give up if the load never drops

			", normalized effective load: " normalized-effective-load
			))
     ;; overloaded and count expired (i.e. went to zero)
     (else
      (if (> num-tries 0) ;; should be "num-tries-left". 
	  (if (common:low-noise-print 30 (conc (round effective-load) "-load-acceptable-" effective-host))
	      (debug:print 0 *default-log-port* "Load on " effective-host " is acceptable at effective normalized load of "
			   normalized-effective-load "  continuing."))
	  (debug:print 0 *default-log-port* "Load on " effective-host ", "
		       first" could not be retrieved. Giving up and continuing."))))))

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

;; 					       ;; 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 (pseudo-random-integer 10)) (abs (* (+ (pseudo-random-integer 10)
;; 								(/ (- 1000 count) 10)
;; 								waitdelay)
;; 							     (- first adjmaxload) ))))
;; 	 (load-jump-limit   (configf:lookup-number *configdat* "setup" "load-jump-limit"))
;; 	 ;; effective load accounts for load jumps, this should elminate all the first-next-avg, adjwait, load-jump-limit
;; 	 ;; etc.
;; 	 (effective-load    (common:get-intercept first next))
;; 	 (effective-host    (or remote-host "localhost"))
;; 	 (normalized-effective-load (/ effective-load numcpus))
;; 	 (will-wait                 (> normalized-effective-load maxload)))
;; 	 
;;     ;; 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"))) ;; (> (pseudo-random-integer 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))
;; 
;;     (debug:print-info 1 *default-log-port*
;; 		      "On host: " effective-host
;; 		      ", effective load: " effective-load
;; 		      ", numcpus: " numcpus

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

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

	     (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 (dtests:get-pre-command #!key (default-override #f))
  (let* ((orig-pre-command "export CMD='")
         (viewscreen-pre-command  "viewscreen ")
         (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen"))
         (default-pre-command (if use-viewscreen viewscreen-pre-command orig-pre-command))
         (cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command")))
    (or cfg-ovrd default-override default-pre-command))) ;; "xterm -geometry 180x20 -e \""))

  
(define (dtests:get-post-command #!key (default-override #f))
  (let* ((orig-post-command (conc "';xterm -geometry 180x20 -e \"(echo; echo -n START:;date +ww%U.%w-$H:%M:%S;echo;echo $CMD;echo;$CMD)|&"
                                 "tee -a runlog-`date +ww%U.%w-%H:%M`.log;echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))
         (viewscreen-post-command  "")
         (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen"))
         (default-post-command (if use-viewscreen viewscreen-post-command orig-post-command))
         (cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command")))
    (or cfg-ovrd default-override default-post-command))) ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))

;;======================================================================
;; (define *common:telemetry-log-state* 'startup)
;; (define *common:telemetry-log-socket* #f)
;; 
;; (define (common:telemetry-log-open)
;;   (if (eq? *common:telemetry-log-state* 'startup)
;;       (let* ((serverhost (configf:lookup *configdat* "telemetry" "host"))

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

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

;; (use regex regex-case matchable) ;;  directory-utils)
;; (declare (unit configf))
;; (declare (uses process))
;; (declare (uses env))
;; (declare (uses keys))
;; 
;; (include "common_records.scm")

;; return list (path fullpath configname)
(define (find-config configname #!key (toppath #f))
  (if toppath
      (let ((cfname (conc toppath "/" configname)))
	(if (common:file-exists? cfname)
	    (list toppath cfname configname)

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

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

;;;; cvs-out.impl  -*- Hen -*-
;;;; Kon Lovett, Jun '17

;;;; *** included source file ***

;;Issues
;;
;;- missing explicit types for exports; too much '*' type

;;

(define-constant CRLF-STR "\r\n")
(define-constant LF-STR "\n")
(define-constant CR-STR "\r") ;old MacOS

(define *system-newline*
  (cond-expand
    (windows
      CRLF-STR )
    (unix
      LF-STR )
    (else
      LF-STR ) ) )

(define-constant +newline-char-default+ #t)               ;#t - <system> | #\n | ...
(define-constant +separator-char-default+ #\,)
(define-constant +quote-char-default+ #\")                ;#f | #\" | ...
(define-constant +comment-char-default+ #\#)              ;#f | #\# | ...
(define-constant +quote-doubling-escapes?-default+ #t)
(define-constant +quote-controls?-default+ #t)
(define-constant +always-quote?-default+ #t)

#|
(define-constant +sxml-top-symbol+ '|*TOP*|)
(define-constant +sxml-row-element-default+ 'row)
(define-constant +sxml-col-elements-limit-default+ 32) ; arbitrary (see csv.ss)
|#

;;

;very loose : newline-char | separator-char | quote-char
;see "csv-xml.scm"
(define csv-writer-spec? alist?)
(define-check+error-type csv-writer-spec)

(define csv-writer? procedure?)
(define-check+error-type csv-writer)

;;

(define *default-writer-spec* (writer-spec-with-defaults '()))

(define (list->csv ls #!optional (writer-or-out (current-output-port)))
  (let (
      (writer
        (cond
          ((csv-writer? writer-or-out)
            writer-or-out )
          ((output-port? writer-or-out)
            (make-csv-line-writer 'list->csv writer-or-out *default-writer-spec*) )
          (else
            (error 'list->csv "invalid csv-writer or output-port" writer-or-out) ) ) ) )
    (for-each writer ls) ) )

#|
;;

(define (list->sxml ls
          #!optional
          (row-element (sxml-row-element-default))
          (column-elements (sxml-col-elements-default))
          (writer-spec *default-writer-spec*))
  (append!
    `(,(sxml-top-symbol))
    (map (cut list->sxml-element <> row-element column-elements writer-spec) ls)) )
|#

;;

(define (writer-spec
          #!key
          (newline-char +newline-char-default+)
          (separator-char +separator-char-default+)
          (quote-char +quote-char-default+)
          (comment-char +comment-char-default+)
          (quote-doubling-escapes? +quote-doubling-escapes?-default+)
          (quote-controls? +quote-controls?-default+)
          (always-quote? +always-quote?-default+))
  ;FIXME checking the input types
  `((newline-char . ,newline-char)
    (separator-char . ,separator-char)
    (quote-char . ,quote-char)
    (comment-char . ,comment-char)
    (quote-doubling-escapes? . ,quote-doubling-escapes?)
    (quote-controls? . ,quote-controls?)
    (always-quote? . ,always-quote?)) )

;;

(define (make-csv-writer out-or-str #!optional (writer-spec '()))
  (let ((make-spec-csv-writer (make-csv-writer-maker writer-spec)))
    (make-spec-csv-writer out-or-str) ) )

(define (make-csv-writer-maker #!optional (writer-spec '()))
  (let ((writer-spec
          (writer-spec-with-defaults
            (check-csv-writer-spec 'make-csv-writer-maker writer-spec)) ) )
    (lambda (out-or-str)
      (let (
          (out
            (cond
              ((string? out-or-str)
                (open-output-file out-or-str) )
              ((output-port? out-or-str)
                out-or-str )
              (else
                (error
                  'csv-writer-maker
                  "invalid output-port or string" out-or-str) ) ) ) )
        (make-csv-line-writer 'csv-writer-maker out writer-spec) ) ) ) )

;;

(define (make-csv-line-writer loc out writer-spec)
  (let (
    (writer-spec
      (check-csv-writer-spec loc writer-spec) )
    (newline-obj
      (select-newline-object loc (alist-ref 'newline-char writer-spec eq?)) )
    (separator-char
      (alist-ref 'separator-char writer-spec eq?) )
    (quote-char
      (alist-ref 'quote-char writer-spec eq?) )
    (comment-char
      (alist-ref 'comment-char writer-spec eq?) )
    (quote-doubling-escapes?
      (alist-ref 'quote-doubling-escapes? writer-spec eq?) )
    (quote-controls?
      (alist-ref 'quote-controls? writer-spec eq?) )
    (always-quote?
      (alist-ref 'always-quote? writer-spec eq?) ) )
    ;
    (let* (
      (quote-char-str (unicode-char->string quote-char) )
      (quote-char-str-2 (string-append quote-char-str quote-char-str)) )
      ;
      (define (csv-line-object->string obj)
        ;
        (define (quote-doubling? str)
          (and quote-doubling-escapes? (string-index str quote-char)) )
        ;
        (define (quoting? str)
          (or
            always-quote?
            (quote-doubling? str)
            (and separator-char (string-index str separator-char))
            (and quote-controls? (string-index str char-set:iso-control))) )
        ;
        (type-case obj
          ((char)
            (csv-line-object->string (unicode-char->string obj)) )
          ((symbol)
            (csv-line-object->string (symbol->string obj)) )
          ((string)
            (if (and quote-char (quoting? obj))
              (let (
                (str
                  (if (quote-doubling? obj)
                    (string-translate* obj `((,quote-char-str . ,quote-char-str-2)))
                    obj ) ) )
                ;
                (conc quote-char str quote-char) )
              obj ) )
          (number
            (csv-line-object->string (number->string obj)) )
          (else
            (csv-line-object->string (->string obj)) ) ) )
      ;
      (lambda (obj)
        (let (
          ;build row to output as a string with a line-ending sequence
          (lin
            ;comment desired?
            (if (list? obj)
              ;row data
              (let ((qstrs (map csv-line-object->string (check-list loc obj))))
                (apply
                  conc
                  (append!
                    (intersperse qstrs separator-char)
                    `(,newline-obj))) )
              ;are we supposed to do comments?
              (if comment-char
                (conc comment-char obj newline-obj)
                obj
                #;
                (begin
                  (warning loc "comments not active" obj writer-spec)
                  "" ) ) ) ) )
            ;
            (display lin out) ) ) ) ) )

;;

(define (select-newline-object loc spec)
  (case spec
    ((cr)
      #\return )
    ((lf)
      #\newline )
    ((crlf)
      CRLF-STR )
    (else
      *system-newline* ) ) )

;;

(define (writer-spec-with-defaults writer-spec)
  `((newline-char . ,(alist-ref 'newline-char writer-spec eq? +newline-char-default+))
    (separator-char . ,(alist-ref 'separator-char writer-spec eq? +separator-char-default+))
    (quote-char . ,(alist-ref 'quote-char writer-spec eq? +quote-char-default+))
    (comment-char . ,(alist-ref 'comment-char writer-spec eq? +comment-char-default+))
    (quote-doubling-escapes? . ,(alist-ref 'quote-doubling-escapes? writer-spec eq? +quote-doubling-escapes?-default+))
    (quote-controls? . ,(alist-ref 'quote-controls? writer-spec eq? +quote-controls?-default+))
    (always-quote? . ,(alist-ref 'always-quote? writer-spec eq? +always-quote?-default+))) )

#|
;;

(define (list->sxml-element ls row-element col-elements writer-spec)
  (if (list? ls)
    ;row data
    `(,row-element ,@(map list col-elements (map ->string ls)))
    ;are we supposed to do comments?
    (if (alist-ref 'comment-char writer-spec eq?)
      `(*COMMENT* ,(->string ls))
      ls ) ) )

(define (make-sxml-col-symbol n)
  (string->symbol (string-append "col-" (number->string n))) )

(define +sxml-col-elements-default+
  (map make-sxml-col-symbol (sxml-col-iota)) )

(define (sxml-top-symbol)
  +sxml-top-symbol+ )

(define (sxml-row-element-default)
  +sxml-row-element-default+ )

(define (sxml-col-elements-default)
  +sxml-col-elements-default+ )

(define (sxml-col-iota)
  (iota +sxml-col-elements-limit-default+) )
#;
(define (sxml-col-iota)
  (do ((i 0 add1)
       (ls '() (cons (make-sxml-col-symbol i) ls)) )
      ((= i +sxml-col-elements-limit-default+) ls) ) )
|#

;;;; csv-xml.meta  -*- Hen -*-

((egg "csv-xml.egg")
 (date "2011-07-02")
 (category parsing)
 (author "Neil van Dyke")
 (license "LGPL 3")
 (doc-from-wiki)
 (synopsis "Parsing comma-separated values")
 (depends
  (setup-helper "1.5.2")
  (check-errors "2.0.2")
  (moremacros "1.4.2")
  (string-utils "1.5.5"))
 (test-depends testeez test)
 (files
  "csv-xml.meta" "csv-xml.setup"
  "csv-xml.scm" "csv-out.impl" "csv.ss"
  "test/run.scm" "test/test-csv.ss") )

;;;; csv-xml.scm  -*- Hen -*-
;;;; Kon Lovett, Jun '17
;;;; Kon Lovett, ??? '??

(module csv-xml

(;export
  ;
  reader-spec
  ;
  make-csv-reader
  make-csv-reader-maker
  ;
  csv->list
  csv->sxml
  csv-for-each
  csv-map
  ;
  csv-reader? check-csv-reader error-csv-reader
  csv-reader-spec? check-csv-reader-spec error-csv-reader-spec
  ;
  writer-spec
  ;
  make-csv-writer-maker
  make-csv-writer
  ;
  list->csv
  #;list->sxml
  ;
  csv-writer? check-csv-writer error-csv-writer
  csv-writer-spec? check-csv-writer-spec error-csv-writer-spec)

(import scheme
	chicken.base
	chicken.string
	
	moremacros
	srfi-1
	srfi-13
	srfi-14
	type-checks
	unicode-utils
	)

#;(import (except chicken provide))
;; (import chicken)

;;;

;Need to process `#lang' as well. So just "commented out" the "offending"
;sections in the source.
#;(define-syntax provide (syntax-rules () ((_ ?x0 ...) (begin))))
(define null '())

(include "csv-xml/csv.ss")

;;;

;; (import (only data-structures conc intersperse ->string alist-ref string-translate*))
;; (require-library data-structures)
;; 
;; #;(import (only list-utils alist?))
;; (import (only (srfi 1) every iota append! map))
;; (require-library (srfi 1))
;; 
;; (import (only (srfi 13) string-index))
;; (require-library (srfi 13))
;; 
;; (import (only (srfi 14) char-set:iso-control))
;; (require-library (srfi 14))
;; 
;; (import (only type-checks define-check+error-type check-string check-list))
;; (require-library type-checks)
;; 
;; (import (only unicode-utils unicode-char->string))
;; (require-library unicode-utils)
;; 
;; (require-extension moremacros)

;(from list-utils egg)
(define (alist? obj)
  (if (pair? obj)
    (every pair? obj)
    (null? obj) ) )

;very loose ...
(define csv-reader-spec? alist?)
(define-check+error-type csv-reader-spec)

(define csv-reader? procedure?)
(define-check+error-type csv-reader)

(define (reader-spec
          #!key
          (newline-type 'lax)
          (separator-chars '(#\,))
          (quote-char #\")
          (quote-doubling-escapes? #t)
          (comment-chars '())
          (whitespace-chars '(#\space))
          (strip-leading-whitespace? #f)
          (strip-trailing-whitespace? #f)
          (newlines-in-quotes? #t))
  `((newline-type . ,newline-type)
    (separator-chars . ,separator-chars)
    (quote-char . ,quote-char)
    (quote-doubling-escapes? . ,quote-doubling-escapes?)
    (comment-chars . ,comment-chars)
    (whitespace-chars . ,whitespace-chars)
    (strip-leading-whitespace? . ,strip-leading-whitespace?)
    (strip-trailing-whitespace? . ,strip-trailing-whitespace?)
    (newlines-in-quotes? . ,newlines-in-quotes?)) )

;;;

(include "csv-xml/csv-out.impl")

) ;csv-xml

;;;; csv-xml.setup  -*- Hen -*-

(use setup-helper-mod)

(verify-extension-name "csv-xml")

(setup-shared+static-extension-module (extension-name) (extension-version "0.12.1")
  #:types? #t
  #:inline? #t
  #:compile-options '(
    -optimize-level 3 -debug-level 2
    -no-procedure-checks-for-toplevel-bindings -no-procedure-checks-for-usual-bindings))

;;; @Package     csv
;;; @Subtitle    Comma-Separated Value (CSV) Utilities in Scheme
;;; @HomePage    http://www.neilvandyke.org/csv-scheme/
;;; @Author      Neil Van Dyke
;;; @Version     0.10
;;; @Date        2010-04-13
;;; @PLaneT      neil/csv:1:6

;; $Id: csv.ss,v 1.199 2010/04/13 17:56:20 neilpair Exp $

;;; @legal
;;; Copyright @copyright{} 2004--2009 Neil Van Dyke.  This program is Free
;;; Software; you can redistribute it and/or modify it under the terms of the
;;; GNU Lesser General Public License as published by the Free Software
;;; Foundation; either version 3 of the License (LGPL 3), or (at your option)
;;; any later version.  This program 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
;;; @indicateurl{http://www.gnu.org/licenses/} for details.  For other licenses
;;; and consulting, please contact the author.
;;; @end legal

;#lang scheme/base

;;; @section Introduction

;;; The @b{csv} Scheme library provides utilities for reading various kinds of
;;; what are commonly known as ``comma-separated value'' (CSV) files.  Since
;;; there is no standard CSV format, this library permits CSV readers to be
;;; constructed from a specification of the peculiarities of a given variant.
;;; A default reader handles the majority of formats.
;;;
;;; One of the main uses of this library is to import data from old crusty
;;; legacy applications into Scheme for data conversion and other processing.
;;; To that end, this library includes various conveniences for iterating over
;;; parsed CSV rows, and for converting CSV input to the
;;; @uref{http://pobox.com/~oleg/ftp/Scheme/SXML.html, SXML 3.0} Scheme XML
;;; format.
;;;
;;; This library requires R5RS, SRFI-6, SRFI-23, and an @code{integer->char}
;;; procedure that accepts ASCII values.
;;;
;;; Other implementations of some kind of CSV reading for Scheme include
;;; Gauche's @code{text.csv} module, and Scsh's @code{record-reader} and
;;; related procedures.  This library intends to be portable and more
;;; comprehensive.

;; TODO: Briefly introduce terms "row", "column", and "field".

(define-syntax %csv:error
  (syntax-rules () ((_ p m o)
                    (error (string-append p " : " m) o)
                    ;; Bigloo: (error p m o)
                    )))

(define-syntax %csv:type-error
  (syntax-rules ()
    ((_ proc-str expected-str got-value)
     (%csv:error proc-str
                 (string-append "expected " expected-str ", received:")
                 got-value))))

(define %csv:a2c integer->char)

(define %csv:cr (%csv:a2c 13))
(define %csv:lf (%csv:a2c 10))

(define-syntax %csv:gosc
  (syntax-rules ()
    ((_ os-stx)
     (let* ((os  os-stx)
            (str (get-output-string os)))
       (close-output-port os)
       str))))

(define (%csv:in-arg proc-name in)
  (cond ((input-port? in) in)
        ((string?     in) (open-input-string in))
        (else (%csv:type-error proc-name "input port or string" in))))

(define (%csv:reader-or-in-arg proc-name reader-or-in)
  (cond ((procedure?  reader-or-in) reader-or-in)
        ((input-port? reader-or-in) (make-csv-reader reader-or-in))
        ((string?     reader-or-in) (make-csv-reader (open-input-string
                                                      reader-or-in)))
        (else (%csv:type-error proc-name
                               "csv reader or input port or string"
                               reader-or-in))))

;;; @section Reader Specs

;;; CSV readers are constructed using @dfn{reader specs}, which are sets of
;;; attribute-value pairs, represented in Scheme as association lists keyed on
;;; symbols.  Each attribute has a default value if not specified otherwise.
;;; The attributes are:

;;; @table @code
;;;
;;; @item newline-type
;;; Symbol representing the newline, or record-terminator, convention.  The
;;; convention can be a fixed character sequence (@code{lf}, @code{crlf}, or
;;; @code{cr}, corresponding to combinations of line-feed and carriage-return),
;;; any string of one or more line-feed and carriage-return characters
;;; (@code{lax}), or adaptive (@code{adapt}).  @code{adapt} attempts to detect
;;; the newline convention at the start of the input and assume that convention
;;; for the remainder of the input.  Default: @code{lax}
;;;
;;; @item separator-chars
;;; Non-null list of characters that serve as field separators.  Normally, this
;;; will be a list of one character.  Default: @code{(#\,)} (list of the comma
;;; character)
;;;
;;; @item quote-char
;;; Character that should be treated as the quoted field delimiter character,
;;; or @code{#f} if fields cannot be quoted.  Note that there can be only one
;;; quote character.  Default: @code{#\"} (double-quote)
;;;
;;; @item quote-doubling-escapes?
;;; Boolean for whether or not a sequence of two @code{quote-char} quote
;;; characters within a quoted field constitute an escape sequence for
;;; including a single @code{quote-char} within the string.  Default: @code{#t}
;;;
;;; @item comment-chars
;;; List of characters, possibly null, which comment out the entire line of
;;; input when they appear as the first character in a line.  Default:
;;; @code{()} (null list)
;;;
;;; @item whitespace-chars
;;; List of characters, possibly null, that are considered @dfn{whitespace}
;;; constituents for purposes of the @code{strip-leading-whitespace?} and
;;; @code{strip-trailing-whitespace?} attributes described below.
;;; Default: @code{(#\space)} (list of the space character)
;;;
;;; @item strip-leading-whitespace?
;;; Boolean for whether or not leading whitespace in fields should be
;;; stripped.  Note that whitespace within a quoted field is never stripped.
;;; Default: @code{#f}
;;;
;;; @item strip-trailing-whitespace?
;;; Boolean for whether or not trailing whitespace in fields should be
;;; stripped.  Note that whitespace within a quoted field is never stripped.
;;; Default: @code{#f}
;;;
;;; @item newlines-in-quotes?
;;; Boolean for whether or not newline sequences are permitted within quoted
;;; fields.  If true, then the newline characters are included as part of the
;;; field value; if false, then the newline sequence is treated as a premature
;;; record termination.  Default: @code{#t}
;;;
;;; @end table

;; TODO: Do not expose this procedure for now.  We expect it to go away and be
;; replaced with two other procedures.
;;
;; @defproc %csv:csv-spec-derive orig-spec changes
;;
;; Yields a new CSV spec that is derived from @var{orig-spec} by applying spec
;; @var{changes} as attribute substitions and additions to the original.  For
;; example, given an original CSV reader spec:
;;
;; @lisp
;; (define my-first-csv-spec
;;   '((newline-type            . lax)
;;     (separator-chars         . (#\,))
;;     (quote-char              . #\")
;;     (quote-doubling-escapes? . #t)
;;     (whitespace-chars        . (#\space))))
;; @end lisp
;;
;; a derived spec with a different @code{separator-chars} attribute and an
;; added @code{comment-chars} attribute can be created like:
;;
;; @lisp
;; (%csv:csv-spec-derive my-first-csv-spec
;;                  '((separator-chars . (#\%))
;;                    (comment-chars   . (#\#))))
;; @result{}
;; ((separator-chars         . (#\%))
;;  (comment-chars           . (#\#))
;;  (newline-type            . lax)
;;  (quote-char              . #\")
;;  (quote-doubling-escapes? . #t)
;;  (whitespace-chars        . (#\space)))
;; @end lisp
;;
;; In that the yielded spec might share some structure with @var{orig-spec}
;; and/or @var{changes}.  Most applications will not use this procedure
;; directly.

(define (%csv:csv-spec-derive orig-spec changes)
  ;; TODO: Make this not share structure.  Error-check and normalize at the
  ;; same time we clone.
  (let ((new-spec '()))
    (let ((add-to-new-spec
           (lambda (alist)
             (for-each (lambda (cell)
                         (or (assq (car cell) new-spec)
                             (set! new-spec (cons cell new-spec))))
                       alist))))
      (add-to-new-spec changes)
      (add-to-new-spec orig-spec)
      (reverse new-spec))))

;;; @section Making Reader Makers

;;; CSV readers are procedures that are constructed dynamically to close over a
;;; particular CSV input and yield a parsed row value each time the procedure
;;; is applied.  For efficiency reasons, the reader procedures are themselves
;;; constructed by another procedure, @code{make-csv-reader-maker}, for
;;; particular CSV reader specs.

(define (%csv:csv-error code extra)
  ;; TODO: Maybe make the CSV error handler user-specifiable, or allow user to
  ;; specify some errors that should be disregarded.
  ;;
  ;; TODO: Add position information.  Keep track of character position while
  ;; reading.
  (%csv:error
   "[csv-reader]"
   (string-append "Erroneous CSV format: "
                  (case code
                    ((junk-after-quote-close)
                     "Junk after close of quoted field:")
                    (else (string-append "INTERNAL ERROR: Unknown code: "
                                         (symbol->string code)))))
   extra))

(define (%csv:newline-check-step0 newline-type c port)
  ;; (display "*DEBUG* (equal? newline-type 'lax) = ")
  ;; (write (equal? newline-type 'lax))
  ;; (newline)
  ;; (display "*DEBUG* (eqv? newline-type 'lax) = ")
  ;; (write (eqv? newline-type 'lax))
  ;; (newline)
  (case newline-type
    ((cr)   (eqv? c %csv:cr))
    ((lf)   (eqv? c %csv:lf))
    ((crlf) (if (eqv? c %csv:cr)
                (let ((c2 (peek-char port)))
                  (cond ((eof-object? c2)
                         ;; Note: This is a CR-EOF in an input that uses CR-LF
                         ;; for terminating records.  We are discarding the CR,
                         ;; so it will not be added to the field string.  We
                         ;; might want to signal an error.
                         #t)
                        ((eqv? c2 %csv:lf)
                         (read-char port)
                         #t)
                        (else #f)))
                #f))
    ((lax detect) (cond ((eqv? c %csv:cr)
                         (let ((c2 (peek-char port)))
                           (cond ((eof-object? c2) #t)
                                 ((eqv? c2 %csv:lf)
                                  (read-char port)
                                  'crlf)
                                 (else 'cr))))
                        ((eqv? c %csv:lf) 'lf)
                        (else #f)))
    (else (%csv:error
           "%csv:make-portreader/positional"
           "unrecognized newline-type"
           newline-type))))

(define %csv:make-portreader/positional
  (letrec-syntax
      ((newline-check
        (syntax-rules ()
          ((_ newline-type c port detected-newline-type)
           ;; Note: "port" and "detected-newline-type" must be identifiers.
           ;; "newline-type" and "c" must be identifiers or self-evals.
           (if (eqv? newline-type 'detect)
               (begin (set! detected-newline-type
                            (%csv:newline-check-step0 newline-type c port))
                      detected-newline-type)
               (%csv:newline-check-step0 newline-type c port)))))
       (gosc-cons
        ;; Note: This is to ensure the output string is gotten and closed
        ;; before consing it with the result of a recursive call.
        (syntax-rules ()
          ((_ os b) (let ((s (%csv:gosc os))) (cons s b))))))
    (lambda (newline-type
             separator-chars
             quote-char
             quote-doubling-escapes?
             comment-chars
             whitespace-chars
             strip-leading-whitespace?
             strip-trailing-whitespace?
             newlines-in-quotes?)
      (lambda (port)
        (let ((dnlt #f)
              (escape-char #\\))
          (let read-fields-or-eof ((c (read-char port)))
            (cond
             ((eof-object? c) '())
             ((and strip-leading-whitespace? (memv c whitespace-chars))
              ;; It's leading whitespace char when we're ignoring leading
              ;; whitespace in fields, and there might just be whitespace and
              ;; then an EOF, which should probably be considered just an EOF
              ;; rather than a row with one empty field, so just skip this
              ;; whitespace char.
              (read-fields-or-eof (read-char port)))
             ((and (not (null? comment-chars)) (memv c comment-chars))
              ;; It's a comment char in the first column (or in the first
              ;; non-whitespace column, if "strip-leading-whitespace?" is
              ;; true), so skip to end of line.
              (let ((fake-dnlt #f))
                (let loop ((c (read-char port)))
                  (cond ((eof-object? c) '())
                        ((newline-check newline-type c port fake-dnlt)
                         (read-fields-or-eof (read-char port)))
                        (else (loop (read-char port)))))))
             (else
              ;; It's not going to be just an EOF, so try to read a row.
              (let ((row
                     (let read-fields ((c c))
                       (cond
                        ;; If an EOF or newline in an unquoted field, consider
                        ;; the field and row finished.  (We don't consider EOF
                        ;; before newline to be an error, although perhaps that
                        ;; would be a useful check for a freak premature
                        ;; end-of-input when dealing with "well-formed" CSV).
                        ((or (eof-object? c)
                             (newline-check newline-type c port dnlt))
                         (list ""))
                        ;; If a field separator, finish this field and cons
                        ;; with value of recursive call to get the next field.
                        ((memv c separator-chars)
                         (cons "" (read-fields (read-char port))))
                        ;; If we're ignoring leading whitespace, and it's a
                        ;; whitespace-chars character, then recurse to keep
                        ;; finding the field start.
                        ((and strip-leading-whitespace?
                              (memv c whitespace-chars))
                         (read-fields (read-char port)))
                        ;; If a quote, read a quoted field.
                        ((and quote-char (eqv? c quote-char))
                         (let ((os (open-output-string)))
                           (let loop ((c (read-char port)))
                             (cond
                              ((or (eof-object? c)
                                   (and (not newlines-in-quotes?)
                                        (newline-check newline-type
                                                       c port dnlt)))
                               (list (%csv:gosc os)))
                              ((and escape-char (eqv? c escape-char))
                               ;FIXME can become unsynchronized
                               (write-char (read-char port) os)
                               (loop (read-char port)))
                              ((and quote-char (eqv? c quote-char))
                               (if quote-doubling-escapes?
                                   (let ((c2 (read-char port)))
                                     (if (eqv? c2 quote-char)
                                         (begin (write-char c2 os)
                                                (loop (read-char port)))
                                         (gosc-cons
                                          os
                                          (let skip-after ((c c2))
                                            (cond
                                             ((or (eof-object? c)
                                                  (newline-check
                                                   newline-type c port dnlt))
                                              '())
                                             ((memv c separator-chars)
                                              (read-fields (read-char port)))
                                             ((memv c whitespace-chars)
                                              ;; Note: We tolerate
                                              ;; whitespace after field
                                              ;; close quote even if
                                              ;; skip-trailing-whitespace?
                                              ;; is false.
                                              (skip-after (read-char port)))
                                             (else (%csv:csv-error
                                                    'junk-after-quote-close
                                                    c)))))))
                                   (gosc-cons os
                                              (read-fields (read-char port)))))
                              (else (write-char c os)
                                    (loop (read-char port)))))))
                        ;; It's the start of an unquoted field.
                        (else
                         (let ((os (open-output-string)))
                           (write-char c os)
                           (let loop ((c (read-char port)))
                             (cond
                              ((or (eof-object? c)
                                   (newline-check newline-type c port dnlt))
                               (list (get-output-string os)))
                              ((memv c separator-chars)
                               (gosc-cons os (read-fields (read-char port))))
                              ((and strip-trailing-whitespace?
                                    (memv c whitespace-chars))
                               ;; TODO: Maybe optimize to avoid creating a new
                               ;; output string every time we see whitespace.
                               ;; We could use a string collector with unwrite.
                               ;; And/or do lookahead to see whether whitespace
                               ;; is only one character.  Do this after we have
                               ;; a better regression test suite.
                               (let ((ws-os (open-output-string)))
                                 (write-char c ws-os)
                                 (let ws-loop ((c (read-char port)))
                                   (cond
                                    ((or (eof-object? c)
                                         (newline-check
                                          newline-type c port dnlt))
                                     (close-output-port ws-os)
                                     (list (%csv:gosc os)))
                                    ((memv c separator-chars)
                                     (close-output-port ws-os)
                                     (gosc-cons os (read-fields (read-char
                                                                 port))))
                                    ((memv c whitespace-chars)
                                     (write-char c ws-os)
                                     (ws-loop (read-char port)))
                                    (else
                                     (display (%csv:gosc ws-os) os)
                                     (write-char c os)
                                     (loop (read-char port)))))))
                              (else (write-char c os)
                                    (loop (read-char port)))))))))))
                (if (null? row)
                    row
                    (if (eq? newline-type 'detect)
                        (cons dnlt row)
                        row)))))))))))

(define %csv:make-portreader
  ;; TODO: Make a macro for the three times we list the spec attributes.
  (letrec ((pb (lambda (x) (if x #t #f)))
           (pc (lambda (x)
                 (cond ((char?   x) x)
                       ((string? x) (case (string-length x)
                                      ((1)  (string-ref  x 0))
                                      (else (%csv:type-error
                                             "make-csv-reader-maker"
                                             "character"
                                             x))))
                       (else (%csv:type-error "make-csv-reader-maker"
                                              "character"
                                              x)))))
           (pc-f (lambda (x)
                   (cond ((not     x) x)
                         ((char?   x) x)
                         ((string? x) (case (string-length x)
                                        ((0)  #f)
                                        ((1)  (string-ref  x 0))
                                        (else (%csv:type-error
                                               "make-csv-reader-maker"
                                               "character or #f"
                                               x))))
                         (else (%csv:type-error "make-csv-reader-maker"
                                                "character or #f"
                                                x)))))
           (pe (lambda (x acceptable)
                 (if (memq x acceptable)
                     x
                     (%csv:type-error
                      "make-csv-reader-maker"
                      (let ((os (open-output-string)))
                        (display "symbol from the set " os)
                        (write acceptable os)
                        (%csv:gosc os))
                      x))))
           (plc-n (lambda (x)
                    (or (list? x)
                        (%csv:type-error "make-csv-reader-maker"
                                         "list of characters"
                                         x))
                    (map pc x)))
           (plc (lambda (x)
                  (let ((result (plc-n x)))
                    (if (null? result)
                        (%csv:type-error "make-csv-reader-maker"
                                         "non-null list of characters"
                                         x)
                        result)))))
    (lambda (reader-spec)
      (let ((newline-type               'lax)
            (separator-chars            '(#\,))
            (quote-char                 #\")
            (quote-doubling-escapes?    #t)
            (comment-chars              '())
            (whitespace-chars           '(#\space))
            (strip-leading-whitespace?  #f)
            (strip-trailing-whitespace? #f)
            (newlines-in-quotes?        #t))
        ;; TODO: It's erroneous to have two entries for the same attribute in a
        ;; spec.  However, it would be nice if we error-detected duplicate
        ;; entries, or at least had assq semantics (first, rather than last,
        ;; wins).  Use csv-spec-derive's descendants for that.
        (for-each
         (lambda (item)
           (let ((v (cdr item)))
             (case (car item)
               ((newline-type)
                (set! newline-type (pe v '(cr crlf detect lax lf))))
               ((separator-chars)
                (set! separator-chars (plc v)))
               ((quote-char)
                (set! quote-char (pc-f v)))
               ((quote-doubling-escapes?)
                (set! quote-doubling-escapes? (pb v)))
               ((comment-chars)
                (set! comment-chars (plc-n v)))
               ((whitespace-chars)
                (set! whitespace-chars (plc-n v)))
               ((strip-leading-whitespace?)
                (set! strip-leading-whitespace?  (pb v)))
               ((strip-trailing-whitespace?)
                (set! strip-trailing-whitespace? (pb v)))
               ((newlines-in-quotes?)
                (set! newlines-in-quotes? (pb v))))))
         reader-spec)
        (%csv:make-portreader/positional
         newline-type
         separator-chars
         quote-char
         quote-doubling-escapes?
         comment-chars
         whitespace-chars
         strip-leading-whitespace?
         strip-trailing-whitespace?
         newlines-in-quotes?)))))

;;; @defproc make-csv-reader-maker reader-spec
;;;
;;; Constructs a CSV reader constructor procedure from the @var{reader-spec},
;;; with unspecified attributes having their default values.
;;;
;;; For example, given the input file @code{fruits.csv} with the content:
;;;
;;; @example
;;; apples  |  2 |  0.42
;;; bananas | 20 | 13.69
;;; @end example
;;;
;;; a reader for the file's apparent format can be constructed like:
;;;
;;; @lisp
;;; (define make-food-csv-reader
;;;   (make-csv-reader-maker
;;;    '((separator-chars            . (#\|))
;;;      (strip-leading-whitespace?  . #t)
;;;      (strip-trailing-whitespace? . #t))))
;;; @end lisp
;;;
;;; The resulting @code{make-food-csv-reader} procedure accepts one argument,
;;; which is either an input port from which to read, or a string from which to
;;; read.  Our example input file then can be be read by opening an input port
;;; on a file and using our new procedure to construct a reader on it:
;;;
;;; @lisp
;;; (define next-row
;;;   (make-food-csv-reader (open-input-file "fruits.csv")))
;;; @end lisp
;;;
;;; This reader, @code{next-row}, can then be called repeatedly to yield a
;;; parsed representation of each subsequent row.  The parsed format is a list
;;; of strings, one string for each column.  The null list is yielded to
;;; indicate that all rows have already been yielded.
;;;
;;; @lisp
;;; (next-row) @result{} ("apples" "2" "0.42")
;;; (next-row) @result{} ("bananas" "20" "13.69")
;;; (next-row) @result{} ()
;;; @end lisp

(define (make-csv-reader-maker reader-spec)
  (let ((make-portread
         (if (let ((p (assq 'newline-type reader-spec))) (and p (cdr p)))
             ;; Newline-adapting portreader-maker.
             (letrec
                 ((detect-portread
                   (%csv:make-portreader
                    (%csv:csv-spec-derive reader-spec
                                          '((newline-type . detect)))))
                  ;; TODO: The set of cr/crlf/lf newline-type portreaders are
                  ;; constructed optimistically right now for two reasons:
                  ;; 1. we don't yet sanitize reader-specs of shared structure
                  ;; that can be mutated behind our backs; 2. eventually, we
                  ;; want to add a "lots-o-shots?" argument that, when true,
                  ;; would do this anyway.  Consider.
                  (cr-portread
                   (%csv:make-portreader
                    (%csv:csv-spec-derive reader-spec
                                          '((newline-type . cr)))))
                  (crlf-portread
                   (%csv:make-portreader
                    (%csv:csv-spec-derive reader-spec
                                          '((newline-type . crlf)))))
                  (lf-portread
                   (%csv:make-portreader
                    (%csv:csv-spec-derive reader-spec
                                          '((newline-type . lf))))))
               (lambda ()
                 (let ((actual-portread #f))
                   (let ((adapt-portread
                          (lambda (port)
                            (let ((dnlt-row (detect-portread port)))
                              (if (null? dnlt-row)
                                  dnlt-row
                                  (begin (set! actual-portread
                                               (case (car dnlt-row)
                                                 ((cr)   cr-portread)
                                                 ((crlf) crlf-portread)
                                                 ((lf)   lf-portread)
                                                 (else   actual-portread)))
                                         (cdr dnlt-row)))))))
                     (set! actual-portread adapt-portread)
                     (lambda (port) (actual-portread port))))))
             ;; Stateless portreader-maker.
             (let ((reusable-portread
                    (%csv:make-portreader reader-spec)))
               (lambda () reusable-portread)))))
    (lambda (in)
      (let ((port     (%csv:in-arg "[csv-reader]" in))
            (portread (make-portread)))
        (lambda () (portread port))))))

;;; @section Making Readers

;;; In addition to being constructed from the result of
;;; @code{make-csv-reader-maker}, CSV readers can also be constructed using
;;; @code{make-csv-reader}.

;;; @defproc make-csv-reader in [reader-spec]
;;;
;;; Construct a CSV reader on the input @var{in}, which is an input port or a
;;; string.  If @var{reader-spec} is given, and is not the null list, then a
;;; ``one-shot'' reader constructor is constructed with that spec and used.  If
;;; @var{reader-spec} is not given, or is the null list, then the default CSV
;;; reader constructor is used.  For example, the reader from the
;;; @code{make-csv-reader-maker} example could alternatively have been
;;; constructed like:
;;;
;;; @lisp
;;; (define next-row
;;;   (make-csv-reader
;;;    (open-input-file "fruits.csv")
;;;    '((separator-chars            . (#\|))
;;;      (strip-leading-whitespace?  . #t)
;;;      (strip-trailing-whitespace? . #t))))
;;; @end lisp

(define make-csv-reader
  (let ((default-maker (make-csv-reader-maker '())))
    (lambda (in . rest)
      (let ((spec (cond ((null? rest)       '())
                        ((null? (cdr rest)) (car rest))
                        (else (%csv:error "make-csv-reader"
                                          "extraneous arguments"
                                          (cdr rest))))))
        ((if (null? spec)
             default-maker
             (make-csv-reader-maker spec))
         (%csv:in-arg "make-csv-reader" in))))))

;;; @section High-Level Conveniences

;;; Several convenience procedures are provided for iterating over the CSV rows
;;; and for converting the CSV to a list.
;;;
;;; To the dismay of some Scheme purists, each of these procedures accepts a
;;; @var{reader-or-in} argument, which can be a CSV reader, an input port, or a
;;; string.  If not a CSV reader, then the default reader constructor is used.
;;; For example, all three of the following are equivalent:
;;;
;;; @lisp
;;; (csv->list                                     STRING  )
;;; @equiv{}
;;; (csv->list (make-csv-reader                    STRING ))
;;; @equiv{}
;;; (csv->list (make-csv-reader (open-input-string STRING )))
;;; @end lisp

;;; @defproc csv-for-each proc reader-or-in
;;;
;;; Similar to Scheme's @code{for-each}, applies @var{proc}, a procedure of one
;;; argument, to each parsed CSV row in series.  @var{reader-or-in} is the CSV
;;; reader, input port, or string.  The return value is undefined.

;; TODO: Doc an example for this.

(define (csv-for-each proc reader-or-in)
  (let ((reader (%csv:reader-or-in-arg "csv-for-each" reader-or-in)))
    (let loop ((row (reader)))
      (or (null? row)
          (begin (proc row)
                 (loop (reader)))))))

;;; @defproc csv-map proc reader-or-in
;;;
;;; Similar to Scheme's @code{map}, applies @var{proc}, a procedure of one
;;; argument, to each parsed CSV row in series, and yields a list of the values
;;; of each application of @var{proc}, in order.  @var{reader-or-in} is the CSV
;;; reader, input port, or string.

;; TODO: Doc an example for this.

;; (define (csv-map proc reader-or-in)
;;   (let ((reader (%csv:reader-or-in-arg "csv-for-each" reader-or-in)))
;;     (let ((head '()))
;;       (let ((row (reader)))
;;         (if (null? row)
;;             head
;;             (let ((pair (cons (proc row) '())))
;;               (set! head pair)
;;               (let loop ((prior pair))
;;                 (let ((row (reader)))
;;                   (if (null? row)
;;                       head
;;                       (let ((pair (cons (proc row) '())))
;;                         (set-cdr! prior pair)
;;                         (loop pair)))))))))))

(define (csv-map proc reader-or-in)
  (let ((reader (%csv:reader-or-in-arg "csv-for-each" reader-or-in)))
    (let loop ((row (reader)) (ret null))
      (if (null? row)
          (reverse ret)
          (let ((ret (cons (proc row) ret)))
            (loop (reader) ret))))))

;;; @defproc csv->list reader-or-in
;;;
;;; Yields a list of CSV row lists from input @var{reader-or-in}, which is a
;;; CSV reader, input port, or string.

;; TODO: Doc an example for this.

;; (define (csv->list reader-or-in)
;;   (let ((reader (%csv:reader-or-in-arg "csv->list" reader-or-in)))
;;     (let ((head '()))
;;       (let ((row (reader)))
;;         (if (null? row)
;;             head
;;             (let ((pair (cons row '())))
;;               (set! head pair)
;;               (let loop ((prior pair))
;;                 (let ((row (reader)))
;;                   (if (null? row)
;;                       head
;;                       (let ((pair (cons row '())))
;;                         (set-cdr! prior pair)
;;                         (loop pair)))))))))))

(define (csv->list reader-or-in)
  (csv-map values reader-or-in))

;;; @section Converting CSV to SXML

;;; The @code{csv->sxml} procedure can be used to convert CSV to SXML format,
;;; for processing with various XML tools.

;;; @defproc csv->sxml reader-or-in [row-element [col-elements]]
;;;
;;; Reads CSV from input @var{reader-or-in} (which is a CSV reader, input port,
;;; or string), and yields an SXML representation.  If given, @var{row-element}
;;; is a symbol for the XML row element.  If @var{row-element} is not given,
;;; the default is the symbol @code{row}.  If given @var{col-elements} is a
;;; list of symbols for the XML column elements.  If not given, or there are
;;; more columns in a row than given symbols, column element symbols are of the
;;; format @code{col-@var{n}}, where @var{n} is the column number (the first
;;; column being number 0, not 1).
;;;
;;; For example, given a CSV-format file @code{friends.csv} that has the
;;; contents:
;;;
;;; @example
;;; Binoche,Ste. Brune,33-1-2-3
;;; Posey,Main St.,555-5309
;;; Ryder,Cellblock 9,
;;; @end example
;;;
;;; with elements not given, the result is:
;;;
;;; @lisp
;;; (csv->sxml (open-input-file "friends.csv"))
;;; @result{}
;;; (*TOP*
;;;  (row (col-0 "Binoche") (col-1 "Ste. Brune")  (col-2 "33-1-2-3"))
;;;  (row (col-0 "Posey")   (col-1 "Main St.")    (col-2 "555-5309"))
;;;  (row (col-0 "Ryder")   (col-1 "Cellblock 9") (col-2 "")))
;;; @end lisp
;;;
;;; With elements given, the result is like:
;;;
;;; @lisp
;;; (csv->sxml (open-input-file "friends.csv")
;;;            'friend
;;;            '(name address phone))
;;; @result{}
;;; (*TOP* (friend (name    "Binoche")
;;;                (address "Ste. Brune")
;;;                (phone   "33-1-2-3"))
;;;        (friend (name    "Posey")
;;;                (address "Main St.")
;;;                (phone   "555-5309"))
;;;        (friend (name    "Ryder")
;;;                (address "Cellblock 9")
;;;                (phone   "")))
;;; @end lisp

(define csv->sxml
  (let* ((top-symbol
          (string->symbol "*TOP*"))
         (make-col-symbol
          (lambda (n)
            (string->symbol (string-append "col-" (number->string n)))))
         (default-col-elements
           (let loop ((i 0))
             (if (= i 32) ; arbitrary magic number
                 '()
                 (cons (make-col-symbol i) (loop (+ 1 i)))))))
    ;; TODO: Have option to error when columns count doesn't match provided
    ;; column name list.
    (lambda (reader-or-in . rest)
      (let ((reader       (%csv:reader-or-in-arg "csv->sxml"
                                                 reader-or-in))
            (row-element  'row)
            (col-elements #f))
        ;; TODO: Maybe use case-lambda.
        (or (null? rest)
            (begin (set! row-element (car rest))
                   (let ((rest (cdr rest)))
                     (or (null? rest)
                         (begin (set! col-elements (car rest))
                                (let ((rest (cdr rest)))
                                  (or (null? rest)
                                      (%csv:error
                                       "csv->sxml"
                                       "extraneous arguments"
                                       rest))))))))
        ;; TODO: We could clone and grow default-col-elements for the duration
        ;; of this procedure.
        (cons top-symbol
              (csv-map (lambda (row)
                         (cons row-element
                               (let loop ((vals  row)
                                          (i     0)
                                          (names (or col-elements
                                                     default-col-elements)))
                                 (if (null? vals)
                                     '()
                                     (cons (list (if (null? names)
                                                     (make-col-symbol i)
                                                     (car names))
                                                 (car vals))
                                           (loop (cdr vals)
                                                 (+ 1 i)
                                                 (if (null? names)
                                                     '()
                                                     (cdr names))))))))
                       reader))))))

;; TODO: Make a define-csv-reader/positional, for great constant-folding.
;; That's part of the reason some things are done the way they are.

;; TODO: Make a csv-bind, as a newbie convenience for people without advanced
;; match forms, which looks good in examples.  This is better than a
;; csv-map/bind and a csv-for-each/bind.
;;
;; (csv-for-each/bind ((column-binding ...) body ...)
;;               { (else => closure) | (else body ...) | }
;;               input-port
;;               [ csv-reader ])
;;
;; (csv-for-each/bind
;;  ((lastname firstname email)
;;   ...)
;;  (else => (lambda (row) (error "CSV row didn't match pattern" row)))
;;  my-input-port
;;  my-csv-reader)

;; TODO: Handle escapes, once we find an actual example or specification of any
;; flavor of escapes in CSV other than quote-doubling inside a quoted field.

;; TODO: Add a spec attribute for treating adjacent separators as one, or
;; skipping empty fields.  This would probably only be used in practice for
;; parsing whitespace-separated input.

;; TODO: Get access to MS Excel or documentation, and make this correct.
;;
;; (define msexcel-csv-reader-spec
;;   '((newline-type               . crlf)
;;     (separator-chars            . (#\,))
;;     (quote-char                 . #\")
;;     (quote-doubling-escapes?    . #t)
;;     (comment-chars              . ())
;;     (whitespace-chars           . (#\space))
;;     (strip-leading-whitespace?  . #f)
;;     (strip-trailing-whitespace? . #f)
;;     (newlines-in-quotes?        . #t)))

;; TODO: Maybe put this back in.
;;
;; (define default-csv-reader-spec
;;   '((newline-type               . lax)
;;     (separator-chars            . (#\,))
;;     (quote-char                 . #\")
;;     (quote-doubling-escapes?    . #t)
;;     (comment-chars              . ())
;;     (whitespace-chars           . (#\space))
;;     (strip-leading-whitespace?  . #f)
;;     (strip-trailing-whitespace? . #f)
;;     (newlines-in-quotes?        . #t)))

;; TODO: Implement CSV writing, after CSV reading is field-tested and polished.

;; TODO: Call "close-input-port" once eof-object is hit, but make sure we still
;; can return an empty list on subsequent calls to the CSV reader.

;; TODO: Consider switching back to returning eof-object at the end of input.
;; We originally changed to returning the null list because we might want to
;; synthesize the EOF, and there is no R5RS binding for the eof-object.

;; TODO: [2005-12-09] In one test, Guile has a stack overflow when parsing a
;; row with 425 columns.  Wouldn't hurt to see if we can make things more
;; tail-recursive.

;;; @unnumberedsec History

;;; @table @asis
;;;
;;; @item Version 0.10 -- 2010-04-13 -- PLaneT @code{(1 6)}
;;; Documentation fix.
;;;
;;; @item Version 0.9 -- 2009-03-14 -- PLaneT @code{(1 5)}
;;; Documentation fix.
;;;
;;; @item Version 0.8 -- 2009-02-23 -- PLaneT @code{(1 4)}
;;; Documentation changes.
;;;
;;; @item Version 0.7 -- 2009-02-22 -- PLaneT @code{(1 3)}
;;; License is now LGPL 3.  Moved to author's new Scheme administration system.
;;;
;;; @item Version 0.6 -- 2008-08-12 -- PLaneT @code{(1 2)}
;;; For PLT 4 compatibility, new versions of @code{csv-map} and
;;; @code{csv->list} that don't use @code{set-cdr!} (courtesy of Doug
;;; Orleans). PLT 4 @code{if} compatibility change.  Minor documentation fixes.
;;;
;;; @item Version 0.5 --- 2005-12-09
;;; Changed a non-R5RS use of @code{letrec} to @code{let*}, caught by Guile and
;;; David Pirotte.
;;;
;;; @item Version 0.4 --- 2005-06-07
;;; Converted to Testeez.  Minor documentation changes.
;;;
;;; @item Version 0.3 --- 2004-07-21
;;; Minor documentation changes.  Test suite now disabled by default.
;;;
;;; @item Version 0.2 --- 2004-06-01
;;; Work-around for @code{case}-related bug observed in Gauche 0.8 and 0.7.4.2
;;; that was tickled by @code{csv-internal:make-portreader/positional}.  Thanks
;;; to Grzegorz Chrupa@l{}a for reporting.
;;;
;;; @item Version 0.1 --- 2004-05-31
;;; First release, for testing with real-world input.
;;;
;;; @end table

#;(provide
 csv->list
 csv->sxml
 csv-for-each
 csv-map
 make-csv-reader
 make-csv-reader-maker)

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

;; (define (dtests:get-pre-command #!key (default-override #f))
;;   (let* ((orig-pre-command "export CMD='")
;;          (viewscreen-pre-command  "viewscreen ")
;;          (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen"))
;;          (default-pre-command (if use-viewscreen viewscreen-pre-command orig-pre-command))
;;          (cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command")))
;;     (or cfg-ovrd default-override default-pre-command))) ;; "xterm -geometry 180x20 -e \""))
;; 
;;   
;; (define (dtests:get-post-command #!key (default-override #f))
;;   (let* ((orig-post-command (conc "';xterm -geometry 180x20 -e \"(echo; echo -n START:;date +ww%U.%w-$H:%M:%S;echo;echo $CMD;echo;$CMD)|&"
;;                                  "tee -a runlog-`date +ww%U.%w-%H:%M`.log;echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))
;;          (viewscreen-post-command  "")
;;          (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen"))
;;          (default-post-command (if use-viewscreen viewscreen-post-command orig-post-command))
;;          (cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command")))
;;     (or cfg-ovrd default-override default-post-command))) ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
;; 
;; 
(define (test-info-panel testdat store-label widgets)
  (iup:frame 
   #:title "Test Info" ; #:expand "YES"
   (iup:hbox ; #:expand "YES"
    (apply iup:vbox ; #:expand "YES"
	   (append (map (lambda (val)
			  (iup:label val ; #:expand "HORIZONTAL"

		(datashare:initialize-db db)))
	  db)
	(print "ERROR: invalid path for storing database: " path))))

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

;;======================================================================
;; Database access
;;======================================================================

;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc

;; (use (srfi 18) extras tcp stack)
;; (use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records matchable)
;; (import (prefix sqlite3 sqlite3:))
;; (import (prefix base64 base64:))
;; 
;; (declare (unit db))
;; (declare (uses common))
;; (declare (uses keys))
;; (declare (uses ods))
;; (declare (uses client))
;; (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
;;======================================================================

;; each db entry is a pair ( db . dbfilepath )
;; I propose this record evolves into the area record
;;
(defstruct dbr:dbstruct 
  (tmpdb       #f)
  (dbstack     #f) ;; stack for tmp db handles, do not initialize with a stack
  (mtdb        #f)
  (refndb      #f)
  (homehost    #f) ;; not used yet
  (on-homehost #f) ;; not used yet
  (read-only   #f)
  (stmt-cache  (make-hash-table))
  (locdbs      (make-hash-table)) ;; legacy junk in db_records
  )                ;; goal is to converge on one struct for an area but for now it is too confusing
  

;; record for keeping state,status and count for doing roll-ups in
;; iterated tests
;;
(defstruct dbr:counts

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

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

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

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

;; sync run to disk if touched
;;

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

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

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

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

;;     (if (not cache-dir)
;; 	(begin
;; 	  (debug:print 0 *default-log-port* "ERROR: Failed to find an area to write the cache db")
;; 	  (exit 1))
;; 	(let* ((th1      (make-thread
;; 			  (lambda ()
;; 			    (if (and (common:file-exists? megatest-db)
;; 				     (file-writable? megatest-db))
;; 				(begin
;; 				  (db:sync-to-megatest.db dbstruct 'timestamps) ;; internally mutexes on *db-local-sync*
;; 				  (debug:print-info 2 *default-log-port* "Done syncing to megatest.db"))))
;; 			  "call-with-cached-db sync-to-megatest.db"))
;; 	       (cache-db (db:cache-for-read-only
;; 			  megatest-db
;; 			  (conc cache-dir "/" fname)

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

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

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

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

                (null? toplevels))
           #f
           #t)))))

(define (db:get-status-from-final-status-file run-dir)
  (let ((infile (conc run-dir "/.final-status")))
    ;; first verify we are able to write the output file
    (if (not (file-readable? infile))
        (begin 
	  (debug:print 0 *default-log-port* "ERROR: cannot read " infile)
          (debug:print 0 *default-log-port* "ERROR: run-dir is " run-dir)
          #f
          )
        (with-input-from-file infile read-lines)
	)))

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

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

(include "dbi/dbi.scm")

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

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

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

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

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

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

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

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

;; ONLY A LOWEST COMMON DEMOMINATOR IS SUPPORTED!

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

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

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

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

     lazy-bool)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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



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

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

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

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

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

(require-library margs dbi)

(define help "help me")

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

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

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

(define db (ftf:mk-db))

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

;;     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 diff-report))
;; (declare (uses common))
;; (declare (uses rmt))
;;          
;; (include "common_records.scm")
;; (use matchable)
;; (use fmt)
;; (use ducttape-lib)

(define css "")

(define (diff:tests-mindat->hash tests-mindat)
  (let* ((res (make-hash-table)))
    (for-each
     (lambda (item)
       (let* ((test-name+item-path (cons (list-ref item 0) (list-ref item 1)))

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

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

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

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

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

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

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

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


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

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


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

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

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


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

                    )

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

      (define (get-uuid)
(print "ERROR in ducttape lib")
	"foo")
        ;;(string-upcase (uuid->string (uuid-generate))))

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

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

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

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

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

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

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

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


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


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

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

;; (use sql-de-lite) ;; srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables)

(define (env:open-db fname)
  (let* ((db-exists (common:file-exists? fname))
	 (db        (open-database fname)))
    (if (not db-exists)
	(begin
	  (exec (sql db "CREATE TABLE envvars (

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

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

;; (use srfi-1 posix regex srfi-69 directory-utils call-with-environment-variables posix-extras
;;      z3 csv typed-records pathname-expand matchable)
;; 
;; (declare (unit ezsteps))
;; (declare (uses db))
;; (declare (uses common))
;; (declare (uses items))
;; (declare (uses runconfig))
;; ;; (declare (uses sdb))
;; ;; (declare (uses filedb))
;; 
;; (include "common_records.scm")
;; (include "key_records.scm")
;; (include "db_records.scm")
;; (include "run_records.scm")
;; 
;; 
;;(rmt:get-test-info-by-id run-id test-id) -> testdat

(define message-window #f)

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

		(loop (- count 1))))))
    
    (debug:print-info 0 *default-log-port* "Running in directory " test-run-dir)
    (if (not (common:file-exists? ".ezsteps"))(create-directory ".ezsteps"))
    ;; if ezsteps was defined then we are sure to have at least one step but check anyway
    
    (if (not (> (length ezstepslst) 0))
	(if message-window
	    (message-window "ERROR: You can only re-run steps defined via ezsteps")
	    (debug:print 0 *default-log-port* "ERROR: You can only re-run steps defined via ezsteps"))
	(begin
	  (let loop ((ezstep   (car ezstepslst))
		     (tal      (cdr ezstepslst))
                     (status-sym-so-far 'pass)
		     ;;(runflag  #f)
                     (saw-start-step-name #f)) ;; flag used to skip steps when not starting at the beginning
	    (if (or (vector-ref exit-info 1)
		    (equal? (alist-ref 'keep-going the-step-params) 'yes))
		(let* ((prev-step-params the-step-params) ;; need to snag this now
		       (stepname    (car ezstep))  ;; do stuff to run the step
                       (logpro-used (common:file-exists? (conc test-run-dir "/" stepname ".logpro")))
		       (stepinfo    (cadr ezstep))
		       (stepparts   (string-match (regexp "^(\\{([^\\}]*)\\}\\s*|)(.*)$") stepinfo))
		       (stepparms   (list-ref stepparts 2)) ;; for future use, {VAR=1,2,3}, run step for each 
		       (stepcmd     (list-ref stepparts 3))

(with-transaction
 db
 (lambda ()
   (loop ((for m (up-from (/ one-year-ago 60) (to (/ now 60))))) ;; days of the year
	 (let ((thetime (* m 60))
	       (thehour (round (/ m 60))))
	   (let loop ((lastsec -1)
		      (sec     (pseudo-random-integer 60))
		      (count   0))
	     (if (> sec lastsec)
		 (exec (sql db "INSERT INTO alldat (event_time,var,val) VALUES (?,?,?)")
		       (+ thetime sec) ;; (* sec 60))
		       "stuff" 
		       (if (even? thehour)
			   (pseudo-random-integer 1000)
			   (pseudo-random-integer 6))))
	     (if (< count 20)
		 (loop (max sec lastsec)(pseudo-random-integer 60)(+ count 1))))))))

(close-database db)


;; (with-transaction
;;  db
;;  (lambda ()
;;    (loop ((for d (up-from 0 (to 365)))) ;; days of the year
;; 	 (print "Day: " d)
;; 	 (loop ((for h (up-from 1 (to 24))))
;; 	     (loop ((for m (up-from 1 (to 60))))
;; 		   (let ((thetime (+ beginning-2016 (* 365 24 60 60)(* h 60 60)(* m 60))))
;; 		     (let loop ((lastsec -1)
;; 				(sec     (pseudo-random-integer 60))
;; 				(count   0))
;; 		       (if (> sec lastsec)
;; 			   (exec (sql db "INSERT INTO alldat (event_time,var,val) VALUES (?,?,?)")
;; 				 (+ thetime sec) ;; (* sec 60))
;; 				 "stuff" 
;; 				 (if (even? h)
;; 				     (pseudo-random-integer 100)
;; 				     (pseudo-random-integer 6))))
;; 		       (if (< count 20)
;; 			   (loop (max sec lastsec)(pseudo-random-integer 60)(+ count 1))))))))))
;; 
;; (close-database db)

;;     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 genexample))
;; (use posix regex matchable)
;; 
;; (include "db_records.scm")

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

#ifdef _WIN32
# include <winsock2.h>
# include <ws2tcpip.h>

const char *inet_ntop(int af, const void *src, char *dst, socklen_t cnt)
{
        if (af == AF_INET)
        {
                struct sockaddr_in in;
                memset(&in, 0, sizeof(in));
                in.sin_family = AF_INET;
                memcpy(&in.sin_addr, src, sizeof(struct in_addr));
                getnameinfo((struct sockaddr *)&in, sizeof(struct
sockaddr_in), dst, cnt, NULL, 0, NI_NUMERICHOST);
                return dst;
        }
        else if (af == AF_INET6)
        {
                struct sockaddr_in6 in;
                memset(&in, 0, sizeof(in));
                in.sin6_family = AF_INET6;
                memcpy(&in.sin6_addr, src, sizeof(struct in_addr6));
                getnameinfo((struct sockaddr *)&in, sizeof(struct
sockaddr_in6), dst, cnt, NULL, 0, NI_NUMERICHOST);
                return dst;
        }
        return NULL;
}

int inet_pton(int af, const char *src, void *dst)
{
        struct addrinfo hints, *res, *ressave;

        memset(&hints, 0, sizeof(struct addrinfo));
        hints.ai_family = af;

        if (getaddrinfo(src, NULL, &hints, &res) != 0)
        {
                return -1;
        }

        ressave = res;

        while (res)
        {
                memcpy(dst, res->ai_addr, res->ai_addrlen);
                res = res->ai_next;
        }

        freeaddrinfo(ressave);
        return 0;
}

#else
 # include <sys/types.h>
 # include <sys/socket.h>
 # include <netinet/in.h>  /* in_addr */
# include <arpa/inet.h>   /* inet_ntop, ... */
# include <netdb.h>       /* hostent, gethostby* */
# include <unistd.h>
#endif

;;; hostinfo.meta -*- Hen -*-
((synopsis "Look up host, protocol, and service information")
 (author "Jim Ursetto")
 (needs vector-lib foreigners)
 (egg "hostinfo.egg")
 (files "hostinfo.h" "hostinfo.meta" "hostinfo.scm" "hostinfo.setup")
 (license "BSD")
 (doc-from-wiki)
 (category net))

;;; hostinfo extension to Chicken Scheme
;;; Description: Look up host, service, and protocol information

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

;;;

;; This extension performs host, protocol and service information lookups
;; via underlying calls to gethostbyname(3), getprotobyname(3), and
;; getservbyname(3).  Depending on your system, this may consult DNS,
;; NIS, /etc/hosts, /etc/services, /etc/protocols, and so on.

;; A simple interface is provided for the most commmon queries. Also
;; provided is a more comprehensive interface using records, which
;; contain all data available in a lookup.

;; IP addresses are represented by 4 (IPv4) or 16 (IPv6) byte
;; u8vectors. The interface requires, and returns, addresses in this
;; format; functions are provided to convert between the string and
;; u8vector representations. However, the "do what I want" procedures
;; (e.g. host-information) will do the conversion for you.

;; Caveats:
;; - IPv6 addresses can be converted to and from strings, and the underlying structure
;;   supports IPv6, but lookup of IPv6 addresses and records is not currently implemented.
;; - array0->string-vector and array0->bytevector-vector contain redundant code.
;; - host, services, and protocol-information check their argument types, even
;;   though the underlying code already does it.

(declare
 (fixnum))

(cond-expand [paranoia]
             [else
              (declare (no-bound-checks))])

#> #include "hostinfo.h" <#

;; (require-extension srfi-4 lolevel posix)

(module hostinfo
;;; Short and sweet lookups
  (current-hostname
   hostname->ip ip->hostname
   protocol-name->number protocol-number->name
   service-port->name service-name->port
;;; Entire host, protocol or service record lookup
   hostname->hostinfo ip->hostinfo
   protocol-name->protoinfo protocol-number->protoinfo
   service-port->servinfo service-name->servinfo
;;; Record accessors and predicates
   hostinfo? hostinfo-name hostinfo-aliases hostinfo-addresses
   hostinfo-address hostinfo-type hostinfo-length
   protoinfo? protoinfo-name protoinfo-aliases protoinfo-number
   servinfo? servinfo-name servinfo-aliases servinfo-port servinfo-protocol
;;; One-stop shops -- does what you want
   host-information protocol-information service-information
;;; Utilities
   string->ip ip->string)

  (import chicken.fixnum chicken.string chicken.blob srfi-2 scheme
          typed-records srfi-9 chicken.foreign srfi-4 chicken.base
	  foreigners system-information
	  chicken.format)

  (define (vector-map p v0)   ; to avoid linking in vector-lib
    (let* ((len (vector-length v0))
           (v (make-vector len)))
      (do ((i 0 (+ i 1)))
          ((>= i len) v)
        (vector-set! v i
                     (p i (vector-ref v0 i))))))

  (cond-expand [unsafe
                (eval-when (compile)
                           (define-inline (##sys#check-string . r)
                             (##core#undefined))) ]
               [else])

;;; C data structure conversions

  (define (c-pointer->blob ptr len)
    (let ((bv (make-blob len))
          (memcpy (foreign-lambda bool "C_memcpy" blob c-pointer integer)))
      (memcpy bv ptr len)
      bv))

;; Convert from null-terminated array of c-strings to vector of strings.
;; These functions use C_alloc and so are not suitable for large datasets.
;; Note: get_argv_2 of runtime.c shows how to build a list instead of a vector (in reverse).
  (define array0->string-vector
    (foreign-primitive scheme-object (((c-pointer "char *") list)) "
    char **p; int len = 0;
    C_word *a, vec, *elt;

    for (p = list; *p; ++p, ++len);

    a = C_alloc(C_SIZEOF_VECTOR(len));
    vec = (C_word)a;
    *a++ = C_make_header(C_VECTOR_TYPE, len);

    for (p = list; *p; ++p) {
       len = strlen(*p);
       elt = C_alloc(C_SIZEOF_STRING(len));
       /* Both C_mutate and *a++ =  seem to work fine here. */
       C_mutate(a++, C_string(&elt, len, *p));
    }
    return(vec);"
                       ))

  ;; Convert from null-terminated array of IP addresses to vector of strings.
  (define array0->bytevector-vector
    (foreign-primitive scheme-object (((c-pointer "char *") list) (integer addrlen)) "
    char **p; int len = 0;
    C_word *a, vec, *elt;

    for (p = list; *p; ++p, ++len);

    a = C_alloc(C_SIZEOF_VECTOR(len));
    vec = (C_word)a;
    *a++ = C_make_header(C_VECTOR_TYPE, len);

    for (p = list; *p; ++p) {
       elt = C_alloc(C_SIZEOF_STRING(addrlen));
       C_mutate(a++, C_bytevector(&elt, addrlen, *p));
    }
    return(vec);"
                       ))

  ;; Not currently used.  Could make the array0-> stuff somewhat cleaner.
  ;; (define array0-length
  ;;   (foreign-lambda* integer (((pointer "void *") list)) #<<EOF
  ;;     void **p; int len = 0;
  ;;     for (p = list; *p; ++p, ++len);
  ;;     return(len);
  ;; EOF
  ;; ))

;;; string->ip conversion

  ;; inet_pton does not like "127.1", nor "0", nor any other non-standard
  ;; representation of IP addresses.  This is specified by RFC2553.
  ;; inet_aton resolves these addresses.  We use inet_pton here.

  (define-foreign-variable inet4-addrstrlen integer "INET_ADDRSTRLEN")
  (define-foreign-variable inet6-addrstrlen integer "INET6_ADDRSTRLEN")
  (define-foreign-variable af-inet  integer "AF_INET")
  (define-foreign-variable af-inet6 integer "AF_INET6")

  (define inet-ntop (foreign-lambda c-string "inet_ntop" integer u8vector c-string integer))
  (define inet-pton (foreign-lambda* bool ((integer type) (c-string src) (blob dest))
                                     "return(inet_pton(type, src, dest) == 1);"))

  (define (string->ip4 str)
    (##sys#check-string str 'string->ip4)
    (let ((bv (make-blob 4)))
      (and (inet-pton af-inet str bv)
           (blob->u8vector bv))))

  (define (string->ip6 str)
    (##sys#check-string str 'string->ip6)
    (let ((bv (make-blob 16)))
      (and (inet-pton af-inet6 str bv)
           (blob->u8vector bv))))

  (define (string->ip str)
    (or (string->ip4 str)
        (string->ip6 str)))

;;; ip->string conversion

  (define (ip4->string addr)
    (let ((len inet4-addrstrlen))
      (inet-ntop af-inet addr (make-string len) len)))

  (define (ip6->string addr)
    (let ((len inet6-addrstrlen))
      (inet-ntop af-inet6 addr (make-string len) len)))

  ;; Take an IPv4 or IPv6 u8vector and convert it into the
  ;; appropriate string representation, via inet_ntop.
  (define (ip->string addr)
    (let ((len (u8vector-length addr)))
      (cond ((fx= len 4)  (ip4->string addr))
            ((fx= len 16) (ip6->string addr))
            (else
             (error "Invalid IP address length" addr)))))

;;; hostent raw structure

  (define-foreign-record-type (hostent "struct hostent")
    (c-string h_name hostent-name)
    (c-pointer h_aliases hostent-h_aliases)
    (integer h_addrtype hostent-addrtype)
    (integer h_length hostent-length)
    (c-pointer h_addr_list hostent-addr-list))

  ;; Some convenient accessors for the raw hostent structure--with raw c pointers
  ;; converted to the appropriate scheme objects.  We only use these once or twice
  ;; below, so their main advantage is clarity.
  (define (hostent-aliases h)
    (array0->string-vector (hostent-h_aliases h)))
  (define (hostent-address h)
    (let* ((get-addr (foreign-lambda* c-pointer ((hostent h)) "return(h->h_addr_list[0]);"))
           (addr (get-addr h)))
      (blob->u8vector
       (c-pointer->blob addr (hostent-length h)))))
  (define (hostent-addresses h)
    (vector-map (lambda (i x) (blob->u8vector x))
                (array0->bytevector-vector (hostent-addr-list h)
                                           (hostent-length h))))
  ;; The IPv6 equivalents of these are getipnodebyname and
  ;; getipnodebyaddr.
  (define gethostent/name (foreign-lambda hostent "gethostbyname" c-string))

  (define (gethostent/addr addr)
    (if (fx= (u8vector-length addr) 4)
        (gethostent/addr/bv (u8vector->blob addr))
        (error "invalid IP address length; only IPv4 supported" addr)))

  ;; Warning: handle IPv6!!
  (define gethostent/addr/bv (foreign-lambda* hostent ((blob addr))
                                              "return(gethostbyaddr((const char *)addr, 4, AF_INET));"))

  ;; This was originally made a macro so we could easily return multiple
  ;; values -- but we're now returning a hostinfo structure.  Eh.
  (define (hostent->hostinfo h)
    (make-hostinfo (hostent-name h)
                   (hostent-addresses h)
                   (hostent-aliases h)))

;;; hostinfo and host information

  ;; The standard host name for the current processor.
  ;; Gets & Sets, error otherwise.

  (define set-host-name!
    (foreign-lambda* int ((c-string name))
                     "return(sethostname(name, strlen(name)));"))

  (define (current-hostname . args)
    (if (null? args)
        (get-host-name)
        (and (zero? (set-host-name! (->string (car args))))
             (error 'current-hostname "cannot set hostname"))))

  ;; Structure accessors created by define-foreign-record do not intercept
  ;; NULL pointer input, including #f.
  (define (hostname->ip host)
    (and-let* ((h (gethostent/name host)))
      (hostent-address h)))

  (define (hostname->hostinfo host)
    (and-let* ((h (gethostent/name host)))
      (hostent->hostinfo h)))

  (define (ip->hostname addr)
    (and-let* ((h (gethostent/addr addr)))
      (hostent-name h)))

  (define (ip->hostinfo addr)
    (and-let* ((h (gethostent/addr addr)))
      (hostent->hostinfo h)))

  ;; A simple hostinfo structure.
  (define-record-type hostinfo
    (make-hostinfo name addresses aliases)
    hostinfo?
    (name hostinfo-name)
    (addresses hostinfo-addresses)
    (aliases hostinfo-aliases))

  ;; "Accessors" for phantom fields.
  ;; We don't need to store length or type, as these are artifacts
  ;; of the C implementation, and can be derived from the address itself.
  (define (hostinfo-address h) (vector-ref (hostinfo-addresses h) 0))
  (define (hostinfo-length h) (u8vector-length (hostinfo-address h)))
  (define (hostinfo-type h)
    (let ((len (u8vector-length (hostinfo-address h))))
      (cond ((fx= len 4)  'AF_INET)   ;; Kind of a dummy implementation--
            ((fx= len 16) 'AF_INET6)  ;; not sure what value would be appropriate
            (else
             (error "Invalid IP address length" (hostinfo-address h))))))

  ;; Format the structure for easy interactive viewing--should be possible to
  ;; add a ctor for this representation, though it's not clear why you'd want to.
  (define-record-printer (hostinfo h port)
    (fprintf port "#,(hostinfo name: ~S addresses: ~S aliases: ~S)"
             (hostinfo-name h) (hostinfo-addresses h) (hostinfo-aliases h)))

  ;; Warning:  lookup of an IP address which is invalid yet numeric will
  ;; return a false positive.  Bug in gethostbyname?
  ;; E.g.  (hostname->hostinfo "1") => #,(hostinfo name: "1" addresses: (#u8(0 0 0 1)))
  ;; ** If we used inet_aton for string->ip, then these cases would
  ;; be transformed into u8vector IPs, and the lookup would correctly fail.

  ;; Return a hostinfo record.  HOST is a u8vector IP address, a string
  ;; hostname, or a string numeric IP address.
  (define (host-information host)
    (if (u8vector? host)
        (ip->hostinfo host)
        (begin
          (##sys#check-string host 'host-information)
          (cond ((string->ip host) => ip->hostinfo)
                (else (hostname->hostinfo host))))))

;;; protocols

  (define-foreign-record-type (protoent "struct protoent")
    (c-string p_name protoent-name)
    (c-pointer p_aliases protoent-p_aliases)
    (integer p_proto protoent-proto))

  (define getprotoent/name   (foreign-lambda protoent "getprotobyname" c-string))
  (define getprotoent/number (foreign-lambda protoent "getprotobynumber" integer))

  ;; Raw structure -> scheme-object accessors
  (define (protoent-aliases p)
    (array0->string-vector (protoent-p_aliases p)))

  (define-record-type protoinfo
    (make-protoinfo name number aliases)
    protoinfo?
    (name protoinfo-name)
    (number protoinfo-number)
    (aliases protoinfo-aliases))

  (define-record-printer (protoinfo p port)
    (fprintf port "#,(protoinfo name: ~S number: ~S aliases: ~S)"
             (protoinfo-name p) (protoinfo-number p) (protoinfo-aliases p)))

  (define (protocol-name->number name)
    (and-let* ((p (getprotoent/name name)))
      (protoent-proto p)))
  (define (protocol-number->name nr)
    (and-let* ((p (getprotoent/number nr)))
      (protoent-name p)))

  (define (protoent->protoinfo p)
    (make-protoinfo (protoent-name p)
                    (protoent-proto p)
                    (protoent-aliases p)))

  (define (protocol-name->protoinfo name)
    (and-let* ((p (getprotoent/name name)))
      (protoent->protoinfo p)))
  (define (protocol-number->protoinfo nr)
    (and-let* ((p (getprotoent/number nr)))
      (protoent->protoinfo p)))

  (define (protocol-information proto)
    (if (fixnum? proto)
        (protocol-number->protoinfo proto)
        (begin
          (##sys#check-string proto 'protocol-information)
          (protocol-name->protoinfo proto))))

;;; services

  (define-foreign-type port-number int
    (foreign-lambda int "htons" int)
    (foreign-lambda int "ntohs" int) )

  (define-foreign-record-type (servent "struct servent")
    (c-string s_name servent-name)
    (c-pointer s_aliases servent-s_aliases)
    (port-number s_port servent-port)
    (c-string s_proto servent-proto))

  (define (servent->servinfo s)
    (make-servinfo (servent-name s)
                   (servent-port s)
                   (array0->string-vector
                    (servent-s_aliases s))
                   (servent-proto s)))

  (define getservent/name (foreign-lambda servent "getservbyname" c-string c-string))
  (define getservent/port (foreign-lambda servent "getservbyport" port-number c-string))

  (define-record-type servinfo
    (make-servinfo name port aliases protocol)
    servinfo?
    (name servinfo-name)
    (port servinfo-port)
    (aliases servinfo-aliases)
    (protocol servinfo-protocol))

  (define-record-printer (servinfo s port)
    (fprintf port "#,(servinfo name: ~S port: ~S aliases: ~S protocol: ~S)"
             (servinfo-name s) (servinfo-port s) (servinfo-aliases s) (servinfo-protocol s)))

  ;; If provided with the optional protocol argument (a string), these will
  ;; restrict their search to that protocol.
  (define (service-name->port name . pr)
    (let-optionals pr ((proto #f))
                   (and-let* ((s (getservent/name name proto)))
                     (servent-port s))))
  (define (service-port->name port . pr)
    (let-optionals pr ((proto #f))
                   (and-let* ((s (getservent/port port proto)))
                     (servent-name s))))
  (define (service-name->servinfo name . pr)
    (let-optionals pr ((proto #f))
                   (and-let* ((s (getservent/name name proto)))
                     (servent->servinfo s))))
  (define (service-port->servinfo port . pr)
    (let-optionals pr ((proto #f))
                   (and-let* ((s (getservent/port port proto)))
                     (servent->servinfo s))))

  ;; Return service information given a service name or port, and an
  ;; optional protocol name or number to restrict the search to.
  ;; Note: if the protocol-number->name lookup fails,
  ;; an error is thrown, as this was probably not intended.
  (define (service-information service . pr)
    (let-optionals pr ((proto #f))
                   (let ((proto (if (fixnum? proto)
                                    (or (protocol-number->name proto)
                                        (error 'service-information "illegal protocol number" proto))
                                    proto)))
                     (if (fixnum? service)
                         (service-port->servinfo service proto)
                         (begin
                           (##sys#check-string service 'service-information)
                           (service-name->servinfo service proto))))))
)   ; end module

;;; Tests
(cond-expand
 [testing
  (import hostinfo)
  (current-hostname)
  (host-information "www.call-with-current-continuation.org")
  (host-information '#u8(194 97 107 133))
  (host-information "194.97.107.133")
                                        ; =>  #,(hostinfo name: "www003.lifemedien.de" addresses: #(#u8(194 97 107 133))
                                        ;        aliases: #("www.call-with-current-continuation.org"))
  (ip->hostname '#u8(194 97 107 133)) ; "www003.lifemedien.de"
  (string->ip "0708::0901")  ;  #u8(7 8 0 0 0 0 0 0 0 0 0 0 0 0 9 1)
  (ip->string '#u8(127 0 0 1))        ;  "127.0.0.1"
  (hostinfo-aliases
   (hostname->hostinfo
    (ip->hostname (hostname->ip
                   (hostinfo-name
                    (host-information "www.call-with-current-continuation.org"))))))
                                        ; => #("www.call-with-current-continuation.org")

  (protocol-information 17) ; => #,(protoinfo name: "udp" number: 17 aliases: #("UDP"))
  (protoinfo-name (protocol-information 2)) ; => "igmp"
  (protoinfo-aliases (protocol-name->protoinfo
                      (protocol-number->name
                       (protoinfo-number
                        (protocol-information "ospf"))))) ; => #("OSPFIGP")
  (protocol-name->number "OSPFIGP") ; 89 (you can look up aliases, too)

  (servinfo-protocol (service-name->servinfo
                      (service-port->name
                       (servinfo-port (service-information "ssh"))))) ; => "udp" (yes, really)
  (service-information "ssh" "tcp") ; => #,(servinfo name: "ssh" port: 22 aliases: #() protocol: "tcp")
  (service-information "ssh" "tco")   ; => #f
  (service-information 512 "tcp") ; #,(servinfo name: "exec" port: 512 aliases: #() protocol: "tcp")
  (service-information 512 "udp") ; #,(servinfo name: "comsat" port: 512 aliases: #("biff") protocol: "udp")
  (service-information 512 17)        ; same as previous
  (service-information 512 170000)   ; Error: (service-information) illegal protocol number: 170000
  ] [else])

(define libs
  (if (eq? (build-platform) 'msvc)
      "-lws2_32"
      "") )

(compile -s -O2 -d2 hostinfo.scm ,libs -j hostinfo)
(compile -s -O2 -d0 hostinfo.import.scm)
(install-extension
 'hostinfo 
 '("hostinfo.so" "hostinfo.import.so")
 '((version "1.4.1")))

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

;; (require-extension (srfi 18) extras tcp s11n)
;; 
;; 
;; (use  srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest posix-extras)
;; 
;; (use spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing)
;; 
;; Configurations for server
(tcp-buffer-size 2048)
(max-connections 2048) 

;; (declare (unit http-transport))
;; 
;; (declare (uses common))
;; (declare (uses db))
;; (declare (uses tests))
;; (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
;; (declare (uses server))
;; ;; (declare (uses daemon))
;; (declare (uses portlogger))
;; (declare (uses rmt))
;; 
;; (include "common_records.scm")
;; (include "db_records.scm")
;; (include "js-path.scm")

;; (require-library stml)
(define (http-transport:make-server-url hostport)
  (if (not hostport)
      #f
      (conc "http://" (car hostport) ":" (cadr hostport))))

(define *server-loop-heart-beat* (current-seconds))

  (let loop ((etime (+ (current-seconds) 5))) ;; give up in five seconds
    (if (> *http-requests-in-progress* 0)
	(if (> etime (current-seconds))
	    (begin
	      (thread-sleep! 0.05)
	      (loop etime))
	    (debug:print-error 0 *default-log-port* "requests still in progress after 5 seconds of waiting. I'm going to pass on cleaning up http connections"))
	(close-idle-connections!)))
  (set! *http-connections-next-cleanup* (+ (current-seconds) 10))
  (mutex-unlock! *http-mutex*))

(define (http-transport:inc-requests-and-prep-to-close-all-connections)
  (mutex-lock! *http-mutex*)
  (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*)))

					     (list (cons 'key (or server-id   "thekey"))
						   (cons 'cmd cmd)
						   (cons 'params sparams))
					     read-string))
					  transport: 'http)
                                         0)) ;; added this speculatively
			      ;; Shouldn't this be a call to the managed call-all-connections stuff above?
			      (close-idle-connections!)
			      (mutex-unlock! *http-mutex*)
			      ))
	      (time-out     (lambda ()
			      (thread-sleep! 45)
			      (debug:print 0 *default-log-port* "WARNING: send-receive took more than 45 seconds!!")
			      #f))
	      (th1 (make-thread send-recieve "with-input-from-request"))

          (if (common:low-noise-print 120 "server continuing")
              (debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
	      (let ((curr-time (current-seconds)))
		(handle-exceptions
		    exn
		    (debug:print 0 *default-log-port* "ERROR: Failed to change timestamp on log file " server-log-file ". Are you out of space on that disk? exn=" exn)
		  (if (not *server-overloaded*)
		      (set-file-times! server-log-file curr-time curr-time)))))
          (loop 0 server-state bad-sync-count (current-milliseconds)))
         (else
          (debug:print-info 0 *default-log-port* "Server timed out. seconds since last db access: " (- (current-seconds) last-access))
          (http-transport:server-shutdown port)))))))

(define (http-transport:server-shutdown port)
  (begin

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


;; (define itemdat '((ripeness    "green ripe overripe")
;; 		     (temperature "cool medium hot")
;; 		     (season      "summer winter fall spring")))

;; (declare (unit items))
;; (declare (uses common))
;; 
;; (include "common_records.scm")

;; Puts out all combinations
(define (process-itemlist hierdepth curritemkey itemlist)
  (let ((res '()))
    (if (not hierdepth)
	(set! hierdepth (length itemlist)))
    (let loop ((hed (car itemlist))

;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;
 
;;======================================================================
;; Run keys, these are used to hierarchially organise tests and run areas
;;======================================================================

;; (use sqlite3 srfi-1 posix regex regex-case srfi-69)
;; (import (prefix sqlite3 sqlite3:))
;; 
;; (declare (unit keys))
;; (declare (uses common))
;; 
;; (include "key_records.scm")
;; (include "common_records.scm")

(define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ...
  (string-intersperse keys ","))

(define (args:usage . a) #f)

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

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

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

;; (use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3
;;      call-with-environment-variables csv)
;; (use typed-records pathname-expand matchable)
;; 
;; (import (prefix base64 base64:))
;; (import (prefix sqlite3 sqlite3:))
;; 
;; (declare (unit launch))
;; (declare (uses subrun))
;; (declare (uses common))
;; (declare (uses configf))
;; (declare (uses db))
;; (declare (uses ezsteps))
;; 
;; (include "common_records.scm")
;; (include "key_records.scm")
;; (include "db_records.scm")
;; (include "megatest-fossil-hash.scm")

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

;; ezsteps were going to be coded as
;; stepname[,predstep1,predstep2 ...] [{VAR1=first,second,third}] command to execute

		      )))
	      (mutex-unlock! m)
	      ;; no point in sticking around. Exit now. But run end of run before exiting?
        (launch:end-of-run-check run-id)
	      (exit)))
	(if (hash-table-ref/default misc-flags 'keep-going #f)
	    (begin
	      (thread-sleep! 3) ;; (+ 3 (pseudo-random-integer 6))) ;; add some jitter to the call home time to spread out the db accesses
	      (if (hash-table-ref/default misc-flags 'keep-going #f)  ;; keep originals for cpu-load and disk-free unless they change more than the allowed delta
		  (loop (calc-minutes)
                        (or new-cpu-load cpu-load)
                        (or new-disk-free disk-free)
                        (if do-sync (current-seconds) last-sync)))))))
    (tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f))) ;; NOTE: Checking twice for keep-going is intentional

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

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

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

	  ;; We are about to actually kick off the test
	  ;; so this is a good place to remove the records for 
	  ;; any previous runs
	  ;; (db:test-remove-steps db run-id testname itemdat)
	  ;; now is also a good time to write the .testconfig file
	  (let* ((tconfig-fname   (conc work-area "/.testconfig"))
		 (tconfig-tmpfile (conc tconfig-fname ".tmp"))
		 (tconfig         (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t)) ;; 'return-procs)))
		 (scripts (configf:get-section tconfig "scripts")))
	    ;; create .testconfig file
	    (configf:write-alist tconfig tconfig-tmpfile)
	    (move-file tconfig-tmpfile tconfig-fname #t)
	    (delete-file* ".final-status")

	    ;; extract scripts from testconfig and write them to files in test run dir
	    (for-each
	     (lambda (scriptdat)
	       (match scriptdat
		      ((name content)
		       (with-output-to-file name
			 (lambda ()
			   (print content)
			   (set-file-permissions! name (bitwise-ior perm/irwxg perm/irwxu)))))
		      (else
		       (debug:print-info 0 "Invalid script definiton found in [scripts] section of testconfig. \"" scriptdat "\""))))
	     scripts))
	  ;; 
	  (let* ((m            (make-mutex))
		 (kill-job?    #f)
		 (exit-info    (make-launch:einf pid: #t exit-status: #t exit-code: #t rollup-status: 0)) ;; pid exit-status exit-code (i.e. process was successfully run) rollup-status

	     ;; checking for null cachefiles should not be necessary, I was seeing error car of '(), might be a chicken bug or a red herring ...
	     (mtcachef   (if (null? cachefiles)
			     #f
			     (car cachefiles))) ;; (and cachedir (conc cachedir "/" ".megatest.cfg-"  megatest-version "-" megatest-fossil-hash)))
	     (rccachef   (if (null? cachefiles)
			     #f
			     (cdr cachefiles)))) ;; (and cachedir (conc cachedir "/" ".runconfigs.cfg-"  megatest-version "-" megatest-fossil-hash)))
	      ;; (cancreate (and cachedir (common:file-exists? cachedir)(file-writable? cachedir) (not (common:in-running-test?)))))
	(set! *toppath* toppath) ;; This is needed when we are running as a test using CMDINFO as a datasource
        ;;(BB> "launch:setup-body -- cachefiles="cachefiles)
	(cond
	 ;; if mtcachef exists just read it, however we need to assume toppath is available in $MT_RUN_AREA_HOME
	 ((and (not force-reread)
	       mtcachef  rccachef
	       use-cache

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

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


(define (get-best-disk confdat testconfig)
  (let* ((disks   (or (and testconfig (hash-table-ref/default testconfig "disks" #f))
		      (hash-table-ref/default confdat "disks" #f)))

;;     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 margs))
;; (declare (uses common))

(define args:arg-hash (make-hash-table))

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

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

;;  megatest.scm mofiles/autoload.o mofiles/dbi.o mofiles/ducttape-lib.o
;;  mofiles/pkts.o mofiles/stml2.o mofiles/cookie.o mofiles/mutils.o
;;  mofiles/mtargs.o

;; (include "mutils/mutils.scm")
;; (include "autoload/autoload.scm")
;; (include "dbi/dbi.scm")
;; (include "stml2/cookie.scm")
;; (include "stml2/stml2.scm")
;; (include "pkts/pkts.scm")
(include "csv-xml/csv-xml.scm")
;; (include "ducttape/ducttape-lib.scm")
(include "hostinfo/hostinfo.scm")
(include "adjutant.scm")

(declare (uses mutils))
(declare (uses autoload))
(declare (uses pkts))
(declare (uses ducttape-lib))
(declare (uses stml2))
(declare (uses cookie))
(declare (uses mtargs))

;; (include "call-with-environment-variables/call-with-environment-variables.scm")

(module megatest-main
	*

	(import scheme
		chicken.base
		chicken.bitwise
		chicken.condition
		chicken.file
		chicken.file.posix
		chicken.format
		chicken.io
		chicken.irregex
		chicken.pathname
		chicken.port
		chicken.pretty-print
		chicken.process
		chicken.process-context
		chicken.process-context.posix
		chicken.process.signal
		chicken.random
		chicken.repl
		chicken.sort
		chicken.string
		chicken.tcp
		chicken.time
		chicken.time.posix
		
		(prefix sqlite3 sqlite3:)
		(prefix base64 base64:)
		address-info
		csv-abnf
		directory-utils
		fmt
		json
		matchable
		md5
		message-digest
		queues
		regex
		regex-case
		sql-de-lite
		stack
		typed-records
		s11n
		sparse-vectors
		sxml-serializer
		sxml-modifications
		system-information
		z3
		spiffy
		uri-common
		intarweb
		http-client
		spiffy-request-vars
		intarweb
		spiffy-directory-listing
		
		srfi-1
		srfi-4
		srfi-18
		srfi-13
		srfi-98
		srfi-69

		;; local modules
		mutils
		csv-xml
		ducttape-lib
		hostinfo
		adjutant
		)
	
;; (include "common.scm")
(include "megatest-version.scm")

;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)
(define setenv set-environment-variable!)
(define unsetenv unset-environment-variable!)

;; (declare (uses common))
;; ;; (declare (uses megatest-version))
;; (declare (uses margs))
;; (declare (uses runs))
;; (declare (uses launch))
;; (declare (uses server))
;; (declare (uses client))
;; (declare (uses tests))
;; (declare (uses genexample))
;; ;; (declare (uses daemon))
;; (declare (uses db))
;; ;; (declare (uses dcommon))
;; 
;; (declare (uses tdb))
;; (declare (uses mt))
;; (declare (uses api))
;; (declare (uses tasks)) ;; only used for debugging.
;; (declare (uses env))
;; (declare (uses diff-report))
;; (declare (uses ftail))
;; (import ftail)

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

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

(import (prefix dbi dbi:))
(import stml2)
(import pkts)

(include "common.scm")
(include "configf.scm")
(include "margs.scm")
(include "process.scm")
(include "keys.scm")
(include "portlogger.scm")
(include "db.scm")
(include "rmt.scm")
(include "runs.scm")
(include "launch.scm")
(include "server.scm")
(include "client.scm")
(include "tests.scm")
(include "items.scm")
(include "subrun.scm")
(include "genexample.scm")
(include "tdb.scm")
(include "mt.scm")
(include "api.scm")
(include "tasks.scm")
(include "ezsteps.scm")
(include "env.scm")
(include "diff-report.scm")
(include "cgisetup/models/pgdb.scm")
(include "runconfig.scm")
(include "archive.scm")
(include "ods.scm")
(include "http-transport.scm")

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

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

;; copied from egg call-with-environment-variables
;;
(define (call-with-environment-variables variables thunk)
  ;; @("Sets up environment variable via dynamic-wind which are taken down after thunk."
  ;;   (variables "An alist of the form {{'((\"var\" . \"value\") ...)}}")
  ;;   (thunk "The thunk to execute with a modified environment"))
  (let ((pre-existing-variables
         (map (lambda (var-value)
                (let ((var (car var-value)))
                  (cons var (get-environment-variable var))))
              variables)))
    (dynamic-wind
        (lambda () (void))
        (lambda ()
;;           (use posix)
          (for-each (lambda (var-value)
                      (setenv (car var-value) (cdr var-value)))
            variables)
          (thunk))
        (lambda ()
          (for-each (lambda (var-value)
                      (let ((var (car var-value))
                            (value (cdr var-value)))
                        (if value
                            (setenv var value)
                            (unsetenv var))))
            pre-existing-variables)))))



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

;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file
;;
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc")))
  (if (common:file-exists? debugcontrolf)
      (load debugcontrolf)))

;; usage logging, careful with this, it is not designed to deal with all real world challenges!
;;
(if (and *usage-log-file*
         (file-writable? *usage-log-file*))
    (with-output-to-file
        *usage-log-file*
      (lambda ()
        (print
         (if *usage-use-seconds*
             (current-seconds)
             (time->string

			 (debug:print 0 *default-log-port* "WARNING: log file " logpath-in " path too long, converted to " newlogf)
			 newlogf)
		       logpath-in)))
     (if (not (directory-exists? log-dir))
         (system (conc "mkdir -p " log-dir)))
     (open-output-file logpath))
   (exn ()
        (debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath-in)
        (define *didsomething* #t)  
        (exit 1))))

;; this segment will run launch:setup only if -log is not set. This is fairly safe as servers are not
;; manually started and thus should never be started in a non-megatest area. Thus no need to handle situation
;; where (launch:setup) returns #f?
;;

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

	    ;; (print "allrundat:")
	    ;; (pp allrundat)
	    ;; (print "runs:")
	    ;; (pp runs)
	    ;(print "sheets: ")
	    ;; (pp sheets)
	    (if (eq? dmode 'ods)
		(let* ((tempdir    (conc "/tmp/" (current-user-name) "/" (pseudo-random-integer 10000) "_" (current-process-id)))
		       (outputfile (or (args:get-arg "-o") "out.ods"))
		       (ouf        (if (string-match (regexp "^[/~]+.*") outputfile) ;; full path?
				       outputfile
				       (begin
					 (debug:print 0 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory")
					 (conc (current-directory) "/" outputfile)))))
		  (create-directory tempdir #t)

;; == duplicated == 		     user
;; == duplicated == 		     args:arg-hash))))

;;======================================================================
;; Rollup into a run
;;======================================================================

;; (if (args:get-arg "-rollup")
;;     (general-run-call 
;;      "-rollup" 
;;      "rollup tests" 
;;      (lambda (target runname keys keyvals)
;;        (runs:rollup-run keys
;; 			keyvals
;; 			(or (args:get-arg "-runname")(args:get-arg ":runname") )
;; 			user))))

;;======================================================================
;; Lock or unlock a run
;;======================================================================

(if (or (args:get-arg "-lock")(args:get-arg "-unlock"))
    (general-run-call 

(if (args:get-arg "-mark-incompletes")
    (begin
      (if (not (launch:setup))
	  (begin
	    (debug:print 0 *default-log-port* "Failed to setup, exiting")
	    (exit 1)))
      (rmt:find-and-mark-incomplete #f)
      (set! *didsomething* #t)))

;;======================================================================
;; Update the tests meta data from the testconfig files
;;======================================================================

(if (args:get-arg "-update-meta")
    (begin
      (if (not (launch:setup))
	  (begin
	    (debug:print 0 *default-log-port* "Failed to setup, exiting") 
	    (exit 1)))
      (runs:update-all-test_meta #f)
      (set! *didsomething* #t)))

;;======================================================================
;; Start a repl
;;======================================================================

;; fakeout readline
;; (include "readline-fix.scm")


(when (args:get-arg "-diff-rep")
  (when (and
         (not (args:get-arg "-diff-html"))
         (not (args:get-arg "-diff-email")))
    (debug:print 0 *default-log-port* "Must specify -diff-html or -diff-email with -diff-rep")

	    ;; (exit)
	    ;; EOF

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

	;; (if *use-new-readline*
	;; 	  (begin
	;; 	    (install-history-file (get-environment-variable "HOME") ".megatest_history") ;;  [homedir] [filename] [nlines])
	;; 	    (current-input-port (make-readline-port "megatest> ")))
	;; 	  (begin
	;; 	    (gnu-history-install-file-manager
	;; 	     (string-append
	;; 	      (or (get-environment-variable "HOME") ".") "/.megatest_history"))
	;; 	    (current-input-port (make-gnu-readline-port "megatest> "))))
	      (if (args:get-arg "-repl")
		  (repl)
		  (load (args:get-arg "-load")))
	      ;; (db:close-all dbstruct) <= taken care of by on-exit call
	      )
	    (exit)))
	  (set! *didsomething* #t))))

           (debug:print 0 *default-log-port* "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*)
           (exit 0))
        (case *globalexitstatus*
         ((0)(exit 0))
         ((1)(exit 1))
         ((2)(exit 2))
         (else (exit 3)))))
)

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


;; (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) posix-extras directory-utils call-with-environment-variables)
;; (import (prefix sqlite3 sqlite3:))
;; 
;; (declare (unit mt))
;; (declare (uses db))
;; (declare (uses common))
;; (declare (uses items))
;; (declare (uses runconfig))
;; (declare (uses tests))
;; (declare (uses server))
;; (declare (uses runs))
;; (declare (uses rmt))
;; ;; (declare (uses filedb))
;; 
;; (include "common_records.scm")
;; (include "key_records.scm")
;; (include "db_records.scm")
;; (include "run_records.scm")
;; (include "test_records.scm")

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

;;======================================================================
;;  R U N S
;;======================================================================

			actual-state  " "
			actual-status " "
			event-time
			))
	 (prev-nbfake-log (get-environment-variable "NBFAKE_LOG")))
    (setenv "NBFAKE_LOG" (conc (cond
				((and (directory-exists? test-rundir)
				      (file-writable? test-rundir))
				 test-rundir)
				((and (directory-exists? *toppath*)
				      (file-writable? *toppath*))
				 *toppath*)
				(else (conc "/tmp/" (current-user-name))))
			       "/" logname))
    (debug:print-info 0 *default-log-port* "TRIGGERED on " trigger ", running command " fullcmd " output at " (get-environment-variable "NBFAKE_LOG"))
    ;; (call-with-environment-variables
    ;;  `(("NBFAKE_LOG" . ,(conc test-rundir "/" logname)))
    ;;  (lambda ()

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

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

(import scheme chicken.base chicken.process-context srfi-69 srfi-1)


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

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

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

(module mutils
    *

  (import scheme

	  chicken.base
	  chicken.file
	  chicken.file.posix
	  chicken.port
	  chicken.process
	  chicken.process-context
	  chicken.random
	  chicken.condition
	  chicken.io
	  chicken.time
	  chicken.string
	  
	  ;; data-structures posix
	  srfi-1
	  ;; srfi-13
	  srfi-69
	  srfi-98

	  regex


	  matchable
	  sparse-vectors
	  system-information
	  
	  )


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

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



;; this is a simple two dimensional sparse array

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

	   (apply mutils:hier-list-get @hierlist @path))))

;;======================================================================
;; Other utils
;;======================================================================

(define (check-write-create fpath)
  (and (file-writable? fpath)
       (let ((fname (conc fpath "/.junk-" (current-seconds) "-"
			  (pseudo-random-integer 10000))))
	 ;;(print "trying to create/remove " fname)
	 (handle-exceptions
	  exn
	  #f
	  (begin
	    (with-output-to-file fname
	      (lambda ()

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

;; (use csv-xml regex)
;; (declare (unit ods))
;; (declare (uses common))

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

pktdb-pktspec

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

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

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

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

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

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

(include "pkts/pkts.scm")

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

;; (require-extension (srfi 18) extras tcp s11n)
;; 
;; (use sqlite3 srfi-1 posix srfi-69 hostinfo dot-locking z3)
;; (import (prefix sqlite3 sqlite3:))
;; 
;; (declare (unit portlogger))
;; (declare (uses db))

;; lsof -i

(define (portlogger:open-db fname)
  (let* ((avail    (tasks:wait-on-journal fname 5 remove: #t)) ;; wait up to about 10 seconds for the journal to go away
	 (exists   (common:file-exists? fname))
	 (db       (if avail 
		       (sqlite3:open-database fname)
		       (begin
			 (system (conc "rm -f " fname))
			 (sqlite3:open-database fname))))
	 (handler  (sqlite3:make-busy-timeout 136000))
	 (canwrite (file-writable? fname)))
	 ;; (db-init  (lambda ()
	 ;;             (sqlite3:execute 
	 ;;              db
	 ;;              "CREATE TABLE IF NOT EXISTS ports (
         ;;                 port INTEGER PRIMARY KEY,
         ;;                 state TEXT DEFAULT 'not-used',
         ;;                 fail_count INTEGER DEFAULT 0,

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

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

;;======================================================================
;; Process convience utils
;;======================================================================

;;  (use regex directory-utils)
;;  (declare (unit process))

(define (process:conservative-read port)
  (let loop ((res ""))
    (if (not (eof-object? (peek-char port)))
	(loop (conc res (read-char port)))
	res)))

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

;; (use format typed-records) ;; RADT => purpose of json format??
;; 
;; (declare (unit rmt))
;; (declare (uses api))
;; (declare (uses http-transport))
;; (include "common_records.scm")
;; (declare (uses rmtmod))

;; (import rmtmod)

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

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

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

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

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

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

;;======================================================================
;; read a config file, loading only the section pertinent
;; to this run field1val/field2val/field3val ...
;;======================================================================

;; (use format directory-utils)
;; 
;; (declare (unit runconfig))
;; (declare (uses common))
;; 
;; (include "common_records.scm")

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

;; NB// to process a runconfig ensure to use environ-patt with target!

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

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

;; (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) 
;;      posix-extras directory-utils pathname-expand typed-records format  sxml-serializer
;;      sxml-modifications matchable)
;; 
;; (declare (unit runs))
;; (declare (uses db))
;; (declare (uses common))
;; (declare (uses items))
;; (declare (uses runconfig))
;; (declare (uses tests))
;; (declare (uses server))
;; (declare (uses mt))
;; (declare (uses archive))
;; ;; (declare (uses filedb))
;; 
;; (include "common_records.scm")
;; (include "key_records.scm")
;; (include "db_records.scm")
;; (include "run_records.scm")
;; (include "test_records.scm")
;; 
;; (include "debugger.scm")

;; use this struct to facilitate refactoring
;;

(defstruct runs:dat
  reglen regfull

	 (rtime  0)
	 (startt (current-seconds))
	 (endt   (+ startt duration)))
    ((or proc runs:parallel-runners-mgmt) rdat)
    (let loop ()
      (let* ((wstart (current-seconds)))
	(if (< wstart endt)
	    (let* ((work-time (pseudo-random-integer 10)))
	      #;(debug:print-info 0 *default-log-port* "working for " work-time
				" seconds. Total work: " rtime ", elapsed time: " (- wstart startt))
	      (thread-sleep! work-time)
	      (set! rtime (+ rtime work-time))
	      ((or proc runs:parallel-runners-mgmt) rdat)
	      (loop)))))
    (let* ((done-time (current-seconds)))

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

	 (rp-mutex     (make-mutex))
	 (bup-mutex    (make-mutex))
         (keep-records (args:get-arg "-keep-records")) ;; used in conjunction with -remove-runs to keep the records, TODO: consolidate this with "mode".
	 (test-records '())) ;; for tasks that we wish to operate on all tests in one fell swoop

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

                                        (if (and (not (string=  rundir "/tmp/badname")) 
                                             (file-exists? rundir)
                                             (substring-index run-name rundir)
                                             (tests:glob-like-match (conc "%/" target "/%") rundir)
                                             )
                                          (begin
                                            (set! lasttpath (db:test-get-rundir new-test-dat)) ;; remember this path for run removal
                                            (set! lastrealpath (remove-last-path-directory (realpath lasttpath)))
                                            (hash-table-set! run-paths-hash lastrealpath 1)
                                            (runs:remove-test-directory new-test-dat mode) ;; 'remove-all)
                                          )
                                          (begin
                                            (debug:print 2 *default-log-port* "Not removing directory " rundir " because either it doesn't exist or has a bad name")
                                            (debug:print 2 *default-log-port* "Is /tmp/badname: " (string=  rundir "/tmp/badname"))
                                            (debug:print 2 *default-log-port* "Exists: " (file-exists? rundir))

      ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "CLEANING" "LOCKED" #f))
      ((remove-all)      (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "REMOVING" "LOCKED" #f))
      ((archive-remove)  (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVE_REMOVING" #f #f)))
    (debug:print-info 1 *default-log-port* "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir)
    (if (and real-dir 
	     (> (string-length real-dir) 5)
	     (common:file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc.
	(let* ((realpath (realpath run-dir)))
	  (debug:print-info 1 *default-log-port* "Recursively removing " realpath)
	  (if (common:file-exists? realpath)
	      (runs:safe-delete-test-dir realpath)
	      (debug:print 0 *default-log-port* "WARNING: test dir " realpath " appears to not exist or is not readable")))
	(if real-dir 
	    (debug:print 0 *default-log-port* "WARNING: directory " real-dir " does not exist")
	    (debug:print 0 *default-log-port* "WARNING: no real directory corrosponding to link " run-dir ", nothing done")))

(define doc-template 
  '(*TOP*
    (*PI* xml "version='1.0'")
    (testsuite)))

(define (runs:update-junit-test-reporter-xml run-id)

  (let*	((junit-test-reporter	(configf:lookup *configdat* "runs" "junit-test-reporter-xml"))
	 (junit-test-report-dir  (configf:lookup *configdat* "runs" "junit-test-report-dir"))
	 (xml-dir		(if (and junit-test-reporter (equal? junit-test-reporter "yes" ))
				    (if junit-test-report-dir
					junit-test-report-dir
					(conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME")))
				    #f))
	 (xml-ts-name		(if xml-dir

			 (test-itempath	(vector-ref test 11))
			 (tc-name	(conc test-name (if (and test-itempath (not (equal? test-itempath ""))) (conc "." (string-translate test-itempath "/" "." )) "")))
			 (test-state	(vector-ref test 3))
			 (comment	(vector-ref test 14))   
			 (test-status	(vector-ref test 4))
			 (exc-msg	(conc "No bucket for State " test-state " Status " test-status))
			 (new-doc	(cond 
					 ((member test-state (list "RUNNING" ))
					  ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inProgress)))) doc))
					 ((member test-state (list "LAUNCHED" "REMOTEHOSTSTART"  "NOT_STARTED"))
					  ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inQueue)))) doc))
					 ((member test-status (list "PASS" "WARN" "WAIVED"))
					  ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name))))) doc))
					 ((member test-status (list "FAIL" "CHECK"))
					  ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "failure")))))) doc)) 
					 ((member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED"))
					  ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "error")))))) doc))
					 ((member test-status (list "SKIP"))
					  ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (skipped (@ (type "skipped")))))) doc))
					 (else 
					  (debug:print 0 *default-log-port* (conc "What do I do with State " test-state " Status " test-status))
					  ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,exc-msg) (type "error")))))) doc))))
			 (new-error-cnt	(if (member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED"))
					    (+ error-cnt 1) 
					    error-cnt))
			 (new-fail-cnt	(if (member test-status (list "FAIL" "CHECK"))
					    (+ fail-cnt 1)
					    fail-cnt)))
 	      (if (null? tail)
		    (let* ((final-doc ((modify `("testsuite" insert-into (@ (name ,xml-ts-name) (tests ,tests-count) (errors ,error-cnt) (failures ,fail-cnt)))) new-doc)))
		    (debug:print 0 *default-log-port* "modify attrib error=" error-cnt " fail= " fail-cnt)
		    (handle-exceptions
		     exn
		     (let*	((msg	((condition-property-accessor 'exn 'message) exn)))
		       (debug:print 0 *default-log-port* (conc "WARNING: Failed to update file" xml-path". Message:" msg ", exn=" exn)))
		     		   
		     (if (not (file-exists? xml-dir)) 

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

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

(define (server:make-server-url hostport)
  (if (not hostport)
      #f
      (conc "http://" (car hostport) ":" (cadr hostport))))

(define  *server-loop-heart-beat* (current-seconds))

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

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

        ;; Get the list of server logs that do not contain "exiting". Ignore logs for servers that have exited.
	(let* ((server-logs-cmd  (conc "grep -iL exiting " areapath "/logs/server-*-*.log"))
               (server-logs   (string-split (string-chomp (call-with-input-pipe server-logs-cmd read-string))))
	       (num-serv-logs (length server-logs)))
	  (if (or (null? server-logs) (= num-serv-logs 0))
              (let ()
                 (debug:print 1  *default-log-port* "There are no servers running")
	         '()
              )
	      (let loop ((hed  (string-chomp (car server-logs)))

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

	#f)))

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

(define (server:record->id servr)
  (handle-exceptions
   exn
   (begin 

	     (call-num     (car last-run-dat))
	     (when-run     (cadr last-run-dat))
	     (run-delay    (+ (case call-num
				((0)    0)
				((1)   20)
				((2)  300)
				(else 600))
			      (pseudo-random-integer 5)))   ;; add a small random number just in case a lot of jobs hit the work hosts simultaneously
	     (lock-file    (conc areapath "/logs/server-start.lock")))
	(if	(> (- (current-seconds) when-run) run-delay)
		(let* ((start-flag (conc areapath "/logs/server-start-last")))
		  (common:simple-file-lock-and-wait lock-file expire-time: 15)
                  (debug:print-info  0 *default-log-port* "server:kind-run: touching " start-flag)
		  (system (conc "touch " start-flag)) ;; lazy but safe
		  (server:run areapath)

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

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

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

(declare (unit stml2))

(include "stml2/stml2.scm")

(import stml2)

(write "true")

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

;; (declare (unit cookie))

(module cookie
    *

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

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

;; stml is a list of html strings

;; (declare (unit stml))

(module stml2
    *

  (import

    (chicken base)
    (chicken blob)
    (chicken condition)
    (chicken file)
    (chicken format)
    (chicken io)
    (chicken pathname)
    (chicken port)
    (chicken process)
    (chicken process-context posix)
    (chicken process-context)
    (chicken random)
    (chicken string)
    (chicken time posix)
    (chicken time)
    (prefix crypt c:)
    (prefix dbi dbi:)
    cookie
    queues
    regex
    scheme
    srfi-1
    srfi-13
    srfi-69
    typed-records



    )

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

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

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

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

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

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

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

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

   ((string? val)  (string->number val))
   ((symbol? val)  (string->number (symbol->string val)))
   (else     #f)))

;; NB// this is *illegal* pgint
(define (s:illegal-pgint val)
  (cond
   ((> val 2147483640.0) 1)   ;;  2147483647
   ((< val -2147483640.0) -1) ;; -2147483648
   (else #f)))

(define (s:any->pgint val)
  (let ((n (s:any->number val)))
    (if n
	(if (s:illegal-pgint n)
	    #f

	(formdat:load-all-port (current-input-port))
	(make-formdat:formdat))))

;; (s:process-cgi-input (caaar dat))
(define (formdat:load-all-port inp)
  (let* ((formdat        (make-formdat:formdat))
	 (debugp         #f))
    ;; (open-output-file (conc "/tmp/delme-" (current-user-id) ".log"))))
    ;; (write-string (read-string #f inp) #f debugp)  ;; destroys all data!
    (formdat:initialize formdat)
    (let ((alldats (formdat:dat->list inp 10e6 debug-port: #f debugp)))
      
      #;(if debugp (format debugp "formdat : alldats: ~A\n" alldats))

      (let ((firstitem   (car alldats))
	    (multipass #f)) 
	(if (and (not (null? firstitem))
		 (not (null? (car firstitem))))
	    (if (string-match formdat:delim-patt-rex (caar firstitem))
		(set! multipass #t)))

	    ;; 		       (munged (s:process-cgi-input datstr)))
	    ;; 		  (print "datstr: " datstr " munged: " munged)
	    (if (and (not (null? alldats))
		     (not (null? (car alldats)))
		     (not (null? (caar alldats))))
		(formdat:load formdat  (s:process-cgi-input (caaar alldats))))) ;; munged))
	;;		    (format debugp "formdat : name: ~A content: ~A\n" name content)
	#;(if debugp (close-output-port debugp))
	;; (sdat-formdat-set! s:session formdat)
	formdat))))
		
#|
(define inp (open-input-file "tests/example.post.in"))
(define dat (read-string #f inp))
(define datstr (open-input-string dat))

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

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

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

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

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


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

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

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

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

;; (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) 
;;      posix-extras directory-utils pathname-expand typed-records format
;;      call-with-environment-variables)
;; (declare (unit subrun))
;; ;;(declare (uses runs))
;; (declare (uses db))
;; (declare (uses common))
;; ;;(declare (uses items))
;; ;;(declare (uses runconfig))
;; ;;(declare (uses tests))
;; ;;(declare (uses server))
;; (declare (uses mt))
;; ;;(declare (uses archive))
;; ;; (declare (uses filedb))
;; 
;; ;(include "common_records.scm")
;; ;;(include "key_records.scm")
;; (include "db_records.scm") ;; provides db:test-get-id
;; ;;(include "run_records.scm")
;; ;;(include "test_records.scm")

(define (subrun:subrun-test-initialized? test-run-dir)
  (if (and (common:file-exists? (conc test-run-dir "/subrun-area") )
           (common:file-exists? (conc test-run-dir "/testconfig.subrun") ))
      #t
      #f))

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

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

;; (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format)
;; (import (prefix sqlite3 sqlite3:))
;; 
;; (declare (unit tasks))
;; (declare (uses db))
;; (declare (uses rmt))
;; (declare (uses common))
;; (declare (uses pgdb))

;; (import pgdb) ;; pgdb is a module

(include "task_records.scm")
(include "db_records.scm")

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

	     (print-call-chain (current-error-port))
	     (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
	     (debug:print 5 *default-log-port* " exn=" (condition->list exn))))
       (let* ((dbpath        (db:dbfile-path )) ;; (tasks:get-task-db-path))
	      (dbfile       (conc dbpath "/monitor.db"))
	      (avail        (tasks:wait-on-journal dbpath 10)) ;; wait up to about 10 seconds for the journal to go away
	      (exists       (common:file-exists? dbpath))
	      (write-access (file-writable? dbpath))
	      (mdb          (cond ;; what the hek is *toppath* doing here?
			     ((and (string? *toppath*)(file-writable? *toppath*))
			      (sqlite3:open-database dbfile))
			     ((file-readable? dbpath)    (sqlite3:open-database dbfile))
			     (else (sqlite3:open-database ":memory:")))) ;; (never-give-up-open-db dbpath))
	      (handler      (sqlite3:make-busy-timeout 36000)))
	 (if (and exists
		  (not write-access))
	     (set! *db-write-access* write-access)) ;; only unset so other db's also can use this control
	 (sqlite3:set-busy-handler! mdb handler)
	 (db:set-sync mdb) ;; (sqlite3:execute mdb (conc "PRAGMA synchronous = 0;"))
	 ;;  (if (or (and (not exists)
	 ;; 	      (file-writable? *toppath*))
	 ;; 	 (not (file-readable? dbpath)))
	 ;;      (begin
	 ;; 
	 ;; TASKS QUEUE MOVED TO main.db
	 ;;
	 ;; (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY,
         ;;                        action TEXT DEFAULT '',
         ;;                        owner TEXT,