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 apimod.scm commonmod.scm	\
            dbmod.scm rmtmod.scm debugprint.scm mtver.scm	\
            csv-xml.scm servermod.scm hostinfo.scm

# commonmod.scm dbmod.scm adjutant.scm ulex.scm	\
#            rmtmod.scm apimod.scm

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

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

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

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








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
mofiles/apimod.o mofiles/dbmod.o mofiles/rmtmod.o : mofiles/commonmod.o
mofiles/commonmod.o : mofiles/mtargs.o mofiles/debugprint.o mofiles/megatest-version.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

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

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

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


(module apimod
	*
	
(import scheme
	(prefix sqlite3 sqlite3:)

	typed-records
	srfi-18

	commonmod

	)


)

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

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














































;;======================================================================
;; S T A T E S   A N D   S T A T U S E S
;;======================================================================

;; BBnote: *common:std-states* - dashboard filter control and test control state buttons defined here; used in set-fields-panel and dboard:make-controls
(define *common:std-states*   ;; for toggle buttons in dashboard
  '(

  (time->string (seconds->local-time (current-seconds)) "%Y-%m-%d %H:%M:%S"))

;;======================================================================
;; currently the primary job of the watchdog is to run the sync back to megatest.db from the db in /tmp
;; if we are on the homehost and we are a server (by definition we are on the homehost if we are a server)
;;
(define (common:readonly-watchdog dbstruct)
  (let ((just-testing 0.0501))
    (thread-sleep! just-testing)) ;; (/ 1 20)) ;; 0.051) ;; delay for startup
  (debug:print-info 13 *default-log-port* "common:readonly-watchdog entered.")
  ;; sync megatest.db to /tmp/.../megatst.db
  (let* ((sync-cool-off-duration   3)
        (golden-mtdb     (dbr:dbstruct-mtdb dbstruct))
        (golden-mtpath   (db:dbdat-get-path golden-mtdb))
        (tmp-mtdb        (dbr:dbstruct-tmpdb dbstruct))
        (tmp-mtpath      (db:dbdat-get-path tmp-mtdb)))

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

;; 
;;     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 commonmod))
(declare (uses mtver))

(module commonmod
	*
	
(import scheme
	chicken.base
	chicken.condition
	chicken.file
	chicken.time
	chicken.file.posix
	chicken.process-context.posix
	chicken.io
	chicken.string
	
	(prefix sqlite3 sqlite3:)
	
	system-information
	typed-records
	md5
	message-digest
	regex
	srfi-1
	srfi-18
	srfi-69

	mtver
	)

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


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

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

;;
(define (common:simple-file-lock fname #!key (expire-time 300))

  (let ((fmod-time (handle-exceptions
		       ext

		     (current-seconds)

		     (file-modification-time fname))))



    (if (file-exists? fname)







	(if (> (- (current-seconds) fmod-time) expire-time)




	    (begin


	      (handle-exceptions exn #f (delete-file* fname))	
	      (common:simple-file-lock fname expire-time: expire-time))


	    #f)



	(let ((key-string (conc (get-host-name) "-" (current-process-id))))





	  (with-output-to-file fname





	    (lambda ()
	      (print key-string)))
	  (thread-sleep! 0.251)




	  (if (file-exists? fname)
	      (handle-exceptions exn
                #f 
                (with-input-from-file fname
	  	  (lambda ()
		    (equal? key-string (read-line)))))

	      #f)))))




(define (common:simple-file-lock-and-wait fname #!key (expire-time 300))




  (let ((end-time (+ expire-time (current-seconds))))
    (let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time)))
      (if got-lock

	  #t
	  (if (> end-time (current-seconds))


	      (begin

		(thread-sleep! 3)
		(loop (common:simple-file-lock fname expire-time: expire-time)))





	      #f)))))



(define (common:simple-file-release-lock fname)




  (handle-exceptions
      exn



      #f ;; I don't really care why this failed (at least for now)








    (delete-file* fname)))








)

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

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

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

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

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

(module configfmod
	*
	
(import scheme

	chicken.base
	chicken.condition
	chicken.file
	chicken.io
	chicken.pathname
	chicken.port
	chicken.pretty-print
	chicken.process
	chicken.process-context
	chicken.sort
	chicken.string
	chicken.time

	debugprint
	mtargs
	pkts
	
	(prefix base64 base64:)
	(prefix dbi dbi:)
	(prefix sqlite3 sqlite3:)
	(srfi 18)
	directory-utils
	format
	matchable
	md5
	message-digest
	regex
	regex-case
	sparse-vectors
	srfi-1
	srfi-13
	srfi-69
	stack
	typed-records
	z3
	
	)

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

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

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

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

(define (configf:section-var-set! cfgdat section-name var value #!key (metadata #f))
  (hash-table-set! cfgdat section-name
		   (configf:assoc-safe-add
		    (hash-table-ref/default cfgdat section-name '())
		    var value metadata: metadata)))

;; use to have definitive setting:
;;  [foo]
;;  var yes
;;
;;  (configf:var-is? cfgdat "foo" "var" "yes") => #t
;;
(define (configf:var-is? cfgdat section var expected-val)
  (equal? (configf:lookup cfgdat section var) expected-val))

;; redefines
(define config-lookup configf:lookup)

;; safely look up a value that is expected to be a number, return
;; a default (#f unless provided)
;;
(define (configf:lookup-number cfdat section varname #!key (default #f))
  (let* ((val (configf:lookup cfdat section varname))
         (res (if val
                  (string->number (string-substitute "\\s+" "" val #t))
                  #f)))
    (cond
     (res  res)
     (val  (debug:print 0 *default-log-port* "ERROR: no number found for [" section "], " varname ", got: " val))
     (else default))))

(define (configf:section-vars cfgdat section)
  (let ((sectdat (hash-table-ref/default cfgdat section '())))
    (if (null? sectdat)
	'()
	(map car sectdat))))

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

(define (configf:set-section-var cfgdat section var val)
  (let ((sectdat (configf:get-section cfgdat section)))
    (hash-table-set! cfgdat section
                     (configf:assoc-safe-add sectdat var val))))

;;======================================================================the end

;; return list (path fullpath configname)
(define (find-config configname #!key (toppath #f))
  (if toppath
      (let ((cfname (conc toppath "/" configname)))
	(if (file-exists? cfname)
	    (list toppath cfname configname)
	    (list #f      #f     #f)))
      (let* ((cwd (string-split (current-directory) "/")))
	(let loop ((dir cwd))
	  (let* ((path     (conc "/" (string-intersperse dir "/")))
		 (fullpath (conc path "/" configname)))
	    (if (file-exists? fullpath)
		(list path fullpath configname)
		(let ((remcwd (take dir (- (length dir) 1))))
		  (if (null? remcwd)
		      (list #f #f #f) ;;  #f #f) 
		  (loop remcwd)))))))))

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

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

(define configf:include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$"))
(define configf:script-rx  (regexp "^\\[scriptinc\\s+(\\S+)([^\\]]*)\\]\\s*$")) ;; include output from a script
(define configf:section-rx (regexp "^\\[(.*)\\]\\s*$"))
(define configf:blank-l-rx (regexp "^\\s*$"))
(define configf:key-sys-pr (regexp "^(\\S+)\\s+\\[system\\s+(\\S+.*)\\]\\s*$"))
(define configf:key-val-pr (regexp "^(\\S+)(\\s+(.*)|())$"))
(define configf:key-no-val (regexp "^(\\S+)(\\s*)$"))
(define configf:comment-rx (regexp "^\\s*#.*"))
(define configf:cont-ln-rx (regexp "^(\\s+)(\\S+.*)$"))
(define configf:settings   (regexp "^\\[configf:settings\\s+(\\S+)\\s+(\\S+)]\\s*$"))

;; read a line and process any #{ ... } constructs

(define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get|rget|scm|sh|rp|gv|g|mtrah)\\s+([^\\}\\{]*)\\}(.*)"))

(define (configf:system ht cmd)
  (system cmd)
  )

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

;; Run a shell command and return the output as a string
(define (shell cmd)
  (let* ((output (process:cmd-run->list cmd))
	 (res    (car output))
	 (status (cadr output)))
    (if (equal? status 0)
	(let ((outres (string-intersperse 
		       res
		       "\n")))
	  (debug:print-info 4 *default-log-port* "shell result:\n" outres)
	  outres)
	(begin
	  (with-output-to-port (current-error-port)
	    (lambda ()
	      (print "ERROR: " cmd " returned bad exit code " status)))
	  ""))))

;; this was inline but I'm pretty sure that is a hold over from when it was *very* simple ...
;;
(define (configf:read-line p ht allow-processing settings)
  (let loop ((inl (read-line p)))
    (let ((cont-line (and (string? inl)
			  (not (string-null? inl))
			  (equal? "\\" (string-take-right inl 1)))))
      (if cont-line ;; last character is \ 
	  (let ((nextl (read-line p)))
	    (if (not (eof-object? nextl))
		(loop (string-append (if cont-line 
					 (string-take inl (- (string-length inl) 1))
					 inl)
				     nextl))))
	  (let ((res (case allow-processing ;; if (and allow-processing 
		       ;;	   (not (eq? allow-processing 'return-string)))
		       ((#t #f)
			(configf:process-line inl ht allow-processing))
		       ((return-string)
			inl)
		       (else
			(configf:process-line inl ht allow-processing)))))
	    (if (and (string? res)  ;; must set to "no" to force NOT trimming trailing spaces
		     (not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "yes") "no")))
		(string-substitute "\\s+$" "" res)
		res))))))

(define (configf:cfgdat->env-alist section cfgdat-ht allow-system)
  (filter
   (lambda (pair)
     (let* ((var (car pair))
            (val (cdr pair)))
       (cons var
             (cond
              ((and allow-system (procedure? val)) ;; if we decided to use something other than #t or #f for allow-system ('return-procs or 'return-string) , this may become problematic
               (val))
              ((procedure? val) #f)
              ((string? val) val)
              (else "#f")))))
   (append
    (hash-table-ref/default cfgdat-ht "default" '())
    (if (equal? section "default") '() (hash-table-ref/default cfgdat-ht section '())))))

(define (calc-allow-system allow-system section sections)
  (if sections
      (and (or (equal? "default" section)
	       (member section sections))
	   allow-system) ;; account for sections and return allow-system as it might be a symbol such as return-strings
      allow-system))
    
;; given a config hash and a section name, apply that section to all matching sections (using wildcard % or regex if /..../)
;; remove the section when done so that there is no downstream clobbering
;;
(define (configf:apply-wildcards ht section-name)
  (if (hash-table-exists? ht section-name)
      (let* ((vars  (hash-table-ref ht section-name))
	     (rxstr (if (string-contains section-name "%")
			(string-substitute (regexp "%") ".*" section-name)
			(string-substitute (regexp "^/(.*)/$") "\\1" section-name)))
	     (rx    (regexp rxstr)))
	;; (print "\nsection-name: " section-name " rxstr: " rxstr)
        (for-each
         (lambda (section)
	   (if section
	       (let ((same-section (string=? section-name section))
		     (rx-match     (string-match rx section)))
		 ;; (print "section: " section " vars: " vars " same-section: " same-section " rx-match: " rx-match)
		 (if (and (not same-section) rx-match)
		     (for-each
		      (lambda (bundle)
			;; (print "bundle: " bundle)
			(let ((key  (car bundle))
			      (val  (cadr bundle))
			      (meta (if (> (length bundle) 2)(caddr bundle) #f)))
			  (hash-table-set! ht section (configf:assoc-safe-add (hash-table-ref ht section) key val metadata: meta))))
		      vars)))))
         (hash-table-keys ht))))
  ht)

;; read a config file, returns hash table of alists

;; read a config file, returns hash table of alists
;; adds to ht if given (must be #f otherwise)
;; allow-system:
;;    #f - do not evaluate [system
;;    #t - immediately evaluate [system and store result as string
;;    'return-procs -- return a proc taking ht as an argument that may be evaulated at some future time
;;    'return-string -- return a string representing a proc taking ht as an argument that may be evaulated at some future time
;; envion-patt is a regex spec that identifies sections that will be eval'd
;; in the environment on the fly
;; sections: #f => get all, else list of sections to gather
;; post-section-procs alist of section-pattern => proc, where: (proc section-name next-section-name ht curr-path)
;; apply-wildcards: #t/#f - apply vars from targets with % wildcards to all matching sections
;;
(define (read-config path ht allow-system #!key (environ-patt #f)            (curr-section #f)   
		     (sections #f)              (settings (make-hash-table)) (keep-filenames #f)
		     (post-section-procs '())   (apply-wildcards #t) )
  (debug:print 9 *default-log-port* "START: " path)
;; (if *configdat*
;;     (common:save-pkt `((action . read-config)
;;       		 (f      . ,(cond ((string? path) path)
;;       				  ((port?   path) "port")
;;       				  (else (conc path))))
;;                        (T      . configf))
;;       	       *configdat* #t add-only: #t))
  (if (and (not (port? path))
	   (not (file-exists? path))) ;; for case where we are handed a port
      (begin 
	(debug:print-info 1 *default-log-port* "read-config - file not found " path " current path: " (current-directory))
	;; WARNING: This is a risky change but really, we should not return an empty hash table if no file read?
	#f) ;; (if (not ht)(make-hash-table) ht))
      (let ((inp        (if (string? path)
			    (open-input-file path)
			      path)) ;; we can be handed a port
	    (res        (if (not ht)(make-hash-table) ht))
	    (metapath   (if (or (debug:debug-mode 9)
				keep-filenames)
			    path #f))
            (process-wildcards  (lambda (res curr-section-name)
                                  (if (and apply-wildcards
                                           (or (string-contains curr-section-name "%")   ;; wildcard
                                               (string-match "/.*/" curr-section-name))) ;; regex
                                      (begin
                                        (configf:apply-wildcards res curr-section-name)
                                        (hash-table-delete! res curr-section-name))))))  ;; NOTE: if the section is a wild card it will be REMOVED from res 
	(let loop ((inl               (configf:read-line inp res (calc-allow-system allow-system curr-section sections) settings)) ;; (read-line inp))
		   (curr-section-name (if curr-section curr-section "default"))
		   (var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere
		   (lead     #f))
	  (debug:print-info 8 *default-log-port* "curr-section-name: " curr-section-name " var-flag: " var-flag "\n   inl: \"" inl "\"")
	  (if (eof-object? inl) 
	      (begin
                ;; process last section for wildcards
                (process-wildcards res curr-section-name)
		(if (string? path) ;; we received a path, not a port, thus we are responsible for closing it.
		    (close-input-port inp))
		(if (list? sections) ;; delete all sections except given when sections is provided
		    (for-each
		     (lambda (section)
		       (if (not (member section sections))
			   (hash-table-delete! res section))) ;; we are using "" as a dumping ground and must remove it before returning the ht
		     (hash-table-keys res)))
		(debug:print 9 *default-log-port* "END: " path)
                res
                ) ;; retval
	      (regex-case 
	       inl 
	       (configf:comment-rx _                  (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
                                                            curr-section-name #f #f))
               
	       (configf:blank-l-rx _                  (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
                                                            curr-section-name #f #f))
	       (configf:settings   ( x setting val  )
                                   (begin
                                     (hash-table-set! settings setting val)
                                     (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
                                           curr-section-name #f #f)))
               
	       (configf:include-rx ( x include-file )
                                   (let* ((curr-conf-dir (pathname-directory path))
                                          (full-conf     (if (and (absolute-pathname? include-file) (file-exists? include-file))
                                                             include-file
                                                             (common:nice-path 
                                                              (conc (if curr-conf-dir
                                                                        curr-conf-dir
                                                                        ".")
                                                                    "/" include-file)))))
				     (let ((all-matches (sort (handle-exceptions exn
								(begin
								 (debug:print '(2 9) *default-log-port* "glob of " full-conf " gave no match. , exn=" exn)
								 (list))
								(glob full-conf)) string<=?)))
				       (if (null? all-matches)
					   (begin
					     (debug:print '(2 9) #f "INFO: include file(s) matching " include-file " not found (called from " path ")")
					     (debug:print 2 *default-log-port* "        " full-conf))
					   (for-each
					    (lambda (fpath)
					      ;; (push-directory conf-dir)
					      (debug:print 9 *default-log-port* "Including: " full-conf)
					      (read-config fpath res allow-system environ-patt: environ-patt
							   curr-section: curr-section-name sections: sections settings: settings
							   keep-filenames: keep-filenames))
					    all-matches))
				       (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 (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))))))
                                        (debug:print '(2 9) *default-log-port* "Including from script output: " include-script)
                                        ;;  (print "We got here, calling read-config next. Port is: " new-inp-port)
                                        (read-config new-inp-port res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames)
                                        (close-input-port new-inp-port)
                                        (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
                                      (begin
                                        (debug:print 0 *default-log-port* "Script not found or not exectutable: " include-script)
                                        (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))
                                  ) ;; )
	       (configf:section-rx ( x section-name )
                                   (begin
                                     ;; call post-section-procs
                                     (for-each 
                                      (lambda (dat)
                                        (let ((patt (car dat))
                                              (proc (cdr dat)))
                                          (if (string-match patt curr-section-name)
                                              (proc curr-section-name section-name res path))))
                                      post-section-procs)
                                     ;; after gathering the vars for a section and if apply-wildcards is true and if there is a wildcard in the section name process wildcards
                                     ;; NOTE: we are processing the curr-section-name, NOT section-name.
                                     (process-wildcards res curr-section-name)
                                     (if (not (hash-table-ref/default res section-name #f))(hash-table-set! res section-name '())) ;; ensure that mere mention of a section is not lost
                                     (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
                                           ;; if we have the sections list then force all settings into "" and delete it later?
                                           ;; (if (or (not sections) 
                                           ;;	      (member section-name sections))
                                           ;;	  section-name "") ;; stick everything into "". NOPE: We need new strategy. Put stuff in correct sections and then delete all sections later.
                                           section-name
                                           #f #f)))
	       (configf:key-sys-pr ( x key cmd      )
                                   (if (calc-allow-system allow-system curr-section-name sections)
                                       (let ((alist    (hash-table-ref/default res curr-section-name '()))
                                             (val-proc (lambda ()
                                                         (let* ((start-time (current-seconds))
                                                                (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))
                                                                (cmdres     (process:cmd-run->list cmd delta-env-alist-or-hash-table: env-delta)) ;; BB: here is where [system is exec'd.  needs to have env from other vars!
                                                                (delta      (- (current-seconds) start-time))
                                                                (status     (cadr cmdres))
                                                                (res        (car  cmdres)))
                                                           (debug:print-info 4 *default-log-port* "" inl "\n => " (string-intersperse res "\n"))
                                                           (if (not (eq? status 0))
                                                               (begin
                                                                 (debug:print-error 0 *default-log-port* "problem with " inl ", return code " status
                                                                                    " output: " cmdres)))
                                                           (if (> delta 2)
                                                               (debug:print-info 0 *default-log-port* "for line \"" inl "\"\n  command: " cmd " took " delta " seconds to run with output:\n   " res)
                                                               (debug:print-info 9 *default-log-port* "for line \"" inl "\"\n  command: " cmd " took " delta " seconds to run with output:\n   " res))
                                                           (if (null? res)
                                                               ""
                                                               (string-intersperse res " "))))))
                                         (hash-table-set! res curr-section-name 
                                                          (configf:assoc-safe-add alist
                                                                                 key 
                                                                                 (case (calc-allow-system allow-system curr-section-name sections)
                                                                                   ((return-procs) val-proc)
                                                                                   ((return-string) cmd)
                                                                                   (else (val-proc)))
                                                                                 metadata: metapath))
                                         (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
                                       (loop (configf:read-line inp res
                                                                (calc-allow-system allow-system curr-section-name sections)
                                                                settings)
                                             curr-section-name #f #f)))
               
	       (configf:key-no-val ( x key val)
                                   (let* ((alist   (hash-table-ref/default res curr-section-name '()))
                                          (fval    (or (if (string? val) val #f) ""))) ;; fval should be either "" or " " (one or more spaces)
                                     (debug:print 10 *default-log-port* "   setting: [" curr-section-name "] " key " = #t")
                                     (safe-setenv key fval)
                                     (hash-table-set! res curr-section-name 
                                                      (configf:assoc-safe-add alist key fval metadata: metapath))
                                     (loop (configf:read-line inp res
                                                              (calc-allow-system allow-system curr-section-name sections)
                                                              settings)
                                           curr-section-name key #f)))
               
	       (configf:key-val-pr ( x key unk1 val unk2 )
                                   (let* ((alist   (hash-table-ref/default res curr-section-name '()))
                                          (envar   (and environ-patt
							(string-search (regexp environ-patt) curr-section-name) ;; does the section match the envionpatt?
							(and (not (string-null? key))
							     (not (equal? "!" (substring key 0 1)))) ;; ! as leading character is a signature to NOT export to the environment
							;; (string-match "^.*:.*:.*$" key) ;; ;; something:something:something reserved for triggers in runconfigs
							)) 
                                          (realval (if envar
                                                       (configf:eval-string-in-environment val)
                                                       val)))
                                     (debug:print-info 6 *default-log-port* "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name)
                                     (if envar (safe-setenv key realval))
                                     (debug:print 10 *default-log-port* "   setting: [" curr-section-name "] " key " = " val)
                                     (hash-table-set! res curr-section-name 
                                                      (configf:assoc-safe-add alist key realval metadata: metapath))
                                     (loop (configf:read-line inp res
                                                              (calc-allow-system allow-system curr-section-name sections) settings)
                                           curr-section-name key #f)))
	       ;; if a continued line
	       (configf:cont-ln-rx ( x whsp val     )
                                   (let ((alist (hash-table-ref/default res curr-section-name '())))
                                     (if var-flag             ;; if set to a string then we have a continued var
                                         (let ((newval (conc 
                                                        (configf:lookup res curr-section-name var-flag) "\n"
                                                        ;; trim lead from the incoming whsp to support some indenting.
                                                        (if lead
                                                            (string-substitute (regexp lead) "" whsp)
                                                            "")
                                                        val)))
                                           ;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag)
                                           (hash-table-set! res curr-section-name 
                                                            (configf:assoc-safe-add alist var-flag newval metadata: metapath))
                                           (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name var-flag (if lead lead whsp)))
                                         (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))
	       (else (debug:print-error 0 *default-log-port* "problem parsing " path ",\n   \"" inl "\"")
		     (set! var-flag #f)
		     (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))
          ) ;; end loop
        )))
  
;;======================================================================
;; lookup and manipulation routines
;;======================================================================

;; (define (configf:assoc-safe-add alist key val #!key (metadata #f))
;;   (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist)))
;;     (append newalist (list (if metadata
;; 			       (list key val metadata)
;; 			       (list key val))))))
;; 
;; (define (configf:section-var-set! cfgdat section-name var value #!key (metadata #f))
;;   (hash-table-set! cfgdat section-name
;; 		   (configf:assoc-safe-add
;; 		    (hash-table-ref/default cfgdat section-name '())
;; 		    var value metadata: metadata)))
;; 
;; (define (configf:lookup cfgdat section var)
;;   (if (hash-table? cfgdat)
;;       (let ((sectdat (hash-table-ref/default cfgdat section '())))
;; 	(if (null? sectdat)
;; 	    #f
;; 	    (let ((match (assoc var sectdat)))
;; 	      (if match ;; (and match (list? match)(> (length match) 1))
;; 		  (cadr match)
;; 		  #f))
;; 	    ))
;;       #f))
;; 
;; ;; use to have definitive setting:
;; ;;  [foo]
;; ;;  var yes
;; ;;
;; ;;  (configf:var-is? cfgdat "foo" "var" "yes") => #t
;; ;;
;; (define (configf:var-is? cfgdat section var expected-val)
;;   (equal? (configf:lookup cfgdat section var) expected-val))
;; 
;; (define config-lookup configf:lookup)
(define configf:read-file read-config)

;; ;; safely look up a value that is expected to be a number, return
;; ;; a default (#f unless provided)
;; ;;
;; (define (configf:lookup-number cfdat section varname #!key (default #f))
;;   (let* ((val (configf:lookup *configdat* section varname))
;;          (res (if val
;;                   (string->number (string-substitute "\\s+" "" val #t))
;;                   #f)))
;;     (cond
;;      (res  res)
;;      (val  (debug:print 0 *default-log-port* "ERROR: no number found for [" section "], " varname ", got: " val))
;;      (else default))))
;; 
;; (define (configf:section-vars cfgdat section)
;;   (let ((sectdat (hash-table-ref/default cfgdat section '())))
;;     (if (null? sectdat)
;; 	'()
;; 	(map car sectdat))))
;; 
;; (define (configf:get-section cfgdat section)
;;   (hash-table-ref/default cfgdat section '()))
;; 
;; (define (configf:set-section-var cfgdat section var val)
;;   (let ((sectdat (configf:get-section cfgdat section)))
;;     (hash-table-set! cfgdat section
;;                      (configf:assoc-safe-add sectdat var val))))
;; 
;;     ;;(append (filter (lambda (x)(not (assoc var sectdat))) sectdat)
;;     ;;	    (list var val))))
;; 
;;======================================================================
;; setup
;;======================================================================
;;======================================================================

(define (setup)
  (let* ((configf (find-config "megatest.config"))
	 (config  (if configf (read-config configf #f #t) #f)))
    (if config
	(setenv "RUN_AREA_HOME" (pathname-directory configf)))
    config))

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

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

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

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

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


;;======================================================================
;; Non destructive writing of config file
;;======================================================================

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

;; note: I'm cheating a little here. I merely replace "\n" with "\n         "
(define (configf:expand-multi-lines fdat)
  ;; step 1.5 - compress any continued lines
  (if (null? fdat) fdat
      (let loop ((hed (car fdat))
		 (tal (cdr fdat))
		 (res '()))
	(let ((newres (append res (list (string-substitute (regexp "\n") "\n         " hed #t)))))
	  (if (null? tal)
	      newres
	      (loop (car tal)(cdr tal) newres))))))

(define (configf:file->list fname)
  (if (file-exists? fname)
      (let ((inp (open-input-file fname)))
	(let loop ((inl (read-line inp))
		   (res '()))
	  (if (eof-object? inl)
	      (begin
		(close-input-port inp)
		(reverse res))
	      (loop (read-line inp)(cons inl res)))))
      '()))

;;======================================================================
;; Write a config
;;   0. Given a refererence data structure "indat"
;;   1. Open the output file and read it into a list
;;   2. Flatten any multiline entries
;;   3. Modify values per contents of "indat" and remove absent values
;;   4. Append new values to the section (immediately after last legit entry)
;;   5. Write out the new list 
;;======================================================================

(define (configf:write-config indat fname #!key (required-sections '()))
  (let* (;; step 1: Open the output file and read it into a list
	 (fdat       (configf:file->list fname))
	 (refdat  (make-hash-table))
	 (sechash (make-hash-table)) ;; current section hash, init with hash for "default" section
	 (new     #f) ;; put the line to be used in new, if it is to be deleted the set new to #f
	 (secname #f))

    ;; step 2: Flatten multiline entries
    (if (not (null? fdat))(set! fdat (configf:compress-multi-lines fdat)))

    ;; step 3: Modify values per contents of "indat" and remove absent values
    (if (not (null? fdat))
	(let loop ((hed  (car fdat))
		   (tal  (cadr fdat))
		   (res  '())
		   (lnum 0))
	  (regex-case 
	   hed
	   (configf:comment-rx _                  (set! res (append res (list hed)))) ;; (loop (read-line inp) curr-section-name #f #f))
	   (configf:blank-l-rx _                  (set! res (append res (list hed)))) ;; (loop (read-line inp) curr-section-name #f #f))
	   (configf:section-rx ( x section-name ) (let ((section-hash (hash-table-ref/default refdat section-name #f)))
					    (if (not section-hash)
						(let ((newhash (make-hash-table)))
						  (hash-table-set! refdat section-name newhash) ;; was refhash - not sure that refdat is correct here
						  (set! sechash newhash))
						(set! sechash section-hash))
					    (set! new hed) ;; will append this at the bottom of the loop
					    (set! secname section-name)
					    ))
	   ;; No need to process key cmd, let it fall though to key val
	   (configf:key-val-pr ( x key val      )
		       (let ((newval (configf:lookup indat secname key))) ;; was sec, bug or correct?
			 ;; can handle newval == #f here => that means key is removed
			 (cond 
			  ((equal? newval val)
			   (set! res (append res (list hed))))
			  ((not newval) ;; key has been removed
			   (set! new #f))
			  ((not (equal? newval val))
			     (hash-table-set! sechash key newval)
			     (set! new (conc key " " newval)))
			  (else
			   (debug:print-error 0 *default-log-port* "problem parsing line number " lnum "\"" hed "\"")))))
	   (else
	    (debug:print-error 0 *default-log-port* "Problem parsing line num " lnum " :\n   " hed )))
	  (if (not (null? tal))
	      (loop (car tal)(cdr tal)(if new (append res (list new)) res)(+ lnum 1)))
	  ;; drop to here when done processing, res contains modified list of lines
	  (set! fdat res)))

    ;; step 4: Append new values to the section
    (for-each 
     (lambda (section)
       (let ((sdat   '()) ;; append needed bits here
	     (svars  (configf:section-vars indat section)))
	 (for-each 
	  (lambda (var)
	    (let ((val (configf:lookup refdat section var)))
	      (if (not val) ;; this one is new
		  (begin
		    (if (null? sdat)(set! sdat (list (conc "[" section "]"))))
		    (set! sdat (append sdat (list (conc var " " val))))))))
	  svars)
	 (set! fdat (append fdat sdat))))
     (delete-duplicates (append required-sections (hash-table-keys indat))))

    ;; step 5: Write out new file
    (with-output-to-file fname 
      (lambda ()
	(for-each 
	 (lambda (line)
	   (print line))
	 (configf:expand-multi-lines fdat))))))

(define (process:cmd-run->list cmd #!key (delta-env-alist-or-hash-table '()))
  (common:with-env-vars
   delta-env-alist-or-hash-table
   (lambda ()
     (let* ((fh (open-input-pipe cmd))
            (res (port->list fh))
            (status (close-input-pipe fh)))
       (list res status)))))

(define (port->list fh)
  (if (eof-object? fh) #f
      (let loop ((curr (read-line fh))
                 (result '()))
        (if (not (eof-object? curr))
            (loop (read-line fh)
                  (append result (list curr)))
            result))))

;;======================================================================
;; refdb
;;======================================================================

;; 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 (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)
				     (loop (read-line)(cons inl res)))))))
		   (data   '()))
	      (for-each 
	       (lambda (sheet-name)
		 (let* ((dat-path  (conc refdb-path "/" sheet-name ".dat"))
			(ref-dat   (configf:read-file dat-path #f #t))
			(ref-assoc (map (lambda (key)
					  (list key (hash-table-ref ref-dat key)))
					(hash-table-keys ref-dat))))
				   ;; (hash-table->alist ref-dat)))
		   ;; (set! data (append data (list (list sheet-name ref-assoc))))))
		   (set! data (cons (list sheet-name ref-assoc) data))))
	       sheets)
	      (list data "NO ERRORS"))))))

;; map over all pairs in a three level hierarchial alist and apply a function to the keys/val
;;
(define (configf:map-all-hier-alist data proc #!key (initproc1 #f)(initproc2 #f)(initproc3 #f))
  (for-each 
   (lambda (sheetname)
     (let* ((sheettmp  (assoc sheetname data))
	    (sheetdat  (if sheettmp (cadr sheettmp) '())))
       (if initproc1 (initproc1 sheetname))
       (for-each 
	(lambda (sectionname)
	  (let* ((sectiontmp  (assoc sectionname sheetdat))
		 (sectiondat  (if sectiontmp (cadr sectiontmp) '())))
	    (if initproc2 (initproc2 sheetname sectionname))
	    (for-each
	     (lambda (varname)
	       (let* ((valtmp (assoc varname sectiondat))
		      (val    (if valtmp (cadr valtmp) "")))
		 (proc sheetname sectionname varname val)))
	     (map car sectiondat))))
	(map car sheetdat))))
   (map car data))
  data)

;;======================================================================
;;  C O N F I G   T O / F R O M   A L I S T
;;======================================================================

(define (configf:config->alist cfgdat)
  (hash-table->alist cfgdat))

(define (configf:alist->config adat)
  (let ((ht (make-hash-table)))
    (for-each
     (lambda (section)
       (hash-table-set! ht (car section)(cdr section)))
     adat)
    ht))

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


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

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

)

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

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























































































;;======================================================================
;; SQLITE3 HELPERS
;;======================================================================

(define (db:general-sqlite-error-dump exn stmt . params)
  (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) ;; RADT ... how does this work?
    ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn)

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

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

(declare (unit dbmod))

(module dbmod
	*
	
(import scheme
	chicken.base
	(prefix sqlite3 sqlite3:)

	typed-records
	srfi-18
	srfi-69
	
	)

;;======================================================================
;; 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
  (state #f)
  (status #f)
  (count  0)) 

;;======================================================================
;; alist-of-alists
;;======================================================================
;; 
;; (define (db:aa-set! dat key1 key2 val)
;;   (let loop ((

;;======================================================================
;; hash of hashs
;;======================================================================


(define (db:hoh-set! dat key1 key2 val)
  (let* ((subhash (hash-table-ref/default dat key1 #f)))
    (if subhash
	(hash-table-set! subhash key2 val)
	(begin
	  (hash-table-set! dat key1 (make-hash-table))
	  (db:hoh-set! dat key1 key2 val)))))

(define (db:hoh-get dat key1 key2)
  (let* ((subhash (hash-table-ref/default dat key1 #f)))
    (and subhash
	 (hash-table-ref/default subhash key2 #f))))

(define (db:get-cache-stmth dbstruct db stmt)
  (let* ((stmt-cache        (dbr:dbstruct-stmt-cache dbstruct))
	 (stmth             (db:hoh-get stmt-cache db stmt)))
    (or stmth
	(let* ((newstmth (sqlite3:prepare db stmt)))
	  (db:hoh-set! stmt-cache db stmt newstmth)
	  newstmth))))


)

(declare (unit debugprint))
(declare (uses mtargs))

(module debugprint
	*
	
;;(import scheme chicken data-structures extras files ports)
(import scheme
	chicken.base
	chicken.string
	chicken.port
	mtargs
	srfi-1
	)

;;======================================================================
;; debug stuff
;;======================================================================

(define verbosity (make-parameter '()))
(define *default-log-port*  (current-error-port))
	 
;;======================================================================
;; (define (debug:print . params) #f)
;; (define (debug:print-info . params) #f)
;; 
;; (define (set-functions dbgp dbgpinfo)
;;   (set! debug:print dbgp)
;;   (set! debug:print-info dbgpinfo))

;;======================================================================
;; this was cached based on results from profiling but it turned out the profiling
;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching
;; in for now but can probably take it out later.
;;
(define (debug:calc-verbosity vstr arg) ;; arg is 'v (verbose) or 'q (quiet)
  (let* ((res (cond
	       ((number? vstr) vstr)
	       ((not (string?  vstr))   1)
	       ;; ((string-match  "^\\s*$" vstr) 1)
	       (vstr           (let ((debugvals  (filter number? (map string->number (string-split vstr ",")))))
				 (cond
				  ((> (length debugvals) 1) debugvals)
				  ((> (length debugvals) 0)(car debugvals))
				  (else 1))))
	       ((eq? arg 'v)   2) ;; verbose
	       ((eq? arg 'q)   0) ;; quiet
	       (else                   1))))
    (verbosity res)
    res))

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

(define (debug:debug-mode n)
  (let* ((vb (verbosity)))
    (cond
   ((and (number? vb)   ;; number number
	 (number? n))
    (<= n vb))
   ((and (list? vb)     ;; list   number
	 (number? n))
    (member n vb))
   ((and (list? vb)     ;; list   list
	 (list? n))
    (not (null? (lset-intersection! eq? vb n))))
   ((and (number? vb)
	 (list? n))
    (member vb n)))))

(define (debug:print n e . params)
  (if (debug:debug-mode n)
      (with-output-to-port (or e (current-error-port))
	(lambda ()
	  ;; (if *logging*
	      ;; (db:log-event (apply conc params))
	  (apply print params)
	  )))) ;; )

(define (debug:print-error n e . params)
  ;; normal print
  (if (debug:debug-mode n)
      (with-output-to-port (if (port? e) e (current-error-port))
	(lambda ()
	  (apply print "ERROR: " params)
	  )))
  ;; pass important messages to stderr
  (if (and (eq? n 0)(not (eq? e (current-error-port)))) 
      (with-output-to-port (current-error-port)
	(lambda ()
	  (apply print "ERROR: " params)
	  ))))

(define (debug:print-info n e . params)
  (if (debug:debug-mode n)
      (with-output-to-port (if (port? e) e (current-error-port))
	(lambda ()
	  (apply print "INFO: (" n ") " params) ;; res)
	  ))))

)

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

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

(include "hostinfo/hostinfo.scm")

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

(define (http-transport:dec-requests-count-and-close-all-connections)
  (set! *http-requests-in-progress* (- *http-requests-in-progress* 1))
  (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.052)
	      (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

                                    "-")
                                )) "Server run"))
           (th3 (make-thread (lambda ()
                               (debug:print-info 0 *default-log-port* "Server monitor thread started")
                               (http-transport:keep-running)
                               "Keep running"))))
      (thread-start! th2)
      (thread-sleep! 0.252) ;; give the server time to settle before starting the keep-running monitor.
      (thread-start! th3)
      (set! *didsomething* #t)
      (thread-join! th2)
      (exit))))

;; (define (http-transport:server-signal-handler signum)
;;   (signal-mask! signum)

;;     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 autoload))
(declare (uses pkts))
(declare (uses stml2))
(declare (uses cookie))
(declare (uses csv-xml))
(declare (uses hostinfo))

(declare (uses mutils))
(declare (uses ducttape-lib))
(declare (uses mtargs))
(declare (uses commonmod))
(declare (uses apimod))
(declare (uses dbmod))
(declare (uses rmtmod))
(declare (uses servermod))
(declare (uses mtver))

;; (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
	  adjutant
	  csv-xml
	  ducttape-lib
	  hostinfo
	  mtver
	  mutils
	  autoload
	  cookie
	  csv-xml
	  ducttape-lib
	  mtargs
	  pkts
	  stml2
	  (prefix dbi dbi:)

	  apimod
	  commonmod
	  dbmod
	  rmtmod
	  servermod
	  
	  )
	
;; 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 (blahblah)(thread-sleep! 1.234))

(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 "common.scm")
(include "megatest-fossil-hash.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