Megatest

Changes On Branch ee54617ab1fa2231
Login

Changes In Branch v1.6584-ck5 Through [ee54617ab1] Excluding Merge-Ins

This is equivalent to a diff from b6403cb822 to ee54617ab1

2021-04-07
23:25
wip check-in: 50cc8ed2e2 user: matt tags: v1.6584-ck5
22:12
Doesn't compile. WIP check-in: ee54617ab1 user: matt tags: v1.6584-ck5
20:15
Added missing file check-in: 984d886371 user: matt tags: v1.6584-ck5
2021-04-03
06:28
Minor cleanup check-in: 867b8b4e9e user: matt tags: v1.6584-ck5
2021-03-09
21:03
Very odd, missing egg in server.scm, util. check-in: 57b5fb07d6 user: matt tags: v1.65-real
18:48
changed version to 1.6584 check-in: b6403cb822 user: mmgraham tags: v1.65-real
18:45
merged v1.65-real-button-img check-in: 7a3804ade8 user: mmgraham tags: v1.65-real

Modified Makefile from [eb444dcd26] to [f00b41cab1].

17
18
19
20
21
22
23


24
25
26
27
28
29
30
31
32
33
34
35




36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63






64
65
66
67
68
69
70

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


SRCFILES = common.scm items.scm launch.scm ods.scm runconfig.scm	\
           server.scm configf.scm db.scm keys.scm margs.scm		\
           process.scm runs.scm tasks.scm tests.scm genexample.scm	\
           http-transport.scm filedb.scm tdb.scm client.scm mt.scm	\
           ezsteps.scm lock-queue.scm sdb.scm rmt.scm api.scm		\
           subrun.scm portlogger.scm archive.scm env.scm		\
           diff-report.scm cgisetup/models/pgdb.scm

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




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

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

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

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

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

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

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







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

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







>
>
|
|
|
|
|
|
|


|

|
>
>
>
>
|
|















<
<
<
<
<
<
<




>
>
>
>
>
>







17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58







59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75

# 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 adjutant.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!)

Modified adjutant.scm from [7560fecb1c] to [e7bfe77fd6].

18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33

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

(declare (unit adjutant))

(module adjutant *

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

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

)







|
|







18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33

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

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

)

Added altdb-template.scm version [805de76f5f].







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

Modified api.scm from [7029eb2f68] to [a67aba3194].

16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
;;     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







|
|
|
|
|
|







16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
;;     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

Modified apimod.scm from [a7cef484dc] to [dc935cc366].

16
17
18
19
20
21
22
23
24
25
26
27
28
29




30
31

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

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

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

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




(import commonmod)
(import (prefix ulex ulex:))



)







<




|
|
>
>
>
>
|
|
>



16
17
18
19
20
21
22

23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
;;     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

	)


)

Modified archive.scm from [35b9e5966e] to [908fcb316e].

13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
;;     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 "/" itempatt))
	(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-is-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







|
|
|
|
|
|
|
|
|
|






|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|







13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
;;     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

Added attic/widgets.scm version [3a32b6256a].

































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
;;  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)

Added autoload.scm version [2b9f0c7a0d].















































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
;;======================================================================
;; 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")

Added autoload/autoload.egg version [fdfe376fc0].











>
>
>
>
>
1
2
3
4
5
((license "BSD")
 (category lang-exts)
 (author "Alex Shinn")
 (synopsis "Load modules lazily")
 (components (extension autoload)))

Added autoload/autoload.meta version [eeb95f11ac].



















>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
;;; 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"))

Added autoload/autoload.scm version [b29a83f03e].



























































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
;;;; 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))))))

)

Added autoload/autoload.setup version [ca258ae59c].















>
>
>
>
>
>
>
1
2
3
4
5
6
7

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

Added call-with-environment-variables/call-with-environment-variables-core.scm version [018f37fa46].



















































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
(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)))))

Added call-with-environment-variables/call-with-environment-variables.meta version [827824779b].























>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
((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))

Added call-with-environment-variables/call-with-environment-variables.release-info version [a5138452ec].





















>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
(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")

Added call-with-environment-variables/call-with-environment-variables.scm version [9b19c97a90].





















>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
(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"))

Added call-with-environment-variables/call-with-environment-variables.setup version [aa68521cc2].





















>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
(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)

Added call-with-environment-variables/call-with-environment-variables.wiki version [c4f0264957].













































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
== 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]].

Modified cgisetup/models/pgdb.scm from [4136225c9c] to [3f24f4a8cc].

14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
;;     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







|
|
|
|
|
|
|
|
|
|
|
|
|
|
|







14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
;;     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

Modified client.scm from [dc4c7b41e8] to [b72ee8db86].

16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
;;     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*)))







|
|
|
|
|
|
|
|
|
|
|
|







16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
;;     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*)))
121
122
123
124
125
126
127
128
129
130
			  (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 (random (- 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)))))))))








|


121
122
123
124
125
126
127
128
129
130
			  (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)))))))))

Modified common.scm from [82673dacdb] to [1b32ae0d45].

14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29

30
31
32
33
34
35
36
37
38
39
40
41
;;     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)
;; 







|
|
|
|
|
|
|
<
|
>
|
|
|
|
|







14
15
16
17
18
19
20
21
22
23
24
25
26
27

28
29
30
31
32
33
34
35
36
37
38
39
40
41
;;     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)
;; 
173
174
175
176
177
178
179

180
181
182
183
184
185
186
(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)


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

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








>







173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
(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)

197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219





220
221
222
223
224
225
226
(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 (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)))







|


|
|
|
|
|
|
|
|
|
|
|

|
>
>
>
>
>







198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
(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)))
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
;; 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-write-access? 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)







|







596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
;; 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)
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
    (begin
      (debug:print-error 0 *default-log-port* "received bad encoded string \"" instr "\", message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
      (print-call-chain (current-error-port))
      #f)
    (read (open-input-string (base64:base64-decode instr))))
   (read (open-input-string (z3:decode-buffer (base64:base64-decode instr))))))

;; dot-locking egg seems not to work, using this for now
;; if lock is older than expire-time then remove it and try again
;; 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 (common: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.25)
	  (if (common: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)))

;;======================================================================
;; 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
  '(







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







728
729
730
731
732
733
734













































735
736
737
738
739
740
741
    (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
  '(
1002
1003
1004
1005
1006
1007
1008

1009
1010
1011
1012
1013
1014
1015
1016
  (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)

  (thread-sleep! 0.05) ;; 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)))







>
|







963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
  (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)))
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
;;
(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-write-access? hed)
			    hed)
		       (handle-exceptions
			   exn
			   (begin
			     (debug:print-info 0 *default-log-port* "could not create " hed
					       ", this might cause problems down the road. exn=" exn)
			     #f)







|







1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
;;
(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)
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
(define (common:directory-writable? path-string)
  (handle-exceptions
      exn
    (begin
      (debug:print 0 *default-log-port* "Failed to identify access to " path-string ", exn=" exn)
      #f)
   (if (and (directory-exists? path-string)
            (file-write-access? path-string))
       path-string
       #f)))

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







|







1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
(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")
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
				   (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)
						"] Failed to read .homehost file after trying five times. Giving up and exiting, message: "
						((condition-property-accessor 'exn 'message) exn))
				   (exit 1)))
			   (let ((hhf (conc *toppath* "/.homehost")))
			     (if (common:file-exists? hhf)
				 (with-input-from-file hhf read-line)
				 (if (file-write-access? *toppath*)
				     (begin
				       (with-output-to-file hhf
					 (lambda ()
					   (print bestadrs)))
				       (begin
					 (mutex-unlock! *homehost-mutex*)
					 (car (common:get-homehost))))







|







1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
				   (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))))
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
  (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-read-access? fullpath))
	    (handle-exceptions
		exn
	      (begin
		(debug:print 0 *default-log-port* "failed to get cached info from " fullpath ", exn=" exn)
		#f)
	     (debug:print 2 *default-log-port* "reading file " fullpath)
	     (let ((real-age (- (current-seconds)







|







1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
  (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)
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
         (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 (random 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







|







2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
         (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
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
;; 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! (random 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







|







2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
;; 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
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
			", 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 "
			   effective-normalized-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))







|







2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
			", 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))
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
;; 					       ;; at least use 1
;; 	 (loadjmp (- first (if (> next (* numcpus 0.7)) ;; could do something with average of first and next?
;; 			       0
;; 			       next))) ;; we will force a conservative calculation any time next is large.
;; 	 (first-next-avg    (/ (+ first next) 2))
;; 	 ;; add some randomness to the time to break any alignment
;; 	 ;; where netbatch dumps many jobs to machines simultaneously
;;          (adjwait           (min (+ 300 (random 10)) (abs (* (+ (random 10)
;; 								(/ (- 1000 count) 10)
;; 								waitdelay)
;; 							     (- first adjmaxload) ))))
;; 	 (load-jump-limit   (configf:lookup-number *configdat* "setup" "load-jump-limit"))
;; 	 ;; 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"))) ;; (> (random 100) 75) ;; about 25% of the time
;; 	(debug:print-info 1 *default-log-port* "Checking cpuload on " (or remote-host "localhost") ", maxload: " maxload
;;     ", load: " first ", adjmaxload: " adjmaxload ", loadjmp: " loadjmp))
;; 
;;     (debug:print-info 1 *default-log-port*
;; 		      "On host: " effective-host
;; 		      ", effective load: " effective-load
;; 		      ", numcpus: " numcpus







|













|







2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
;; 					       ;; 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
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
     (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-write-access? 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-write-access? 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)







|














|







2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
     (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)
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
     (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-read-access? 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)))







|







3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
     (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)))
3609
3610
3611
3612
3613
3614
3615


















3616
3617
3618
3619
3620
3621
3622
	     (begin
	       (debug:print 0 *default-log-port* "joining threads failed. exn=" exn)
               #t) ;; just ignore it, it might have died in the meantime so joining it will throw an exception
             (thread-join! thread))
           )))
   (hash-table-keys *common:thread-punchlist*)))



















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







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
	     (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"))

Modified common_records.scm from [80f9e14f2d] to [9a86cd2d43].

66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215

216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254

     (with-output-to-port (current-error-port)
       (lambda ()
	 (print ((condition-property-accessor 'exn 'message) exn))
	 (print "Callback error in " procname)
	 (print "Full condition info:\n" (condition->list exn)))))
   (proc)))

;; Need a mutex protected way to get and set values
;; or use (define-simple-syntax ??
;;
(define-inline (with-mutex mtx accessor record . val)
  (mutex-lock! mtx)
  (let ((res (apply accessor record val)))
    (mutex-unlock! mtx)
    res))

;; 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)
  (or (hash-table-ref/default *verbosity-cache* vstr #f)
      (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))))
                  ((args:get-arg "-v")   2)
                  ((args:get-arg "-q")    0)
                  (else                   1))))
        (hash-table-set! *verbosity-cache* vstr 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)
  (cond
   ((and (number? *verbosity*)   ;; number number
	 (number? n))
    (<= n *verbosity*))
   ((and (list? *verbosity*)     ;; list   number
	 (number? n))
    (member n *verbosity*))
   ((and (list? *verbosity*)     ;; list   list
	 (list? n))
    (not (null? (lset-intersection! eq? *verbosity* n))))
   ((and (number? *verbosity*)
	 (list? n))
    (member *verbosity* n))))

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

;; Brandon's debug printer shortcut (indulge me :)
(define *BB-process-starttime* (current-milliseconds))
(define (BB> . in-args)
  (let* ((stack (get-call-chain))
         (location "??"))
    (for-each
     (lambda (frame)
       (let* ((this-loc (vector-ref frame 0))
              (temp     (string-split (->string this-loc) " "))
              (this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???")))
         (if (equal? this-func "BB>")
             (set! location this-loc))))
     stack)
    (let* ((color-on "\x1b[1m")
           (color-off "\x1b[0m")
           (dp-args
            (append
             (list 0 *default-log-port*
                   (conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off "   ")  )
             in-args)))
      (apply debug:print dp-args))))

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



;; register hash tables with BBpp.
(hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE:
                 (cons hash-table? hash-table->alist))

;; test name converter
(define (BBpp_custom_converter arg)
  (let ((res #f))
    (for-each
     (lambda (custom-type-name)
       (let* ((custom-type-info      (hash-table-ref *BBpp_custom_expanders_list* custom-type-name))
              (custom-type-test      (car custom-type-info))
              (custom-type-converter (cdr custom-type-info)))
         (when (and (not res) (custom-type-test arg))
           (set! res (custom-type-converter arg)))))
     (hash-table-keys *BBpp_custom_expanders_list*))
    (if res (BBpp_ res) arg)))

(define (BBpp_ arg)
  (cond
   ;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg)))
   ;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg)))
   ((hash-table? arg)
    (let ((al (hash-table->alist arg)))
      (BBpp_ (cons HASH_TABLE: al))))
   ((null? arg) '())
   ;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
   ((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
   (else (BBpp_custom_converter arg))))

;; Brandon's pretty printer.  It expands hashes and custom types in addition to regular pp
(define (BBpp arg)
  (pp (BBpp_ arg)))

;(use define-macro)
(define-syntax inspect
  (syntax-rules ()
    [(_ x)
    ;; (with-output-to-port (current-error-port)
       (printf "~a is: ~a\n" 'x (with-output-to-string (lambda () (BBpp x))))

     ;;  )
     ]
    [(_ x y ...) (begin (inspect x) (inspect y ...))]))

(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 ()
	  (if *logging*
	      (db:log-event (apply conc params))
	      ;; (apply print "pid:" (current-process-id) " " params)
	      (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 ()
	  (if *logging*
	      (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params))))
		(db:log-event res))
	      ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res)
	      (apply print "INFO: (" n ") " params) ;; res)
	      )))))



;; if a value is printable (i.e. string or number) return the value
;; else return an empty string
(define-inline (printable val)
  (if (or (number? val)(string? val)) val ""))









<
<
<
<
<
<
<
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
66
67
68
69
70
71
72









73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208

209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
     (with-output-to-port (current-error-port)
       (lambda ()
	 (print ((condition-property-accessor 'exn 'message) exn))
	 (print "Callback error in " procname)
	 (print "Full condition info:\n" (condition->list exn)))))
   (proc)))










;;      ;; 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)
;;        (or (hash-table-ref/default *verbosity-cache* vstr #f)
;;            (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))))
;;                        ((args:get-arg "-v")   2)
;;                        ((args:get-arg "-q")    0)
;;                        (else                   1))))
;;              (hash-table-set! *verbosity-cache* vstr 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)
;;        (cond
;;         ((and (number? *verbosity*)   ;; number number
;;      	 (number? n))
;;          (<= n *verbosity*))
;;         ((and (list? *verbosity*)     ;; list   number
;;      	 (number? n))
;;          (member n *verbosity*))
;;         ((and (list? *verbosity*)     ;; list   list
;;      	 (list? n))
;;          (not (null? (lset-intersection! eq? *verbosity* n))))
;;         ((and (number? *verbosity*)
;;      	 (list? n))
;;          (member *verbosity* n))))
;;      
;;      (define (debug:setup)
;;        (let ((debugstr (or (args:get-arg "-debug")
;;      		      (args:get-arg "-debug-noprop")
;;      		      (getenv "MT_DEBUG_MODE"))))
;;          (set! *verbosity* (debug:calc-verbosity debugstr))
;;          (debug:check-verbosity *verbosity* debugstr)
;;          ;; if we were handed a bad verbosity rule then we will override it with 1 and continue
;;          (if (not *verbosity*)(set! *verbosity* 1))
;;          (if (and (not (args:get-arg "-debug-noprop"))
;;      	     (or (args:get-arg "-debug")
;;      		 (not (getenv "MT_DEBUG_MODE"))))
;;      	(setenv "MT_DEBUG_MODE" (if (list? *verbosity*)
;;      				    (string-intersperse (map conc *verbosity*) ",")
;;      				    (conc *verbosity*))))))
;;        
;;      (define (debug:print n e . params)
;;        (if (debug:debug-mode n)
;;            (with-output-to-port (or e (current-error-port))
;;      	(lambda ()
;;      	  (if *logging*
;;      	      (db:log-event (apply conc params))
;;      	      (apply print params)
;;      	      )))))
;;      
;;      ;; Brandon's debug printer shortcut (indulge me :)
;;      (define *BB-process-starttime* (current-milliseconds))
;;      (define (BB> . in-args)
;;        (let* ((stack (get-call-chain))
;;               (location "??"))
;;          (for-each
;;           (lambda (frame)
;;             (let* ((this-loc (vector-ref frame 0))
;;                    (temp     (string-split (->string this-loc) " "))
;;                    (this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???")))
;;               (if (equal? this-func "BB>")
;;                   (set! location this-loc))))
;;           stack)
;;          (let* ((color-on "\x1b[1m")
;;                 (color-off "\x1b[0m")
;;                 (dp-args
;;                  (append
;;                   (list 0 *default-log-port*
;;                         (conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off "   ")  )
;;                   in-args)))
;;            (apply debug:print dp-args))))
;;      
;;      (define *BBpp_custom_expanders_list* (make-hash-table))
;;      
;;      
;;      
;;      ;; register hash tables with BBpp.
;;      (hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE:
;;                       (cons hash-table? hash-table->alist))
;;      
;;      ;; test name converter
;;      (define (BBpp_custom_converter arg)
;;        (let ((res #f))
;;          (for-each
;;           (lambda (custom-type-name)
;;             (let* ((custom-type-info      (hash-table-ref *BBpp_custom_expanders_list* custom-type-name))
;;                    (custom-type-test      (car custom-type-info))
;;                    (custom-type-converter (cdr custom-type-info)))
;;               (when (and (not res) (custom-type-test arg))
;;                 (set! res (custom-type-converter arg)))))
;;           (hash-table-keys *BBpp_custom_expanders_list*))
;;          (if res (BBpp_ res) arg)))
;;      
;;      (define (BBpp_ arg)
;;        (cond
;;         ;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg)))
;;         ;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg)))
;;         ((hash-table? arg)
;;          (let ((al (hash-table->alist arg)))
;;            (BBpp_ (cons HASH_TABLE: al))))
;;         ((null? arg) '())
;;         ;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
;;         ((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
;;         (else (BBpp_custom_converter arg))))
;;      
;;      ;; Brandon's pretty printer.  It expands hashes and custom types in addition to regular pp
;;      (define (BBpp arg)
;;        (pp (BBpp_ arg)))
;;      
;;      ;(use define-macro)
;;      (define-syntax inspect
;;        (syntax-rules ()
;;          [(_ x)
;;          ;; (with-output-to-port (current-error-port)
;;             (printf "~a is: ~a\n" 'x (with-output-to-string (lambda () (BBpp x))))
;;           ;;  )
;;           ]

;;          [(_ x y ...) (begin (inspect x) (inspect y ...))]))
;;      
;;      (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 ()
;;      	  (if *logging*
;;      	      (db:log-event (apply conc params))
;;      	      ;; (apply print "pid:" (current-process-id) " " params)
;;      	      (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 ()
;;      	  (if *logging*
;;      	      (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params))))
;;      		(db:log-event res))
;;      	      ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res)
;;      	      (apply print "INFO: (" n ") " params) ;; res)
;;      	      )))))
;;      
;;      
;;      
;;      ;; if a value is printable (i.e. string or number) return the value
;;      ;; else return an empty string
;;      (define-inline (printable val)
;;        (if (or (number? val)(string? val)) val ""))
;;      
;;      

Modified commonmod.scm from [9423abd515] to [b5e3523a1c].

15
16
17
18
19
20
21

22
23
24
25
26









27




28

29





30
31
32
33
34
35
36
37
38
39
40
41
42


43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100


101
102
103
104
105
106
107
108
109
110
111
112
113
114


115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
;; 
;;     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))


(module commonmod
	*
	
(import scheme chicken data-structures extras files)









(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69




	md5 message-digest

	regex srfi-1)






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

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



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

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


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

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

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


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

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

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

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


		   (else f))))
	     (filter (lambda (x)
		       (not (string-match "^\\s*" x)))
		     val-list))
	'())))

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

(define (get-testsuite-name toppath configdat)
  (or (lookup configdat "setup" "area-name")
      (lookup configdat "setup" "testsuite")
      (get-environment-variable "MT_TESTSUITE_NAME")


      (if (string? toppath)
          (pathname-file toppath)
          #f)))

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

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

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

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

)







>




|
>
>
>
>
>
>
>
>
>
|
>
>
>
>
|
>
|
>
>
>
>
>










<


>
>
|
<
|
|
<
|
|
<
|
<
|
<
<
<
|
<
<
<
<
<
<
<
|
<
<
<
<
|
<
<
|
|
<
<
|
<
<
<
|
<
<
<
<
<
|
<
<
<
<
<
|
|
|
<
<
<
<
|
>
>
|
|
|
<
|

<
<
<
|
<
<
<
<
>
>
|
<
|
|
<
<
|
<
|
|
<
<
<
<
<
|

<
<
|
<
<
<
<
|
|
<
<
<
|
<
<
<
<
<
<
<
<
|
|
<
<
<
<
<
<


15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59

60
61
62
63
64

65
66

67
68

69

70



71







72




73


74
75


76



77





78





79
80
81




82
83
84
85
86
87

88
89



90




91
92
93

94
95


96

97
98





99
100


101




102
103



104








105
106






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








)

Modified configf.scm from [15f0835800] to [7587db552f].

18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38

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

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







|
|
|
|
|
|
|







18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38

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

;;======================================================================
;; 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)
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
				       (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-execute-access? 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))))))







|







356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
				       (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))))))
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729

;; 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-read-access? 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)







|







715
716
717
718
719
720
721
722
723
724
725
726
727
728
729

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

Added configfmod.scm version [d26d1d864a].































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
;;======================================================================
;; 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))
  

)

Added csv-xml.scm version [86b3f1ae82].

















































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
;;  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/>.

;; Always use two or four digit decimal
;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00..

(declare (unit csv-xml))

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

Added csv-xml/csv-out.impl version [a1397a6ff6].











































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
;;;; 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) ) )
|#

Added csv-xml/csv-xml.meta version [fd2d3bfc5b].







































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
;;;; 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") )

Added csv-xml/csv-xml.scm version [63c836b4b4].













































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
;;;; 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

Added csv-xml/csv-xml.setup version [510ab3ecb8].

























>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
;;;; 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))

Added csv-xml/csv.ss version [817d757d1f].



















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
;;; @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)

Modified dashboard-tests.scm from [237d160a6c] to [4ccafc8c2c].

53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85

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







|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|







53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85

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

Modified datashare.scm from [2c1663032f] to [bce23aa6ff].

251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
		(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 (random 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))







|







251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
		(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))

Modified db.scm from [ed256dd44f] to [d384bd54d1].

14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
;;     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/>.
;;
;;======================================================================

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

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







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







14
15
16
17
18
19
20






















































































21
22
23
24
25
26
27
;;     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)
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
;; 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-write-access? parent-dir))
	 (file-exists  (common:file-exists? fname))
	 (file-write   (if file-exists
			   (file-write-access? 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)))







|


|







158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
;; 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)))
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
							 
               (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-write-access? 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))))








|







244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
							 
               (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))))

422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
         (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-write-access? 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
;;







|







336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
         (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
;;
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
;;
(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-write-access? 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
     ;;







|







539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
;;
(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
     ;;
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
    ((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-write-access? (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-write-access? (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)







|





|







627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
    ((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)
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
;;     (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-write-access? 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)







|







951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
;;     (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)
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
          (delete-file* (common:get-sync-lock-filepath))
          )
	 
	 ;; clear out junk records
	 ;;
	 ((dejunk)
	  ;; (db:delay-if-busy mtdb) ;; ok to delay on mtdb
	  (when (file-write-access? (db:dbdat-get-path mtdb)) (db:clean-up mtdb))
	  (db:clean-up tmpdb)
	  (db:clean-up refndb))

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







|







1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
          (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
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
	(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 (random 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))







|







1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
	(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))
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
                (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-read-access? 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)
	)))







|







1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
                (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)
	)))
4882
4883
4884
4885
4886
4887
4888
4889
4890
4891
4892
4893
4894
4895
4896
  (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 "_" (random 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  







|







4796
4797
4798
4799
4800
4801
4802
4803
4804
4805
4806
4807
4808
4809
4810
  (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  

Added dbi.scm version [3f996117f2].















































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
;;======================================================================
;; 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")

Added dbi/dbi.egg version [ce14ed7e9e].











>
>
>
>
>
1
2
3
4
5
((license "BSD")
 (category db)
 (dependencies autoload sql-null)
 (test-dependencies test)
 (components (extension dbi)))

Added dbi/dbi.meta version [df5803e479].











































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
;; -*- 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."))

Added dbi/dbi.release-info version [8881b5e958].















>
>
>
>
>
>
>
1
2
3
4
5
6
7
(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")

Added dbi/dbi.scm version [0d4d10831e].







































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
;;; 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)))))
)

Added dbi/dbi.setup version [e37bd8290c].























>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
;; 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")

Added dbi/example.scm version [fa8cc725eb].











































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
;;; 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;")

Modified dbmod.scm from [2029a02dc3] to [f2badf7d83].

19
20
21
22
23
24
25
26

















27













28


29



30














31
32







33



34


35



36
37





















38
39
;;======================================================================

(declare (unit dbmod))

(module dbmod
	*
	
(import scheme chicken data-structures extras)

















(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18)
















(define (just-testing)



  (print "JUST TESTING"))















;; (define (debug:print . params) #f)







;; (define (debug:print-info . params) #f)



;; 


;; (define (set-functions dbgp dbgpinfo)



;;   (set! debug:print dbgp)
;;   (set! debug:print-info dbgpinfo))






















)







|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>

>
>
|
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
>
>
>
>
>
>
>
|
>
>
>

>
>
|
>
>
>
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>


19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
;;======================================================================

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


)

Added debugprint.scm version [668a77fa42].

























































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
(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)
	  ))))

)

Modified diff-report.scm from [722e4fdcd5] to [9cbd17eb23].

12
13
14
15
16
17
18
19
20
21
22
23
24
25
26

27
28
29
30
31
32
33
;;     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)))







|
|
|
|
|
|
|
|
>







12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
;;     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)))

Modified ducttape/ducttape-lib.scm from [59b0a2f94a] to [c4ffa8169c].

47
48
49
50
51
52
53
54
55
56
57

58
59
60
61
62

63
64
65
66
67
68
69
     current-wwdate
     current-isodate
     *this-exe-dir*
     *this-exe-name*
     *this-exe-fullpath*
     )

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


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


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

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







|
|

|
>


|

|
>







47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
     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
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
("wmx" . "video/x-ms-wmx")
("wvx" . "video/x-ms-wvx")
("avi" . "video/x-msvideo")
("movie" . "video/x-sgi-movie")
("smv" . "video/x-smv")
("ice" . "x-conference/x-cooltalk")))

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







|
|

|







841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
("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"
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070

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


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







|







1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072

      (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.
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
     (let ( (raw-debug-level (get-environment-variable "DUCTTAPE_DEBUG_LEVEL")) )
       (if raw-debug-level
           (let ((num-debug-level (runs-ok (string->number raw-debug-level))))
             (if (integer? num-debug-level)
                 (begin
                   (let ((new-num-debug-level (- num-debug-level 1)))
                     (if (> new-num-debug-level 0) ;; decrement
                         (setenv "DUCTTAPE_DEBUG_LEVEL" (number->string new-num-debug-level))
                         (unsetenv "DUCTTAPE_DEBUG_LEVEL")))
                   num-debug-level) ; it was set and > 0, mode is value
                 (begin
                   (unsetenv "DUCTTAPE_DEBUG_LEVEL") ;; value was invalid, unset it
                   #f))) ; value was invalid, mode is f
           #f)))) ; var not set, mode is f


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

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







|
|


|







1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
     (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
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
            " "))
          (pwd (or (get-environment-variable "PWD") "nopwd"))
          (user (or (get-environment-variable "USER") "nouser"))
          (host (or (get-environment-variable "HOST") "nohost")))
      (if logfile
          (begin
            (ducttape-log-file logfile)
            (setenv "DUCTTAPE_LOG_FILE" (ducttape-log-file))))
      (ducttape-append-logfile 'note (format #f "START - pid=~A ppid=~A argv=(~A) pwd=~A user=~A host=~A" pid ppid argv pwd user host) #t)))         


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







|







1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
            " "))
          (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 
1520
1521
1522
1523
1524
1525
1526


1527
1528
1529
1530
1531
1532
1533
1534
                    )

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

      (define (get-uuid)


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

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








>
>
|







1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
                    )

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

1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
  ;; are sure they can coexist.
  (define (ducttape-process-command-line)

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

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

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

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

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

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


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


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







|






|






|






|







|


















|







|







1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
  ;; 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)
  

Modified env.scm from [028e47144f] to [dcc9cbb083].

14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
;;     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 (







|

|







14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
;;     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 (

Modified ezsteps.scm from [5de5d166c7] to [a411433d05].

15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39


40
41
42
43
44
45
46
;; 
;;     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



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







|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

>
>







15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
;; 
;;     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)))
261
262
263
264
265
266
267

268

269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
		(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))

	(message-window "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 prev-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))







>
|
>







|







263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
		(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))

Deleted fs-transport.scm version [d1050dcefe].

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52

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

(require-extension (srfi 18) extras tcp s11n)

(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)
(import (prefix sqlite3 sqlite3:))

(use spiffy uri-common intarweb http-client spiffy-request-vars)

(tcp-buffer-size 2048)

(declare (unit fs-transport))

(declare (uses common))
(declare (uses db))
(declare (uses tests))
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.

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


;;======================================================================
;; F S   T R A N S P O R T   S E R V E R
;;======================================================================

;; There is no "server" per se but a convience routine to make it non
;; necessary to be reopening the db over and over again.
;;

(define (fs:process-queue-item packet)
  (if (not *dbstruct-db*) ;; we will require that (setup-for-run) has already been called
      (set! *dbstruct-db* (db:setup-db)))
  (debug:print-info 11 *default-log-port* "fs:process-queue-item called with packet=" packet)
  (db:process-queue-item *dbstruct-db* packet))
      
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































Modified gen-data-for-graph.scm from [253156d2fd] to [6f0d8b5e9a].

29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
(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     (random 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)
			   (random 1000)
			   (random 6))))
	     (if (< count 20)
		 (loop (max sec lastsec)(random 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     (random 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)
;; 				     (random 100)
;; 				     (random 6))))
;; 		       (if (< count 20)
;; 			   (loop (max sec lastsec)(random 60)(+ count 1))))))))))
;; 
;; (close-database db)







|






|
|

|













|






|
|

|


29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
(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)

Modified genexample.scm from [c6a2ab2853] to [17c365cd01].

14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
;;     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.
  ;;







|
|
|
|







14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
;;     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.
  ;;

Added hostinfo.scm version [e131d5b66f].















































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
;;======================================================================
;; 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")

Added hostinfo/hostinfo.h version [4f39d60970].



























































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
#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

Added hostinfo/hostinfo.meta version [90c3b6c82d].



















>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
;;; 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))

Added hostinfo/hostinfo.scm version [15139d566b].



















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
;;; 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])

Added hostinfo/hostinfo.setup version [94d320c0dc].























>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
(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")))

Modified http-transport.scm from [2202b22e9f] to [92216113da].

12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
;;     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))








|
|
|
|
|
|
|




|
|
|
|
|
|
|
|
|
|
|
|
|
|

|







12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
;;     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))

222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239

(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.05)
	      (loop etime))
	    (debug:print-error 0 *default-log-port* "requests still in progress after 5 seconds of waiting. I'm going to pass on cleaning up http connections"))
	(close-all-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*)))








|


|







222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239

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

297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
					     (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-all-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"))







|







297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
					     (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"))
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
          (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*)
		      (change-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







|







520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
          (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
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
                                    "-")
                                )) "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.25) ;; 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)







|







610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
                                    "-")
                                )) "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)

Modified items.scm from [16328a4b96] to [4777d396de].

17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
;;     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))







|
|
|
|







17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
;;     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))

Modified keys.scm from [9fa2c0cfa5] to [6b0d666bea].

17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
;;     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)

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







|
|
|
|
|
|
|
|







17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
;;     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)

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

Modified launch.scm from [7e65ac64d4] to [914613830c].

17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
;;     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







|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|







17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
;;     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
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
		      )))
	      (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 (random 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








|







305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
		      )))
	      (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

355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
	       (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-execute-access? 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))







|







355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
	       (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))
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651

	  ;; (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-execute-access? 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)
	    (file-move 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)
			   (change-file-mode 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







|













|










|







612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651

	  ;; (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
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
	     ;; 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-write-access? 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







|







911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
	     ;; 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
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
              )
          (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-read-access? 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)))







|







1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
              )
          (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)))

Modified margs.scm from [812fd1b225] to [c1ea22878c].

12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
;;     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)







|







12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
;;     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)

Deleted megatest-version.scm version [f92dc46346].

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
;;  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/>.

;; Always use two or four digit decimal
;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00..

;; (declare (unit megatest-version))

(define megatest-version 1.6584)
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































Modified megatest.scm from [35ed864745] to [165242d338].

12
13
14
15
16
17
18






19






20
21













































































































22
23


24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45


46
47
48
49
50
51
52



53
54
55
56
57
58
59
60
61
62

63
64
65
66
67
68
69

70
71
72









73
74



75
76
77
78
79

80
81
82
83
84
85
86
87


88
89
90
91
92

93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122






123
124
125
126
127
128

129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155







156
157
158
159

160
161
162


163
164
165
166
167
168
169
170
171
172
173
174
175
176

177
178
179
180
181
182
183
184
185
186
187
188
189
190

191
192


193
194
195


196
197
198
199
200
201
202
203
204


205
206
207
208
209
210
211
212
213
214
215

216
217
218
219
220
221
222
223
224
225
226
227
228
229

230

231
232
233

234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251

252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270

271
272

273
274
275
276


277
278
279
280

281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310


311
312
313
314
315






316



317








318
319


320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336


337

338
339
340
341
342

343
344

345



346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371

372


373



374
375
376

377
378

379






380
381
382
383
384
385
386
387
388
389
390
391
392
393

394
395
396
397
398
399
400
401



402
403
404
405
406


407


408
409

410

411
412

413
414
415


416


417
418
419
420
421


422



423
424
425


426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450



451
452
453
454
455
456
457



458
459
460
461
462
463
464

465
466
467





468


469
470
471

472
473
474
475
476
477
478
479








480
481
482
483
484
485




486
487
488
489
490

491








492
493
494
495
496
497
498
499
500
501
502
503
504
505





506
507
508



509
510
511
512
513
514
515
516
517



518
519






520
521
522
523
524
525

526


527
528
529

530
531
532
533
534
535

536
537
538
539
540
541
542
543
544

545
546
547
548
549
550
551
552


553
554
555
556
557
558
559
560
561
562
563


564
565
566
567
568
569
570
571
572
573
574



575
576

577
578
579
580
581
582
583
584


585
586
587
588
589

590
591
592
593
594
595
596
597
598


599


600
601
602
603
604
605


606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623

624
625




626
627
628
629
630
631
632


633
634
635
636
637
638
639
640



641
642
643

644
645
646
647
648
649



650
651
652
653
654
655
656
657
658
659


660
661



662
663
664
665
666


667





668

669
670
671
672

673
674
675
676
677
678
679
680
681
682
683
684
685

686



687
688
689
690
691
692
693


694
695
696
697
698




























699
700
701
702
703
704
705

706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729











730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989








990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238



















1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288

1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361


1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571

1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622


1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111

2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402

2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459

2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532

2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554






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







;; (include "common.scm")






(include "megatest-version.scm")














































































































;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)



(declare (uses common))
;; (declare (uses megatest-version))
(declare (uses margs))
(declare (uses runs))
(declare (uses launch))
(declare (uses server))
(declare (uses client))
(declare (uses tests))
(declare (uses genexample))
;; (declare (uses daemon))
(declare (uses db))
;; (declare (uses dcommon))

(declare (uses tdb))
(declare (uses mt))
(declare (uses api))
(declare (uses tasks)) ;; only used for debugging.
(declare (uses env))
(declare (uses diff-report))
;; (declare (uses ftail))
;; (import ftail)



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

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



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

(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-write-access? *usage-log-file*))
    (with-output-to-file
        *usage-log-file*

      (lambda ()
        (print
         (if *usage-use-seconds*
             (current-seconds)
             (time->string
              (seconds->local-time (current-seconds))
              "%Yww%V.%w %H:%M:%S"))
         " "


         (current-user-name) " "
         (current-directory) " "
         "\"" (string-intersperse (argv) " ") "\""))
      #:append))


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

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

Launching and managing runs
  -run                    : run all tests or as specified by -testpatt
  -remove-runs            : remove the data for a run, requires -runname and -testpatt
                            Optionally use :state and :status, use -keep-records to remove only
                            the run data. Use -kill-wait to override the 10 second
                            per test wait after kill delay (e.g. -kill-wait 0). 
  -kill-runs              : kill existing run(s) (all incomplete tests killed)
  -kill-rerun             : kill an existing run (all incomplete tests killed and run is rerun)
  -set-state-status X,Y   : set state to X and status to Y, requires controls per -remove-runs
  -rerun FAIL,WARN...     : force re-run for tests with specificed status(s)
  -rerun-clean            : set all tests not COMPLETED+PASS,WARN,WAIVED to NOT_STARTED,n/a
                            and then run the specified testpatt with -preclean
  -rerun-all              : set all tests to NOT_STARTED,n/a and run with -preclean
  -lock                   : lock run specified by target and runname
  -unlock                 : unlock run specified by target and runname






  -set-run-status status  : sets status for run to status, requires -target and -runname
  -get-run-status         : gets status for run specified by target and runname
  -run-wait               : wait on run specified by target and runname
  -preclean               : remove the existing test directory before running the test
  -clean-cache            : remove the cached megatest.config and runconfigs.config files
  -no-cache               : do not use the cached config files. 

  -one-pass               : launch as many tests as you can but do not wait for more to be ready
  -remove-keep N          : remove all but N most recent runs per target; use '-actions, -age, -precmd'
  -age <age>              : 120d,3h,20m to apply only to runs older than the 
                                 specified age. NB// M=month, m=minute
  -actions <action>[,...] : actions to take; print,remove-runs,archive,kill-runs
  -precmd                 : insert a wrapper command in front of the commands run

Selectors (e.g. use for -runtests, -remove-runs, -set-state-status, -list-runs etc.)
  -target key1/key2/...   : run for key1, key2, etc.
  -reqtarg key1/key2/...  : run for key1, key2, etc. but key1/key2 must be in runconfigs
  -testpatt patt1/patt2,patt3/...  : % is wildcard
  -runname                : required, name for this particular test run
  -state                  : Applies to runs, tests or steps depending on context
  -status                 : Applies to runs, tests or steps depending on context
  -modepatt key           : load testpatt from <key> in runconfigs instead of default TESTPATT if -testpatt and -tagexpr are not specified
  -tagexpr tag1,tag2%,..  : select tests with tags matching expression
  

Test helpers (for use inside tests)
  -step stepname
  -test-status            : set the state and status of a test (use :state and :status)
  -setlog logfname        : set the path/filename to the final log relative to the test
                            directory. may be used with -test-status
  -set-toplog logfname    : set the overall log for a suite of sub-tests
  -summarize-items        : for an itemized test create a summary html 
  -m comment              : insert a comment for this test








Test data capture
  -set-values             : update or set values in the testdata table
  :category               : set the category field (optional)
  :variable               : set the variable name (optional)

  :value                  : value measured (required)
  :expected               : value expected (required)
  :tol                    : |value-expect| <= tol (required, can be <, >, >=, <= or number)


  :units                  : name of the units for value, expected_value etc. (optional)
  -load-test-data         : read test specific data for storage in the test_data table
                            from standard in. Each line is comma delimited with four
                            fields category,variable,value,comment

Queries
  -list-runs patt         : list runs matching pattern \"patt\", % is the wildcard
  -show-keys              : show the keys used in this megatest setup
  -test-files targpatt    : get the most recent test path/file matching targpatt e.g. %/% or '*.log'
                            returns list sorted by age ascending, see examples below
  -test-paths             : get the test paths matching target, runname, item and test
                            patterns.
  -list-disks             : list the disks available for storing runs
  -list-targets           : list the targets in runconfigs.config

  -list-db-targets        : list the target combinations used in the db
  -show-config            : dump the internal representation of the megatest.config file
  -show-runconfig         : dump the internal representation of the runconfigs.config file
  -dumpmode MODE          : dump in MODE format instead of sexpr, MODE=json,ini,sexp etc. (add -debug 0,9 to see which file contributes each line)
  -show-cmdinfo           : dump the command info for a test (run in test environment)
  -section sectionName
  -var varName            : for config and runconfig lookup value for sectionName varName
  -since N                : get list of runs changed since time N (Unix seconds)
  -fields fieldspec       : fields to include in json dump; runs:id,runame+tests:testname+steps
  -sort fieldname         : in -list-runs sort tests by this field
  -testdata-csv [categorypatt/]varpatt  : dump testdata for given category

Misc 
  -start-dir path         : switch to this directory before running megatest

  -contour cname          : add a level of hierarcy to the linktree and run paths
  -area-tag tagname       : add a tag to an area while syncing to pgdb


  -run-tag tagname        : add a tag to a run while syncing to pgdb
  -rebuild-db             : bring the database schema up to date
  -cleanup-db             : remove any orphan records, vacuum the db


  -import-megatest.db     : push data from megatest.db to cache db files in /tmp/$USER
  -sync-to-megatest.db    : pull data from cache files in /tmp/$USER to megatest.db
  -sync-to dest           : sync to new postgresql central style database
  -update-meta            : update the tests metadata for all tests
  -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are
                                 overwritten by values set in config files.
  -server -|hostname      : start the server (reduces contention on megatest.db), use
                            - to automatically figure out hostname
  -adjutant C,M           : start the server/adjutant with allocated cores C and Mem M (Gig), 


                            use 0,0 to auto use full machine
  -transport http|rpc     : use http or rpc for transport (default is http) 
  -log logfile            : send stdout and stderr to logfile
  -list-servers           : list the servers 
  -kill-servers           : kill all servers
  -repl                   : start a repl (useful for extending megatest)
  -load file.scm          : load and run file.scm
  -mark-incompletes       : find and mark incomplete tests
  -ping run-id|host:port  : ping server, exit with 0 if found
  -debug N|N,M,O...       : enable debug 0-N or N and M and O ...
  -debug-noprop N|M,M,O...: enable debug but do not propagate to subprocesses via MT_DEBUG

  -config fname           : override the megatest.config file with fname
  -append-config fname    : append fname to the megatest.config file

Utilities
  -env2file fname         : write the environment to fname.csh and fname.sh
  -envcap a               : save current variables labeled as context 'a' in file envdat.db
  -envdelta a-b           : output enviroment delta from context a to context b to -o fname
                            set the output mode with -dumpmode csh, bash or ini
                            note: ini format will use calls to use curr and minimize path
  -refdb2dat refdb        : convert refdb to sexp or to format specified by s-dumpmode
                            formats: perl, ruby, sqlite3, csv (for csv the -o param
                            will substitute %s for the sheet name in generating 
                            multiple sheets)
  -o                      : output file for refdb2dat (defaults to stdout)

  -archive cmd            : archive runs specified by selectors to one of disks specified

                            in the [archive-disks] section.
                            cmd: keep-html, restore, save, save-remove, get, replicate-db (use 
                            -dest to set destination), -include path1,path2... to get or save specific files

  -generate-html          : create a simple html dashboard for browsing your runs
  -generate-html-structure  : create a top level html veiw to list targets/runs and a Run view within each run directory.  
  -list-run-time          : list time requered to complete runs. It supports following switches
                            -run-patt <patt> -target-patt <patt> -dumpmode <csv,json,plain-text>
  -list-test-time	  : list time requered to complete each test in a run. It following following arguments
                            -runname <patt> -target <patt> -dumpmode <csv,json,plain-text>
  -syscheck               : do some very basic checks; write access and space in tmp, home, runs, links and 
                            is $DISPLAY valid 
  -list-waivers           : dump waivers for specified target, runname, testpatt to stdout

Diff report
  -diff-rep               : generate diff report (must include -src-target, -src-runname, -target, -runname
                                                  and either -diff-email or -diff-html)
  -src-target <target>
  -src-runname <target>
  -diff-email <emails>    : comma separated list of email addresses to send diff report
  -diff-html  <rep.html>  : path to html file to generate


Spreadsheet generation
  -extract-ods fname.ods  : extract an open document spreadsheet from the database
  -pathmod path           : insert path, i.e. path/runame/itempath/logfile.html
                            will clear the field if no rundir/testname/itempath/logfile
                            if it contains forward slashes the path will be converted
                            to windows style
Getting started
  -create-megatest-area   : create a skeleton megatest area. You will be prompted for paths
  -create-test testname   : create a skeleton megatest test. You will be prompted for info

Examples

# Get test path, use '.' to get a single path or a specific path/file pattern
megatest -test-files 'logs/*.log' -target ubuntu/n%/no% -runname w49% -testpatt test_mt%

Called as " (string-intersperse (argv) " ") "
Version " megatest-version ", built from " megatest-fossil-hash ))

;;  -gui                    : start a gui interface

;;  -config fname           : override the runconfigs file with fname


;; process args
(define remargs (args:get-args 
		 (argv)
		 (list  "-runtests"  ;; run a specific test


			"-config"    ;; override the config file name
			"-append-config"
			"-execute"   ;; run the command encoded in the base64 parameter
			"-step"

			"-target"
			"-reqtarg"
			":runname"
			"-runname"
			":state"  
			"-state"
			":status"
			"-status"
			"-list-runs"
                        "-testdata-csv"
			"-testpatt"
                        "--modepatt"
                        "-modepatt"
                        "-tagexpr"
			"-itempatt"
			"-setlog"
			"-set-toplog"
			"-runstep"
			"-logpro"
			"-m"
			"-rerun"

			"-days"
			"-rename-run"
			"-to"
			"-dest"
                        "-source" 
                        "-time-stamp" 
			;; values and messages
			":category"


			":variable"
			":value"
			":expected"
			":tol"
			":units"










			;; misc








			"-start-dir"
                        "-run-patt"


                        "-target-patt"   
			"-contour"
                        "-area-tag"  
                        "-area"  
			"-run-tag"
			"-server"
			"-adjutant"
			"-transport"
			"-port"
			"-extract-ods"
			"-pathmod"
			"-env2file"
			"-envcap"
			"-envdelta"
			"-setvars"
			"-set-state-status"



                        ;; move runs stuff here

                        "-remove-keep"           
			"-set-run-status"
			"-age"

			;; archive 

			"-archive"
			"-actions"

			"-precmd"



			"-include"
			"-exclude-rx"
			"-exclude-rx-from"
			
			"-debug" ;; for *verbosity* > 2
			"-debug-noprop"
			"-create-test"
			"-override-timeout"
			"-test-files"  ;; -test-paths is for listing all
			"-load"        ;; load and exectute a scheme file
			"-section"
			"-var"
			"-dumpmode"
			"-run-id"
			"-ping"
			"-refdb2dat"
			"-o"
			"-log"
                        "-sync-log"
			"-since"
			"-fields"
			"-recover-test" ;; run-id,test-id - used internally to recover a test stuck in RUNNING state
			"-sort"
			"-target-db"
			"-source-db"
			"-prefix-target"




                        "-src-target"



                        "-src-runname"
                        "-diff-email"
			"-sync-to"			

			"-pgsync"
			"-kill-wait"    ;; wait this long before removing test (default is 10 sec)

                        "-diff-html"







			;; wizards, area capture, setup new ...
			"-extract-skeleton"
			)
 		 (list  "-h" "-help" "--help"
			"-manual"
			"-version"
		        "-force"
		        "-xterm"
		        "-showkeys"
		        "-show-keys"
		        "-test-status"
			"-set-values"
			"-load-test-data"

			"-summarize-items"
		        "-gui"
			"-daemonize"
			"-preclean"
			"-rerun-clean"
			"-rerun-all"
			"-clean-cache"
			"-no-cache"



			"-cache-db"
			"-cp-eventtime-to-publishtime"
                        "-use-db-cache"
                        "-prepend-contour"






			;; misc
			"-repl"

			"-lock"

			"-unlock"
			"-list-servers"

			"-kill-servers"
                        "-run-wait"      ;; wait on a run to complete (i.e. no RUNNING)
			"-one-pass"      ;;


			"-local"         ;; run some commands using local db access


			"-generate-html"
			"-generate-html-structure" 
			"-list-run-time"
                        "-list-test-time"
			


			;; misc queries



			"-list-disks"
			"-list-targets"
			"-list-db-targets"


			"-show-runconfig"
			"-show-config"
			"-show-cmdinfo"
			"-get-run-status"
			"-list-waivers"

			;; queries
			"-test-paths" ;; get path(s) to a test, ordered by youngest first

			"-runall"    ;; run all tests, respects -testpatt, defaults to %
			"-run"       ;; alias for -runall
			"-remove-runs"
                        "-kill-runs"
                        "-kill-rerun"
                        "-keep-records" ;; use with -remove-runs to remove only the run data
			"-rebuild-db"
			"-cleanup-db"
			"-rollup"
			"-update-meta"
			"-create-megatest-area"
			"-mark-incompletes"

			"-convert-to-norm"
			"-convert-to-old"
			"-import-megatest.db"



			"-sync-to-megatest.db"
                        "-sync-brute-force"
			"-logging"
			"-v" ;; verbose 2, more than normal (normal is 1)
			"-q" ;; quiet 0, errors/warnings only

                        "-diff-rep"




			"-syscheck"
			"-obfuscate"
			;; junk placeholder
			;; "-:p"
			
                        )

		 args:arg-hash
		 0))






;; Add args that use remargs here


;;
(if (and (not (null? remargs))
	 (not (or

	       (args:get-arg "-runstep")
	       (args:get-arg "-envcap")
	       (args:get-arg "-envdelta")
	       )
	      ))
    (debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv))  " ")))

;; before doing anything else change to the start-dir if provided








;;
(if (args:get-arg "-start-dir")
    (if (common:file-exists? (args:get-arg "-start-dir"))
        (let ((fullpath (common:real-path (args:get-arg "-start-dir"))))
          (setenv "PWD" fullpath)
          (change-directory fullpath))




	(begin
	  (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.")
	  (exit 1))))

;; immediately set MT_TARGET if -reqtarg or -target are available

;;








(let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target"))))
  (if targ (setenv "MT_TARGET" targ)))

;; The watchdog is to keep an eye on things like db sync etc.
;;

;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
(define *watchdog* (make-thread
		    (lambda ()
		      (handle-exceptions
			  exn
			  (begin
			    (print-call-chain)
			    (print " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn))





			(common:watchdog)))
		    "Watchdog thread"))




;;(if (not (args:get-arg "-server"))
;;    (thread-start! *watchdog*)) ;; if starting a server; wait till we get to running state before kicking off watchdog
(let* ((no-watchdog-args
       '("-list-runs"
         "-testdata-csv"
         "-list-servers"
         "-server"
	 "-adjutant"
         "-list-disks"



         "-list-targets"
         "-show-runconfig"






         ;;"-list-db-targets"
         "-show-runconfig"
         "-show-config"
         "-show-cmdinfo"
	 "-cleanup-db"
            ))

       (no-watchdog-argvals (list '("-archive" . "replicate-db")))


       (start-watchdog-specail-arg-val (let loop ((hed  (car no-watchdog-argvals))
                                                  (tail (cdr   no-watchdog-argvals)))
                                             ;; (print "hed" hed " arg " (args:get-arg (car hed)) " val:" (cdr hed)  " eql" (equal? (args:get-arg (car hed)) (cdr hed)))  

                                             (if (equal? (args:get-arg (car hed)) (cdr hed))
                                               #f
                                               (if (null? tail)
                                                 #t
                                                 (loop (car tail) (cdr tail))))))      
       (no-watchdog-args-vals (filter (lambda (x) x)

                                      (map args:get-arg no-watchdog-args)))
       (start-watchdog (and (null? no-watchdog-args-vals) start-watchdog-specail-arg-val)))
       ;(print  "no-watchdog-args="no-watchdog-args "no-watchdog-args-vals="no-watchdog-args-vals " start-watchdog-specail-arg-val:" start-watchdog-specail-arg-val " start-watchdog:" start-watchdog) 
  (if start-watchdog
      (thread-start! *watchdog*)))


;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions
(define (open-logfile logpath-in)

  (condition-case
   (let* ((log-dir (or (pathname-directory logpath-in) "."))
	  (fname   (pathname-strip-directory logpath-in))
	  (logpath (if (> (string-length fname) 250)
		       (let ((newlogf (conc log-dir "/" (common:get-signature fname) ".log")))
			 (debug:print 0 *default-log-port* "WARNING: log file " logpath-in " path too long, converted to " newlogf)
			 newlogf)
		       logpath-in)))


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

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


;;
(if (or (args:get-arg "-log")(args:get-arg "-server")) ;; redirect the log always when a server
    (handle-exceptions
	exn
	(begin
	  (print "ERROR: Failed to switch to log output. " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
	  )
      (let* ((tl   (or (args:get-arg "-log")(launch:setup)))   ;; run launch:setup if -server, ensure we do NOT run launch:setup if -log specified
	     (logf (or (args:get-arg "-log") ;; use -log unless we are a server, then craft a logfile name
		       (conc tl "/logs/server-" (current-process-id) "-" (get-host-name) ".log")))
	     (oup  (open-logfile logf)))



	(if (not (args:get-arg "-log"))
	    (hash-table-set! args:arg-hash "-log" logf)) ;; fake out future queries of -log

	(debug:print-info 0 *default-log-port* "Sending log output to " logf)
	(set! *default-log-port* oup))))

(if (or (args:get-arg "-h")
	(args:get-arg "-help")
	(args:get-arg "--help"))
    (begin
      (print help)


      (exit)))

(if (args:get-arg "-manual")
    (let* ((htmlviewercmd (or (configf:lookup *configdat* "setup" "htmlviewercmd")
			      (common:which '("firefox" "arora"))))

	   (install-home  (common:get-install-area))
	   (manual-html   (conc install-home "/share/docs/megatest_manual.html")))
      (if (and install-home
	       (common:file-exists? manual-html))
	  (system (conc "(" htmlviewercmd " " manual-html " ) &"))
	  (system (conc "(" htmlviewercmd " http://www.kiatoa.com/cgi-bin/fossils/megatest/doc/tip/docs/manual/megatest_manual.html ) &")))
      (exit)))

(if (args:get-arg "-version")


    (begin


      (print (common:version-signature)) ;; (print megatest-version)
      (exit)))

(define *didsomething* #f)

;; Overall exit handling setup immediately


;;
(if (or (args:get-arg "-process-reap"))
        ;; (args:get-arg "-runtests")
	;; (args:get-arg "-execute")
	;; (args:get-arg "-remove-runs")
	;; (args:get-arg "-runstep"))
    (let ((original-exit (exit-handler)))
      (exit-handler (lambda (#!optional (exit-code 0))
		      (printf "Preparing to exit with exit code ~A ...\n" exit-code)
		      (for-each
		       
		       (lambda (pid)
			 (handle-exceptions
			     exn
			   (begin
			     (printf "process reap failed. exn=~A\n" exn)
			     #t)
			  (let-values (((pid-val exit-status exit-code) (process-wait pid #t)))

				      (if (or (eq? pid-val pid)
					      (eq? pid-val 0))




					  (begin
					    (printf "Sending signal/term to ~A\n" pid)
					    (process-signal pid signal/term))))))
		       (process:children #f))
		      (original-exit exit-code)))))

;; for some switches always print the command to stderr


;;
(if (args:any? "-run" "-runall" "-remove-runs" "-set-state-status" "-kill-runs" "-kill-rerun")
    (debug:print 0 *default-log-port* (string-intersperse (argv) " ")))

;; some switches imply homehost. Exit here if not on homehost
;;
(let ((homehost-required  (list "-cleanup-db" "-server")))
  (if (apply args:any? homehost-required)



      (if (not (common:on-homehost?))
	  (for-each
	   (lambda (switch)

	     (if (args:get-arg switch)
		 (begin
		   (debug:print 0 *default-log-port* "ERROR: you must be on the homehost to run with " switch
				", you can move homehost by removing the .homehost file but this will disrupt any runs in progress.")
		   (exit 1))))
	   homehost-required))))




;;======================================================================
;; Misc setup stuff
;;======================================================================

(debug:setup)

(if (args:get-arg "-logging")(set! *logging* #t))

;;(if (debug:debug-mode 3) ;; we are obviously debugging


;;    (set! open-run-close open-run-close-no-exception-handling))




(if (args:get-arg "-itempatt")
    (let ((newval (conc (args:get-arg "-testpatt") "/" (args:get-arg "-itempatt"))))
      (debug:print 0 *default-log-port* "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval)
      (hash-table-set! args:arg-hash "-testpatt" newval)
      (hash-table-delete! args:arg-hash "-itempatt")))








(if (args:get-arg "-runtests")

    (debug:print 0 *default-log-port* "WARNING: \"-runtests\" is deprecated. Use \"-run\" with \"-testpatt\" instead"))

(on-exit std-exit-procedure)


;;======================================================================
;; Misc general calls
;;======================================================================

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

;; handle a clean-cache request as early as possible

;;



(if (args:get-arg "-clean-cache")
    (let ((toppath  (launch:setup)))
      (set! *didsomething* #t) ;; suppress the help output.
      (runs:clean-cache (common:args-get-target)
			(args:get-arg "-runname")
			toppath)))
	  


(if (args:get-arg "-env2file")
    (begin
      (save-environment-as-files (args:get-arg "-env2file"))
      (set! *didsomething* #t)))





























(if (args:get-arg "-list-disks")
    (let ((toppath (launch:setup)))
      (print 
       (string-intersperse 
	(map (lambda (x)
	       (string-intersperse 
		x

		" => "))
	     (common:get-disks *configdat*))
	"\n"))
      (set! *didsomething* #t)))

;; csv processing record
(define (make-refdb:csv)
  (vector 
   (make-sparse-array)
   (make-hash-table)
   (make-hash-table)
   0
   0))
(define-inline (refdb:csv-get-svec     vec)    (vector-ref  vec 0))
(define-inline (refdb:csv-get-rows     vec)    (vector-ref  vec 1))
(define-inline (refdb:csv-get-cols     vec)    (vector-ref  vec 2))
(define-inline (refdb:csv-get-maxrow   vec)    (vector-ref  vec 3))
(define-inline (refdb:csv-get-maxcol   vec)    (vector-ref  vec 4))
(define-inline (refdb:csv-set-svec!    vec val)(vector-set! vec 0 val))
(define-inline (refdb:csv-set-rows!    vec val)(vector-set! vec 1 val))
(define-inline (refdb:csv-set-cols!    vec val)(vector-set! vec 2 val))
(define-inline (refdb:csv-set-maxrow!  vec val)(vector-set! vec 3 val))
(define-inline (refdb:csv-set-maxcol!  vec val)(vector-set! vec 4 val))












(define (get-dat results sheetname)
  (or (hash-table-ref/default results sheetname #f)
      (let ((tmp-vec  (make-refdb:csv)))
	(hash-table-set! results sheetname tmp-vec)
	tmp-vec)))

(if (args:get-arg "-refdb2dat")
    (let* ((input-db (args:get-arg "-refdb2dat"))
	   (out-file (args:get-arg "-o"))
	   (out-fmt  (or (args:get-arg "-dumpmode") "scheme"))
	   (out-port (if (and out-file 
			      (not (member out-fmt '("sqlite3" "csv"))))
			 (open-output-file out-file)
			 (current-output-port)))
	   (res-data (configf:read-refdb input-db))
	   (data     (car res-data))
	   (msg      (cadr res-data)))
      (if (not data)
	  (debug:print 0 *default-log-port* "Bad input? data=" data) ;; some error occurred
	  (with-output-to-port out-port
	    (lambda ()
	      (case (string->symbol out-fmt)
		((scheme)(pp data))
		((perl)
		 ;; (print "%hash = (")
		 ;;        key1 => 'value1',
		 ;;        key2 => 'value2',
		 ;;        key3 => 'value3',
		 ;; );
		 (configf:map-all-hier-alist 
		  data 
		  (lambda (sheetname sectionname varname val)
		    (print "$data{\"" sheetname "\"}{\"" sectionname "\"}{\"" varname "\"} = \"" val "\";"))))
		((python ruby)
		 (print "data={}")
		 (configf:map-all-hier-alist
		  data
		  (lambda (sheetname sectionname varname val)
		    (print "data[\"" sheetname "\"][\"" sectionname "\"][\"" varname "\"] = \"" val "\""))
		  initproc1:
		  (lambda (sheetname)
		    (print "data[\"" sheetname "\"] = {}"))
		  initproc2:
		  (lambda (sheetname sectionname)
		    (print "data[\"" sheetname "\"][\"" sectionname "\"] = {}"))))
		((csv)
		 (let* ((results  (make-hash-table)) ;; (make-sparse-array)))
			(row-cols (make-hash-table))) ;; hash of hashes where section => ht { row-<name> => num or col-<name> => num
		   ;; (print "data=")
		   ;; (pp data)
		   (configf:map-all-hier-alist
		    data
		    (lambda (sheetname sectionname varname val)
		      ;; (print "sheetname: " sheetname ", sectionname: " sectionname ", varname: " varname ", val: " val)
		      (let* ((dat      (get-dat results sheetname))
			     (vec      (refdb:csv-get-svec dat))
			     (rownames (refdb:csv-get-rows dat))
			     (colnames (refdb:csv-get-cols dat))
			     (currrown (hash-table-ref/default rownames varname #f))
			     (currcoln (hash-table-ref/default colnames sectionname #f))
			     (rown     (or currrown 
					   (let* ((lastn   (refdb:csv-get-maxrow dat))
						  (newrown (+ lastn 1)))
					     (refdb:csv-set-maxrow! dat newrown)
					     newrown)))
			     (coln     (or currcoln 
					   (let* ((lastn   (refdb:csv-get-maxcol dat))
						  (newcoln (+ lastn 1)))
					     (refdb:csv-set-maxcol! dat newcoln)
					     newcoln))))
			(if (not (sparse-array-ref vec 0 coln)) ;; (eq? rown 0)
			    (begin
			      (sparse-array-set! vec 0 coln sectionname)
			      ;; (print "sparse-array-ref " 0 "," coln "=" (sparse-array-ref vec 0 coln))
			      ))
			(if (not (sparse-array-ref vec rown 0)) ;; (eq? coln 0)
			    (begin
			      (sparse-array-set! vec rown 0 varname)
			      ;; (print "sparse-array-ref " rown "," 0 "=" (sparse-array-ref vec rown 0))
			      ))
			(if (not currrown)(hash-table-set! rownames varname rown))
			(if (not currcoln)(hash-table-set! colnames sectionname coln))
			;; (print "dat=" dat ", rown=" rown ", coln=" coln)
			(sparse-array-set! vec rown coln val)
			;; (print "sparse-array-ref " rown "," coln "=" (sparse-array-ref vec rown coln))
			)))
		   (for-each
		    (lambda (sheetname)
		      (let* ((sheetdat (get-dat results sheetname))
			     (svec     (refdb:csv-get-svec sheetdat))
			     (maxrow   (refdb:csv-get-maxrow sheetdat))
			     (maxcol   (refdb:csv-get-maxcol sheetdat))
			     (fname    (if out-file 
					   (string-substitute "%s" sheetname out-file) ;; "/foo/bar/%s.csv")
					   (conc sheetname ".csv"))))
			(with-output-to-file fname
			  (lambda ()
			    ;; (print "Sheetname: " sheetname)
			    (let loop ((row       0)
				       (col       0)
				       (curr-row '())
				       (result   '()))
			      (let* ((val (sparse-array-ref svec row col))
				     (disp-val (if val
						   (conc "\"" val "\"")
						   "")))
				(if (> col 0)(display ","))
				(display disp-val)
				(cond
				 ((> row maxrow)(display "\n") result)
				 ((>= col maxcol)
				  (display "\n")
				  (loop (+ row 1) 0 '() (append result (list curr-row))))
				 (else
				  (loop row (+ col 1) (append curr-row (list val)) result)))))))))
		    (hash-table-keys results))))
		((sqlite3)
		 (let* ((db-file   (or out-file (pathname-file input-db)))
			(db-exists (common:file-exists? db-file))
			(db        (sqlite3:open-database db-file)))
		   (if (not db-exists)(sqlite3:execute db "CREATE TABLE data (sheet,section,var,val);"))
		   (configf:map-all-hier-alist
		    data
		    (lambda (sheetname sectionname varname val)
		      (sqlite3:execute db
				       "INSERT OR REPLACE INTO data (sheet,section,var,val) VALUES (?,?,?,?);"
				       sheetname sectionname varname val)))
		   (sqlite3:finalize! db)))
		(else
		 (pp data))))))
      (if out-file (close-output-port out-port))
      (exit) ;; yes, bending the rules here - need to exit since this is a utility
      ))

(if (args:get-arg "-ping")
    (let* ((server-id     (string->number (args:get-arg "-ping"))) ;; extract run-id (i.e. no ":"
	   (host:port     (args:get-arg "-ping")))
      (server:ping (or server-id host:port) #f do-exit: #t)))

;;======================================================================
;; Capture, save and manipulate environments
;;======================================================================

;; NOTE: Keep these above the section where the server or client code is setup

(let ((envcap (args:get-arg "-envcap")))
  (if envcap
      (let* ((db      (env:open-db (if (null? remargs) "envdat.db" (car remargs)))))
	(env:save-env-vars db envcap)
	(env:close-database db)
	(set! *didsomething* #t))))

;; delta "language" will eventually be res=a+b-c but for now it is just res=a-b 
;;
(let ((envdelta (args:get-arg "-envdelta")))
  (if envdelta
      (let ((match (string-split envdelta "-")));; (string-match "([a-z0-9_]+)=([a-z0-9_\\-,]+)" envdelta)))
	(if (not (null? match))
	    (let* ((db        (env:open-db (if (null? remargs) "envdat.db" (car remargs))))
		   ;; (resctx    (cadr match))
		   ;; (equn      (caddr match))
		   (parts     match) ;; (string-split equn "-"))
		   (minuend   (car parts))
		   (subtraend (cadr parts))
		   (added     (env:get-added   db minuend subtraend))
		   (removed   (env:get-removed db minuend subtraend))
		   (changed   (env:get-changed db minuend subtraend)))
	      ;; (pp (hash-table->alist added))
	      ;; (pp (hash-table->alist removed))
	      ;; (pp (hash-table->alist changed))
	      (if (args:get-arg "-o")
		  (with-output-to-file
		      (args:get-arg "-o")
		    (lambda ()
		      (env:print added removed changed)))
		  (env:print added removed changed))
	      (env:close-database db)
	      (set! *didsomething* #t))
	    (debug:print-error 0 *default-log-port* "Parameter to -envdelta should be new=start-end")))))

;;======================================================================
;; Start the server - can be done in conjunction with -runall or -runtests (one day...)
;;   we start the server if not running else start the client thread
;;======================================================================

;; Server? Start up here.
;;
(if (args:get-arg "-server")
    (let ((tl        (launch:setup))
          (transport-type (string->symbol (or (args:get-arg "-transport") "http"))))
      (server:launch 0 transport-type)
      (set! *didsomething* #t)))

;; The adjutant is a bit different, it does NOT run (launch:setup) as it is not necessarily tied to
;; a specific Megatest area. Detail are being hashed out and this may change.
;;
(if (args:get-arg "-adjutant")
    (begin
      (adjutant-run)
      (set! *didsomething* #t)))

(if (or (args:get-arg "-list-servers")
        (args:get-arg "-kill-servers"))
    (let ((tl (launch:setup)))
      (if tl ;; all roads from here exit
	  (let* ((servers (server:get-list *toppath*))
		 (fmtstr  "~8a~22a~20a~20a~8a\n"))
	    (format #t fmtstr "pid" "Interface:port" "age (hms)" "Last mod" "State")
	    (format #t fmtstr "===" "==============" "=========" "========" "=====")
	    (for-each ;;  ( mod-time host port start-time pid )
	     (lambda (server)
	       (let* ((mtm (any->number (car server)))
		      (mod (if mtm (- (current-seconds) mtm) "unk"))
		      (age (- (current-seconds)(or (any->number (list-ref server 3)) (current-seconds))))
		      (url (conc (cadr server) ":" (caddr server)))
		      (pid (list-ref server 4))
		      (alv (if (number? mod)(< mod 10) #f)))
		 (format #t
			 fmtstr
			 pid
			 url
			 (seconds->hr-min-sec age)
			 (seconds->hr-min-sec mod)
			 (if alv "alive" "dead"))
		 (if (and alv
			  (args:get-arg "-kill-servers"))
		     (begin
		       (debug:print-info 0 *default-log-port* "Attempting to kill server with pid " pid)
		       (server:kill server)))))
	     (sort servers (lambda (a b)
			     (let ((ma (or (any->number (car a)) 9e9))
				   (mb (or (any->number (car b)) 9e9)))
			       (> ma mb)))))
	    ;; (debug:print-info 1 *default-log-port* "Done with listservers")
	    (set! *didsomething* #t)
	    (exit))
	  (exit))))
      ;; must do, would have to add checks to many/all calls below

;;======================================================================
;; Weird special calls that need to run *after* the server has started?
;;======================================================================

(if (args:get-arg "-list-targets")
    (if (launch:setup)
        (let ((targets (common:get-runconfig-targets)))
          ;; (debug:print 1 *default-log-port* "Found "(length targets) " targets")
          (case (string->symbol (or (args:get-arg "-dumpmode") "alist"))
            ((alist)
             (for-each (lambda (x)
                         ;; (print "[" x "]"))
                         (print x))
                       targets))
            ((json)
             (json-write targets))
            (else
             (debug:print-error 0 *default-log-port* "dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets")))
          (set! *didsomething* #t))))

;; cache the runconfigs in $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME/.runconfig








;;
(define (full-runconfigs-read)
;; in the envprocessing branch the below code replaces the further below code
;;  (if (eq? *configstatus* 'fulldata)
;;      *runconfigdat*
;;      (begin
;;	(launch:setup)
;;	*runconfigdat*)))

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

(if (args:get-arg "-show-runconfig")
    (let ((tl (launch:setup)))
      (push-directory *toppath*)
      (let ((data (full-runconfigs-read)))
	;; keep this one local
	(cond
	 ((and (args:get-arg "-section")
	       (args:get-arg "-var"))
	  (let ((val (or (configf:lookup data (args:get-arg "-section")(args:get-arg "-var"))
			 (configf:lookup data "default" (args:get-arg "-var")))))
	    (if val (print val))))
	 ((or (not (args:get-arg "-dumpmode"))
              (string=? (args:get-arg "-dumpmode") "ini"))
	  (configf:config->ini data))
	 ((string=? (args:get-arg "-dumpmode") "sexp")
	  (pp (hash-table->alist data)))
	 ((string=? (args:get-arg "-dumpmode") "json")
	  (json-write data))
	 (else
	  (debug:print-error 0 *default-log-port* "-dumpmode of " (args:get-arg "-dumpmode") " not recognised")))
	(set! *didsomething* #t))
      (pop-directory)))

(if (args:get-arg "-show-config")
    (let ((tl   (launch:setup))
	  (data *configdat*)) ;; (read-config "megatest.config" #f #t)))
      (push-directory *toppath*)
      ;; keep this one local
      (cond 
       ((and (args:get-arg "-section")
	     (args:get-arg "-var"))
	(let ((val (configf:lookup data (args:get-arg "-section")(args:get-arg "-var"))))
	  (if val (print val))))

       ;; print just a section if only -section

       ((equal? (args:get-arg "-dumpmode") "sexp")
	(pp (hash-table->alist data)))
       ((equal? (args:get-arg "-dumpmode") "json")
	(json-write data))
       ((or (not (args:get-arg "-dumpmode"))
	    (string=? (args:get-arg "-dumpmode") "ini"))
	(configf:config->ini data))
       (else
	(debug:print-error 0 *default-log-port* "-dumpmode of " (args:get-arg "-dumpmode") " not recognised")))
      (set! *didsomething* #t)
      (pop-directory)
      (set! *time-to-exit* #t)))

(if (args:get-arg "-show-cmdinfo")
    (if (or (args:get-arg ":value")(getenv "MT_CMDINFO"))
	(let ((data (common:read-encoded-string (or (args:get-arg ":value")(getenv "MT_CMDINFO")))))
	  (if (equal? (args:get-arg "-dumpmode") "json")
	      (json-write data)
	      (pp data))
	  (set! *didsomething* #t))
	(debug:print-info 0 *default-log-port* "environment variable MT_CMDINFO is not set")))

;;======================================================================
;; Remove old run(s)
;;======================================================================

;; since several actions can be specified on the command line the removal
;; is done first
(define (operate-on action #!key (mode #f)(target-in #f)(runname-in #f)(keys-in #f)(keyvals-in #f)) ;; #f is "use default"
  (let* ((runrec (runs:runrec-make-record))
	 (target (or target-in   (common:args-get-target))) ;; eventually get rid of the call to common:args-get-target
	 (runname (or runname-in
		      (args:get-arg "-runname"))) ;; eventually get rid of the get-arg calls
	 (testpatt (or (args:get-arg "-testpatt")
		       (and (eq? action 'archive) ;; if it is an archive command fallback to MT_TEST_NAME and MT_ITEMPATH
			    (common:get-full-test-name))
		       (and (eq? action 'kill-runs)
			    "%/%") ;; I'm just guessing that this is correct :(
		       (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")))
		       ))) ;;
    (cond
     ((not target)
      (debug:print-error 0 *default-log-port* "Missing required parameter for "
			 action ", you must specify -target or -reqtarg")
      (exit 1))
     ((not runname)
      (debug:print-error 0 *default-log-port* "Missing required parameter for "
			 action ", you must specify the run name pattern with -runname patt")
      (exit 2))
     ((not testpatt)
      (debug:print-error 0 *default-log-port* "Missing required parameter for "
			 action ", you must specify the test pattern with -testpatt")
      (exit 3))
     (else
      (if (not (car *configinfo*))
	  (begin
	    (debug:print-error 0 *default-log-port* "Attempted " action "on test(s) but run area config file not found")
	    (exit 1))
	  ;; put test parameters into convenient variables
	  (begin
	    ;; check for correct version, exit with message if not correct
	    (common:exit-on-version-changed)
	    (runs:operate-on  action
			      target
			      runname
			      testpatt
			      state:  (common:args-get-state)
			      status: (common:args-get-status)
			      new-state-status: (args:get-arg "-set-state-status")
                              mode: mode)))
      (set! *didsomething* #t)))))

(if (args:get-arg "-kill-runs")
    (general-run-call 
     "-kill-runs"
     "kill runs"
     (lambda (target runname keys keyvals)
       (operate-on 'kill-runs mode: #f)
       )))

(if (args:get-arg "-kill-rerun")
    (let* ((target-patt (common:args-get-target))
           (runname-patt (args:get-arg "-runname")))
      (cond ((not target-patt)
             (debug:print-error 0 *default-log-port* "Missing target, must specify target for -kill-rerun with -target <target name>")
             (exit 1))
            ((not runname-patt)
             (debug:print-error 0 *default-log-port* "Missing runname, must specify runname for -kill-rerun with -runname <run name>")
             (exit 1))
            ((string-search "[ ,%]" target-patt)
             (debug:print-error 0 *default-log-port* "Invalid target ["target-patt"], must specify exact target (no wildcards) for -kill-rerun with -target <target name>")
             (exit 1))
            ((string-search "[ ,%]" runname-patt)
             (debug:print-error 0 *default-log-port* "Invalid runname ["runname-patt"], must specify exact runname (no wildcards) for -kill-rerun with -runname <runname name>")
             (exit 1))
            (else
             (general-run-call 
              "-kill-runs"
              "kill runs"
              (lambda (target runname keys keyvals)
                (operate-on 'kill-runs mode: #f)
                ))
      
             (thread-sleep! 15))
            ;; fall thru and let "-run" loop fire
            )))


(if (args:get-arg "-remove-runs")
    (general-run-call 
     "-remove-runs"
     "remove runs"
     (lambda (target runname keys keyvals)
       (operate-on 'remove-runs mode: (if (args:get-arg "-keep-records")
                                          'remove-data-only
                                          'remove-all)))))

(if (args:get-arg "-remove-keep")
    (general-run-call 
     "-remove-keep"
     "remove keep"
     (lambda (target runname keys keyvals)
       (let ((actions (map string->symbol
                           (string-split
			    (or (args:get-arg "-actions")
				"print")
			    ",")))) ;; default to printing the output
         (runs:remove-all-but-last-n-runs-per-target target runname
						     (string->number (args:get-arg "-remove-keep"))
						     actions: actions)))))

(if (args:get-arg "-set-state-status")
    (general-run-call 
     "-set-state-status"
     "set state and status"
     (lambda (target runname keys keyvals)
       (operate-on 'set-state-status))))

(if (or (args:get-arg "-set-run-status")
	(args:get-arg "-get-run-status"))
    (general-run-call
     "-set-run-status"
     "set run status"
     (lambda (target runname keys keyvals)
       (let* ((runsdat  (rmt:get-runs-by-patt keys runname 
					(common:args-get-target)
					#f #f #f #f))
	      (header   (vector-ref runsdat 0))
	      (rows     (vector-ref runsdat 1)))
	 (if (null? rows)
	     (begin
	       (debug:print-info 0 *default-log-port* "No matching run found.")
	       (exit 1))
	     (let* ((row      (car (vector-ref runsdat 1)))
		    (run-id   (db:get-value-by-header row header "id")))
	       (if (args:get-arg "-set-run-status")
		   (rmt:set-run-status run-id (args:get-arg "-set-run-status") msg: (args:get-arg "-m"))
		   (print (rmt:get-run-status run-id))
		   )))))))

;;======================================================================
;; Query runs
;;======================================================================

;; -fields runs:id,target,runname,comment+tests:id,testname,item_path+steps
;;
;; csi> (extract-fields-constraints "runs:id,target,runname,comment+tests:id,testname,item_path+steps")
;;         => (("runs" "id" "target" "runname" "comment") ("tests" "id" "testname" "item_path") ("steps"))
;;
;;   NOTE: remember that the cdr will be the list you expect (cdr ("runs" "id" "target" "runname" "comment")) => ("id" "target" "runname" "comment")
;;         and so alist-ref will yield what you expect



















;;
(define (extract-fields-constraints fields-spec)
  (map (lambda (table-spec) ;; runs:id,target,runname
	 (let ((dat (string-split table-spec ":"))) ;; ("runs" "id,target,runname")
	   (if (> (length dat) 1)
	       (cons (car dat)(string-split (cadr dat) ",")) ;; "id,target,runname"
	       dat)))
       (string-split fields-spec "+")))

(define (get-value-by-fieldname datavec test-field-index fieldname)
  (let ((indx (hash-table-ref/default test-field-index fieldname #f)))
    (if indx
	(if (>= indx (vector-length datavec))
	    #f ;; index too high, should raise an error I suppose
	    (vector-ref datavec indx))
	#f)))





(when (args:get-arg "-testdata-csv")
  (if (launch:setup)
      (let* ((keys        (rmt:get-keys)) ;; (db:get-keys dbstruct))
             (runpatt     (or (args:get-arg "-runname") "%"))
             (testpatt    (common:args-get-testpatt #f))
             (datapatt    (args:get-arg "-testdata-csv"))
             (match-data  (string-match "^([^/]+)/(.*)" (args:get-arg "-testdata-csv")))
             (categorypatt (if match-data (list-ref match-data 1) "%"))
             (setvarpatt  (if match-data
                              (list-ref match-data 2)
                              (args:get-arg "-testdata-csv")))
             (runsdat     (rmt:get-runs-by-patt keys (or runpatt "%") 
                                                (common:args-get-target) #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
             (header      (db:get-header runsdat))
             (access-mode (db:get-access-mode))
             (testpatt    (common:args-get-testpatt #f))
             (fields-spec (if (args:get-arg "-fields")
                              (extract-fields-constraints (args:get-arg "-fields"))
                              (list (cons "runs" (append keys (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count")))
                                    (cons "tests"  db:test-record-fields) ;; "id" "testname" "test_path")
                                    (list "steps" "id" "stepname"))))
             (tests-spec  (let ((t (alist-ref "tests" fields-spec equal?)))
                            (if (and t (null? t)) ;; all fields
                                db:test-record-fields
                                t)))
             (adj-tests-spec (delete-duplicates (if tests-spec (cons "id" tests-spec) db:test-record-fields))) 
             (test-field-index (make-hash-table))
             (runs (db:get-rows runsdat))
             )

        (if (and tests-spec (not (null? tests-spec))) ;; do some validation and processing of the test-spec
            (let ((invalid-tests-spec (filter (lambda (x)(not (member x db:test-record-fields))) tests-spec)))
              (if (null? invalid-tests-spec)
                  ;; generate the lookup map test-field-name => index-number
                  (let loop ((hed (car adj-tests-spec))
                             (tal (cdr adj-tests-spec))
                             (idx 0))
                    (hash-table-set! test-field-index hed idx)
                    (if (not (null? tal))(loop (car tal)(cdr tal)(+ idx 1))))
                  (begin
                    (debug:print-error 0 *default-log-port* "Invalid test fields specified: " (string-intersperse invalid-tests-spec ", "))
                    (exit)))))
        (let* ((table-header (string-split "target,run,test,itempath,category,var,value,comment" ","))
               (table-rows
                (apply append (map  
                               (lambda (run)
                                 (let* ((target (string-intersperse (map (lambda (x)
							 (db:get-value-by-header run header x))
						       keys) "/"))
                                        (statuses (string-split (or (args:get-arg "-status") "") ","))
                                        (run-id  (db:get-value-by-header run header "id"))
                                        (runname (db:get-value-by-header run header "runname")) 
                                        (states  (string-split (or (args:get-arg "-state") "") ","))
                                        (tests   (if tests-spec
                                                     (rmt:get-tests-for-run run-id testpatt states statuses #f #f #f 'testname 'asc ;; (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc 
                                                                        ;; use qryvals if test-spec provided
                                                                        (if tests-spec
                                                                            (string-intersperse adj-tests-spec ",")
                                                                            ;; db:test-record-fields
                                                                            #f)
                                                                        #f
                                                                        'normal)
                                                     '())))
                                   (apply append
                                          (map
                                           (lambda (test)
                                             (let* (
                                                    (test-id      (if (member "id"           tests-spec)(get-value-by-fieldname test test-field-index "id"          ) #f)) ;; (db:test-get-id         test))
                                                    (testname     (if (member "testname"     tests-spec)(get-value-by-fieldname test test-field-index "testname"    ) #f)) ;; (db:test-get-testname   test))
                                                    (itempath     (if (member "item_path"    tests-spec)(get-value-by-fieldname test test-field-index "item_path"   ) #f)) ;; (db:test-get-item-path  test))
                                                    (fullname     (conc testname
                                                                        (if (equal? itempath "")
                                                                            "" 
                                                                            (conc "/" itempath ))))
                                                    (testdat-raw (map vector->list (rmt:read-test-data-varpatt run-id test-id categorypatt setvarpatt)))
                                                    (testdat (filter
                                                              (lambda (x)
                                                                (not (equal? "logpro"
                                                                             (list-ref x 10))))
                                                              testdat-raw)))
                                               (map 
                                                (lambda (item)
                                                  (receive (id test_id category
                                                               variable value expected
                                                               tol units comment status type)
                                                      (apply values item)
                                                    (list target runname testname itempath category variable value comment)))
                                                testdat)))
                                           tests))))
                               runs))))
          (print (string-join table-header ","))
          (for-each (lambda(table-row)
                      (print (string-join (map ->string table-row) ",")))

                    
                            table-rows))))
  (set! *didsomething* #t)
  (set! *time-to-exit* #t))



;; NOTE: list-runs and list-db-targets operate on local db!!!
;;


;; IDEA: megatest list -runname blah% ...
;;
(if (or (args:get-arg "-list-runs")
	(args:get-arg "-list-db-targets"))
    (if (launch:setup)
	(let* (;; (dbstruct    (make-dbr:dbstruct path: *toppath* local: (args:get-arg "-local")))
	       (runpatt     (args:get-arg "-list-runs"))
               (access-mode (db:get-access-mode))
	       (testpatt    (common:args-get-testpatt #f))
	       ;; (if (args:get-arg "-testpatt") 
	       ;;  	        (args:get-arg "-testpatt") 
	       ;;  	        "%"))
	       (keys        (rmt:get-keys)) ;; (db:get-keys dbstruct))
	       ;; (runsdat  (db:get-runs dbstruct runpatt #f #f '()))
	;; (runsdat     (rmt:get-runs-by-patt keys (or runpatt "%") (common:args-get-target) ;; (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target)
	;; 		           	 #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
	       (runsdat     (rmt:get-runs-by-patt keys (or runpatt "%") 
                                                  (common:args-get-target) #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
	       (runstmp     (db:get-rows runsdat))
	       (header      (db:get-header runsdat))
	       ;; this is "-since" support. This looks at last mod times of <run-id>.db files
	       ;; and collects those modified since the -since time.
	       (runs        runstmp)
                        ;; (if (and (not (null? runstmp))
			;;        (args:get-arg "-since"))
			;;   (let ((changed-ids (db:get-changed-run-ids (string->number (args:get-arg "-since")))))
			;;     (let loop ((hed (car runstmp))
			;;   	     (tal (cdr runstmp))
			;;   	     (res '()))
			;;       (let ((new-res (if (member (db:get-value-by-header hed header "id") changed-ids)
			;;   		       (cons hed res)
			;;   		       res)))
			;;         (if (null? tal)
			;;   	  (reverse new-res)
			;;   	  (loop (car tal)(cdr tal) new-res)))))
			;;   runstmp))
	       (db-targets  (args:get-arg "-list-db-targets"))
	       (seen        (make-hash-table))
	       (dmode       (let ((d (args:get-arg "-dumpmode"))) ;; json, sexpr
			      (if d (string->symbol d) #f)))
	       (data        (make-hash-table))
	       (fields-spec (if (args:get-arg "-fields")
				(extract-fields-constraints (args:get-arg "-fields"))
				(list (cons "runs" (append keys (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count")))
				      (cons "tests"  db:test-record-fields) ;; "id" "testname" "test_path")
				      (list "steps" "id" "stepname"))))
	       (runs-spec   (let ((r (alist-ref "runs"  fields-spec equal?))) ;; the check is now unnecessary
			      (if (and r (not (null? r))) r (list "id" ))))
	       (tests-spec  (let ((t (alist-ref "tests" fields-spec equal?)))
			      (if (and t (null? t)) ;; all fields
				  db:test-record-fields
				  t)))
	       (adj-tests-spec (delete-duplicates (if tests-spec (cons "id" tests-spec) db:test-record-fields))) ;; '("id"))))
	       (steps-spec  (alist-ref "steps" fields-spec equal?))
	       (test-field-index (make-hash-table)))
	  (if (and tests-spec (not (null? tests-spec))) ;; do some validation and processing of the test-spec
	      (let ((invalid-tests-spec (filter (lambda (x)(not (member x db:test-record-fields))) tests-spec)))
		(if (null? invalid-tests-spec)
		    ;; generate the lookup map test-field-name => index-number
		    (let loop ((hed (car adj-tests-spec))
			       (tal (cdr adj-tests-spec))
			       (idx 0))
		      (hash-table-set! test-field-index hed idx)
		      (if (not (null? tal))(loop (car tal)(cdr tal)(+ idx 1))))
		    (begin
		      (debug:print-error 0 *default-log-port* "Invalid test fields specified: " (string-intersperse invalid-tests-spec ", "))
		      (exit)))))
	  ;; Each run
	  (for-each 
	   (lambda (run)
	     (let ((targetstr (string-intersperse (map (lambda (x)
							 (db:get-value-by-header run header x))
						       keys) "/")))
	       (if db-targets
		   (if (not (hash-table-ref/default seen targetstr #f))
		       (begin
			 (hash-table-set! seen targetstr #t)
			 ;; (print "[" targetstr "]"))))
			 (if (not dmode)
			     (print targetstr)
			     (hash-table-set! data "targets" (cons targetstr (hash-table-ref/default data "targets" '())))
			     )))
		   (let* ((run-id  (db:get-value-by-header run header "id"))
			  (runname (db:get-value-by-header run header "runname")) 
			  (states  (string-split (or (args:get-arg "-state") "") ","))
			  (statuses (string-split (or (args:get-arg "-status") "") ","))
			  (tests   (if tests-spec
				       (rmt:get-tests-for-run run-id testpatt states statuses #f #f #f 'testname 'asc ;; (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc 
							     ;; use qryvals if test-spec provided
							     (if tests-spec
								 (string-intersperse adj-tests-spec ",")
								 ;; db:test-record-fields
								 #f)
							     #f
							     'normal)
				       '())))
		     (case dmode
		       ((json ods sexpr)
			(if runs-spec
			    (for-each 
			     (lambda (field-name)
			       (mutils:hierhash-set! data (conc (db:get-value-by-header run header field-name)) targetstr runname "meta" field-name))
			     runs-spec)))
			;; (mutils:hierhash-set! data (db:get-value-by-header run header "status")     targetstr runname "meta" "status"     )
			;; (mutils:hierhash-set! data (db:get-value-by-header run header "state")      targetstr runname "meta" "state"      )
			;; (mutils:hierhash-set! data (conc (db:get-value-by-header run header "id"))  targetstr runname "meta" "id"         )
			;; (mutils:hierhash-set! data (db:get-value-by-header run header "event_time") targetstr runname "meta" "event_time" )
			;; (mutils:hierhash-set! data (db:get-value-by-header run header "comment")    targetstr runname "meta" "comment"    )
			;; ;; add last entry twice - seems to be a bug in hierhash?
			;; (mutils:hierhash-set! data (db:get-value-by-header run header "comment")    targetstr runname "meta" "comment"    )
		       (else
			(if (null? runs-spec)
			    (print "Run: " targetstr "/" runname 
				   " status: " (db:get-value-by-header run header "state")
				   " run-id: " run-id ", number tests: " (length tests)
				   " event_time: " (db:get-value-by-header run header "event_time"))
			    (begin
			      (if (not (member "target" runs-spec))
			          ;; (display (conc "Target: " targetstr))
			          (display (conc "Run: " targetstr "/" runname " ")))
			      (for-each
			       (lambda (field-name)
				 (if (equal? field-name "target")
				     (display (conc "target: " targetstr " "))
				     (display (conc field-name ": " (db:get-value-by-header run header (conc field-name)) " "))))
			       runs-spec)
			      (newline)))))
		       
		     (for-each 
		      (lambda (test)
		      	(common:debug-handle-exceptions #f
			 exn
			 (begin
			   (debug:print-error 0 *default-log-port* "Bad data in test record? " test)
			   (debug:print-error 5 *default-log-port* "exn=" (condition->list exn))
			   (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
			   (print-call-chain (current-error-port)))
			 (let* ((test-id      (if (member "id"           tests-spec)(get-value-by-fieldname test test-field-index "id"          ) #f)) ;; (db:test-get-id         test))
				(testname     (if (member "testname"     tests-spec)(get-value-by-fieldname test test-field-index "testname"    ) #f)) ;; (db:test-get-testname   test))
				(itempath     (if (member "item_path"    tests-spec)(get-value-by-fieldname test test-field-index "item_path"   ) #f)) ;; (db:test-get-item-path  test))
				(comment      (if (member "comment"      tests-spec)(get-value-by-fieldname test test-field-index "comment"     ) #f)) ;; (db:test-get-comment    test))
				(tstate       (if (member "state"        tests-spec)(get-value-by-fieldname test test-field-index "state"       ) #f)) ;; (db:test-get-state      test))
				(tstatus      (if (member "status"       tests-spec)(get-value-by-fieldname test test-field-index "status"      ) #f)) ;; (db:test-get-status     test))
				(event-time   (if (member "event_time"   tests-spec)(get-value-by-fieldname test test-field-index "event_time"  ) #f)) ;; (db:test-get-event_time test))
				(rundir       (if (member "rundir"       tests-spec)(get-value-by-fieldname test test-field-index "rundir"      ) #f)) ;; (db:test-get-rundir     test))
				(final_logf   (if (member "final_logf"   tests-spec)(get-value-by-fieldname test test-field-index "final_logf"  ) #f)) ;; (db:test-get-final_logf test))
				(run_duration (if (member "run_duration" tests-spec)(get-value-by-fieldname test test-field-index "run_duration") #f)) ;; (db:test-get-run_duration test))
				(fullname     (conc testname
						    (if (equal? itempath "")
							"" 
							(conc "(" itempath ")")))))
			   (case dmode
			     ((json ods sexpr)
			      (if tests-spec
				  (for-each
				   (lambda (field-name)
				     (mutils:hierhash-set! data  (get-value-by-fieldname test test-field-index field-name) targetstr runname "data" (conc test-id) field-name))
				   tests-spec)))
			     ;; ;; (mutils:hierhash-set! data  fullname   targetstr runname "data" (conc test-id) "tname"     )
			     ;;  (mutils:hierhash-set! data  testname   targetstr runname "data" (conc test-id) "testname"  )
			     ;;  (mutils:hierhash-set! data  itempath   targetstr runname "data" (conc test-id) "itempath"  )
			     ;;  (mutils:hierhash-set! data  comment    targetstr runname "data" (conc test-id) "comment"   )
			     ;;  (mutils:hierhash-set! data  tstate     targetstr runname "data" (conc test-id) "state"     )
			     ;;  (mutils:hierhash-set! data  tstatus    targetstr runname "data" (conc test-id) "status"    )
			     ;;  (mutils:hierhash-set! data  rundir     targetstr runname "data" (conc test-id) "rundir"    )
			     ;;  (mutils:hierhash-set! data  final_logf targetstr runname "data" (conc test-id) "final_logf")
			     ;;  (mutils:hierhash-set! data  run_duration targetstr runname "data" (conc test-id) "run_duration")
			     ;;  (mutils:hierhash-set! data  event-time targetstr runname "data" (conc test-id) "event_time")
			     ;;  ;; add last entry twice - seems to be a bug in hierhash?
			     ;;  (mutils:hierhash-set! data  event-time targetstr runname "data" (conc test-id) "event_time")
			     ;;  )
			     (else
			      (if (and tstate tstatus event-time)
				  (format #t
					  "  Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n"
					  (if fullname fullname "")
					  (if tstate   tstate   "")
					  (if tstatus  tstatus  "")
					  (get-value-by-fieldname test test-field-index "run_duration");;(if test     (db:test-get-run_duration test) "")
					  (if event-time event-time "")
					  (get-value-by-fieldname test test-field-index "host")) ;;(if test (db:test-get-host test)) "")
				  (print "  Test: " fullname
					 (if tstate  (conc " State: "  tstate)  "")
					 (if tstatus (conc " Status: " tstatus) "")
					 (if (get-value-by-fieldname test test-field-index "run_duration")
					     (conc " Runtime: " (get-value-by-fieldname test test-field-index "run_duration"))
					     "")
					 (if event-time (conc " Time: " event-time) "")
					 (if (get-value-by-fieldname test test-field-index "host")
					     (conc " Host: " (get-value-by-fieldname test test-field-index "host"))
					     "")))
			      (if (not (or (equal? (get-value-by-fieldname test test-field-index "status") "PASS")
					   (equal? (get-value-by-fieldname test test-field-index "status") "WARN")
					   (equal? (get-value-by-fieldname test test-field-index "state")  "NOT_STARTED")))
				  (begin
				    (print   (if (get-value-by-fieldname test test-field-index "cpuload")
						 (conc "         cpuload:  "   (get-value-by-fieldname test test-field-index "cpuload"))
						 "") ;; (db:test-get-cpuload test)
					     (if (get-value-by-fieldname test test-field-index "diskfree")
						 (conc "\n         diskfree: " (get-value-by-fieldname test test-field-index "diskfree")) ;; (db:test-get-diskfree test)
						 "")
					     (if (get-value-by-fieldname test test-field-index "uname")
						 (conc "\n         uname:    " (get-value-by-fieldname test test-field-index "uname")) ;; (db:test-get-uname test)
						 "")
					     (if (get-value-by-fieldname test test-field-index "rundir")
						 (conc "\n         rundir:   " (get-value-by-fieldname test test-field-index "rundir")) ;; (db:test-get-rundir test)
						 "")
;;					     "\n         rundir:   " (get-value-by-fieldname test test-field-index "") ;; (sdb:qry 'getstr ;; (filedb:get-path *fdb* 
;; 					     (db:test-get-rundir test) ;; )
					     )

				    ;; Each test
				    ;; DO NOT remote run
				    (let ((steps (rmt:get-steps-for-test run-id (db:test-get-id test)))) ;; (db:get-steps-for-test dbstruct run-id (db:test-get-id test))))
				      (for-each 
				       (lambda (step)
					 (format #t 
						 "    Step: ~20a State: ~10a Status: ~10a Time ~22a\n"
						 (tdb:step-get-stepname step)
						 (tdb:step-get-state step)
						 (tdb:step-get-status step)
						 (tdb:step-get-event_time step)))
				       steps)))))))))
		      (if (args:get-arg "-sort")
			  (sort tests
				(lambda (a-test b-test)
				  (let* ((key    (args:get-arg "-sort"))
					 (first  (get-value-by-fieldname a-test test-field-index key))
					 (second (get-value-by-fieldname b-test test-field-index key)))
				    ((cond 
				      ((and (number? first)(number? second)) <)
				      ((and (string? first)(string? second)) string<=?)
				      (else equal?))
				     first second))))
			  tests))))))
	   runs)
	  (case dmode
	    ((json)  (json-write data))
	    ((sexpr) (pp (common:to-alist data))))
	  (let* ((metadat-fields (delete-duplicates
				  (append keys '( "runname" "time" "owner" "pass_count" "fail_count" "state" "status" "comment" "id"))))
		 (run-fields    '(
				  "testname"
				  "item_path"
				  "state"
				  "status"
				  "comment"
				  "event_time"
				  "host"
				  "run_id"
				  "run_duration"
				  "attemptnum"
				  "id"
				  "archived"
				  "diskfree"
				  "cpuload"
				  "final_logf"
				  "shortdir"
				  "rundir"
				  "uname"
				  )
				)


		 (newdat          (common:to-alist data))
		 (allrundat       (if (null? newdat)
				      '()
				      (car (map cdr newdat)))) ;; (car (map cdr (car (map cdr newdat)))))
		 (runs            (append
				   (list "runs" ;; sheetname
					 metadat-fields)
				   (map (lambda (run)
					  ;; (print "run: " run)
					  (let* ((runname (car run))
						 (rundat  (cdr run))
						 (metadat (let ((tmp (assoc "meta" rundat)))
							    (if tmp (cdr tmp) #f))))
					    ;; (print "runname: " runname "\n\nrundat: " )(pp rundat)(print "\n\nmetadat: ")(pp metadat)
					    (if metadat
						(map (lambda (field)
						       (let ((tmp (assoc field metadat)))
							 (if tmp (cdr tmp) "")))
						     metadat-fields)
						(begin
						  (debug:print 0 *default-log-port* "WARNING: meta data for run " runname " not found")
						  '()))))
					allrundat)))
		 ;; '( ( "target" ( "runname" ( "data" ( "runid" ( "id . "37" ) ( ... ))))
		 (run-pages      (map (lambda (targdat)
					(let* ((target  (car targdat))
					       (runsdat (cdr targdat)))
					  (if runsdat
					      (map (lambda (rundat)
						     (let* ((runname  (car rundat))
							    (rundat   (cdr rundat))
							    (testsdat (let ((tmp (assoc "data" rundat)))
									(if tmp (cdr tmp) #f))))
						       (if testsdat
							   (let ((tests (map (lambda (test)
									       (let* ((test-id  (car test))
										      (test-dat (cdr test)))
										 (map (lambda (field)
											(let ((tmp (assoc field test-dat)))
											  (if tmp (cdr tmp) "")))
										      run-fields)))
									     testsdat)))
							     ;; (print "Target: " target "/" runname " tests:")
							     ;; (pp tests)
							     (cons (conc target "/" runname)
								   (cons (list (conc target "/" runname))
									 (cons '()
									       (cons run-fields tests)))))
							   (begin
							     (debug:print 4 *default-log-port* "WARNING: run " target "/" runname " appears to have no data")
							     ;; (pp rundat)
							     '()))))
						   runsdat)
					      '())))
				      newdat)) ;; we use newdat to get target
		 (sheets         (filter (lambda (x)
					   (not (null? x)))
					 (cons runs (map car run-pages)))))
	    ;; (print "allrundat:")
	    ;; (pp allrundat)
	    ;; (print "runs:")
	    ;; (pp runs)
	    ;(print "sheets: ")
	    ;; (pp sheets)
	    (if (eq? dmode 'ods)
		(let* ((tempdir    (conc "/tmp/" (current-user-name) "/" (random 10000) "_" (current-process-id)))
		       (outputfile (or (args:get-arg "-o") "out.ods"))
		       (ouf        (if (string-match (regexp "^[/~]+.*") outputfile) ;; full path?
				       outputfile
				       (begin
					 (debug:print 0 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory")
					 (conc (current-directory) "/" outputfile)))))
		  (create-directory tempdir #t)
		  (ods:list->ods tempdir ouf sheets))))
	  ;; (system (conc "rm -rf " tempdir))
	  (set! *didsomething* #t)
          (set! *time-to-exit* #t)
          ) ;; end if true branch (end of a let)
        ) ;; end if
    ) ;; end if -list-runs

;; list-waivers
(if (and (args:get-arg "-list-waivers")
	 (launch:setup))
    (let* ((runpatt     (or (args:get-arg "-runname") "%"))
	   (testpatt    (common:args-get-testpatt #f))
	   (keys        (rmt:get-keys)) 
	   (runsdat     (rmt:get-runs-by-patt
			 keys runpatt 
			 (common:args-get-target) #f #f
			 '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
	   (runs        (db:get-rows runsdat))
	   (header      (db:get-header runsdat))
	   (results     (make-hash-table))  ;; [target] ( (testname/itempath . "comment") ... )
	   (addtest     (lambda (target testname itempath comment)
			  (hash-table-set! results target (cons (cons (conc testname "/" itempath) comment)
								(hash-table-ref/default results target '())))))
	   (last-target #f))
      (for-each
       (lambda (run)
	 (let* ((run-id  (db:get-value-by-header run header "id"))
		(target  (rmt:get-target run-id))
		(runname (db:get-value-by-header run header "runname")) 
		(tests   (rmt:get-tests-for-run
			  run-id testpatt '("COMPLETED") '("WAIVED") #f #f #f 'testname 'asc							     ;; use qryvals if test-spec provided
			  #f #f #f)))
	   (if (not (equal? target last-target))
	       (print "[" target "]"))
	   (set! last-target target)
	   (print "# " runname)
	   (for-each
	    (lambda (testdat)
	      (let* ((testfullname (conc (db:test-get-testname testdat)
					 (if (equal? "" (db:test-get-item-path testdat))
					     ""
					     (conc "/" (db:test-get-item-path testdat)))
					 )))
	      (print testfullname " " (db:test-get-comment testdat))))
	    tests)))
       runs)
      (set! *didsomething* #t)))
      
;;======================================================================
;; full run
;;======================================================================

(define (handle-run-requests target runname keys keyvals need-clean)	 
  (if (or (args:get-arg "-kill-rerun") (args:get-arg "-rerun-clean")) ;; first set states/statuses correct
      ;; For rerun-clean do we or do we not support the testpatt?
      (let ((states   (or (configf:lookup *configdat* "validvalues" "cleanrerun-states")
			  "KILLREQ,KILLED,UNKNOWN,INCOMPLETE,STUCK,NOT_STARTED"))
	    (statuses (or (configf:lookup *configdat* "validvalues" "cleanrerun-statuses")
			  "FAIL,INCOMPLETE,ABORT,CHECK,DEAD,PREQ_FAIL,PREQ_DISCARDED")))
	(hash-table-set! args:arg-hash "-preclean" #t)
	(runs:operate-on 'set-state-status
			 target
			 (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
			 ;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
			 (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
			 state:  states
			 ;; status: statuses
			 new-state-status: "NOT_STARTED,n/a")
	(runs:clean-cache target runname *toppath*)
	(runs:operate-on 'set-state-status
			 target
			 (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
			 ;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
			 (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
			 ;; state:  states
			 status: statuses
			 new-state-status: "NOT_STARTED,n/a")))
  ;; RERUN ALL
  (if (args:get-arg "-rerun-all") ;; first set states/statuses correct
      (let* ((rconfig (full-runconfigs-read)))
	(hash-table-set! args:arg-hash "-preclean" #t)
	(runs:operate-on 'set-state-status
			 target
			 (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
			 (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt")
			 state:  #f
			 ;; status: statuses
			 new-state-status: "NOT_STARTED,n/a")
	(runs:clean-cache target runname *toppath*)
	(runs:operate-on 'set-state-status
			 target
			 (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
			 (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt")
			 ;; state:  states
			 status: #f
			 new-state-status: "NOT_STARTED,n/a")))
  (let* ((config-reruns      (let ((x (configf:lookup *configdat* "setup" "reruns")))
			       (if x (string->number x) #f)))
	 (rerun-cnt (if config-reruns
			config-reruns
			1)))

    (runs:run-tests target
		    runname
		    #f ;; (common:args-get-testpatt #f)
		    ;; (or (args:get-arg "-testpatt")
		    ;;     "%")
		    user
		    args:arg-hash
		    run-count: rerun-cnt)))

;; get lock in db for full run for this directory
;; for all tests with deps
;;   walk tree of tests to find head tasks
;;   add head tasks to task queue
;;   add dependant tasks to task queue 
;;   add remaining tasks to task queue
;; for each task in task queue
;;   if have adequate resources
;;     launch task
;;   else
;;     put task in deferred queue
;; if still ok to run tasks
;;   process deferred tasks per above steps

;; run all tests are are Not COMPLETED and PASS or CHECK
(if (or (args:get-arg "-runall")
	(args:get-arg "-run")
	(args:get-arg "-rerun-clean")
	(args:get-arg "-rerun-all")
	(args:get-arg "-runtests")
        (args:get-arg "-kill-rerun"))
    (let ((need-clean (or (args:get-arg "-rerun-clean")
                          (args:get-arg "-rerun-all")))
	  (orig-cmdline (string-intersperse (argv) " ")))
      (general-run-call 
       "-runall"
       "run all tests"
       (lambda (target runname keys keyvals)
	 (if (or (string-search "%" target)
		 (string-search "%" runname)) ;; we are being asked to re-run multiple runs
	     (let* ((run-specs (rmt:simple-get-runs runname #f #f target #f))) ;; list of simple-run records
	       (debug:print-info 0 *default-log-port* "Pattern supplied for target or runname with "
				 (length run-specs) " matches round. Running each in turn.")
	       (if (null? run-specs)
		   (debug:print 0 *default-log-port* "WARNING: No runs match target " target " and runname " runname))
	       (for-each (lambda (spec) 
			   (let* ((precmd     (if (args:get-arg "-precmd")(conc (args:get-arg "-precmd") " ") ""))
				  (newcmdline (conc
					       precmd
					       (string-substitute
						(conc "target " target)
						(conc "target " (simple-run-target spec))
						(string-substitute
						 (conc "runname " runname)
						 (conc "runname " (simple-run-runname spec))
						 orig-cmdline)))))
			     (debug:print 0 *default-log-port* "ORIG: " orig-cmdline)
			     (debug:print 0 *default-log-port* "NEW:  " newcmdline)
			     (system newcmdline)))
			 run-specs))
	     (handle-run-requests target runname keys keyvals need-clean))))))

;;======================================================================
;; run one test
;;======================================================================

;; 1. find the config file
;; 2. change to the test directory
;; 3. update the db with "test started" status, set running host
;; 4. process launch the test
;;    - monitor the process, update stats in the db every 2^n minutes
;; 5. as the test proceeds internally it calls megatest as each step is
;;    started and completed
;;    - step started, timestamp
;;    - step completed, exit status, timestamp
;; 6. test phone home
;;    - if test run time > allowed run time then kill job
;;    - if cannot access db > allowed disconnect time then kill job

;; == duplicated == (if (or (args:get-arg "-run")(args:get-arg "-runtests"))
;; == duplicated ==   (general-run-call 
;; == duplicated ==    "-runtests" 
;; == duplicated ==    "run a test" 
;; == duplicated ==    (lambda (target runname keys keyvals)
;; == duplicated ==      ;;
;; == duplicated ==      ;; May or may not implement it this way ...
;; == duplicated ==      ;;
;; == duplicated ==      ;; Insert this run into the tasks queue
;; == duplicated ==      ;; (open-run-close tasks:add tasks:open-db 
;; == duplicated ==      ;;    	     "runtests" 
;; == duplicated ==      ;;    	     user
;; == duplicated ==      ;;    	     target
;; == duplicated ==      ;;    	     runname
;; == duplicated ==      ;;    	     (args:get-arg "-runtests")
;; == duplicated ==      ;;    	     #f))))
;; == duplicated ==      (runs:run-tests target
;; == duplicated == 		     runname
;; == duplicated == 		     (common:args-get-testpatt #f) ;; (args:get-arg "-runtests")
;; == duplicated == 		     user
;; == duplicated == 		     args:arg-hash))))

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

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

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

(if (or (args:get-arg "-lock")(args:get-arg "-unlock"))
    (general-run-call 
     (if (args:get-arg "-lock") "-lock" "-unlock")
     "lock/unlock tests" 
     (lambda (target runname keys keyvals)
       (runs:handle-locking 
		  target
		  keys
		  (or (args:get-arg "-runname")(args:get-arg ":runname") )
		  (args:get-arg "-lock")
		  (args:get-arg "-unlock")
		  user))))

;;======================================================================
;; Get paths to tests
;;======================================================================
;; Get test paths matching target, runname, and testpatt
(if (or (args:get-arg "-test-files")(args:get-arg "-test-paths"))
    ;; if we are in a test use the MT_CMDINFO data
    (if (getenv "MT_CMDINFO")
	(let* ((startingdir (current-directory))
	       (cmdinfo   (common:read-encoded-string (getenv "MT_CMDINFO")))
	       (transport (assoc/default 'transport cmdinfo))
	       (testpath  (assoc/default 'testpath  cmdinfo))
	       (test-name (assoc/default 'test-name cmdinfo))
	       (runscript (assoc/default 'runscript cmdinfo))
	       (db-host   (assoc/default 'db-host   cmdinfo))
	       (run-id    (assoc/default 'run-id    cmdinfo))
	       (itemdat   (assoc/default 'itemdat   cmdinfo))
	       (state     (args:get-arg ":state"))
	       (status    (args:get-arg ":status"))
	       ;;(target    (args:get-arg "-target"))
	       (target    (common:args-get-target))
	       (toppath   (assoc/default 'toppath   cmdinfo)))
	  (change-directory toppath)
	  (if (not target)
	      (begin
		(debug:print-error 0 *default-log-port* "-target is required.")
		(exit 1)))
	  (if (not (launch:setup))
	      (begin
		(debug:print 0 *default-log-port* "Failed to setup, giving up on -test-paths or -test-files, exiting")
		(exit 1)))
	  (let* ((keys     (rmt:get-keys))
		 ;; db:test-get-paths must not be run remote
		 (paths    (tests:test-get-paths-matching keys target (args:get-arg "-test-files"))))
	    (set! *didsomething* #t)
	    (for-each (lambda (path)
			(if (common:file-exists? path)
			(print path)))	
		      paths)))
	;; else do a general-run-call
	(general-run-call 
	 "-test-files"
	 "Get paths to test"
	 (lambda (target runname keys keyvals)
	   (let* ((db       #f)
		  ;; DO NOT run remote
		  (paths    (tests:test-get-paths-matching keys target (args:get-arg "-test-files"))))
	     (for-each (lambda (path)
			 (print path))
		       paths))))))

;;======================================================================
;; Archive tests
;;======================================================================
;; Archive tests matching target, runname, and testpatt
(if (equal? (args:get-arg "-archive") "replicate-db")
    (begin
          ;; check if source
          ;; check if megatest.db exist
         (launch:setup)
         (if (not (args:get-arg "-source"))
             (begin 
             (debug:print-info 1 *default-log-port* "Missing required argument -source <archive path>")
             (exit 1)))
         (if (common:file-exists? (conc  *toppath* "/megatest.db"))
             (begin  
               (debug:print-info 1 *default-log-port* "File " (conc  *toppath* "/megatest.db") " already exists. Please remove it before trying to replicate db")
               (exit 1)))
         (if (and (common:get-db-tmp-area) (> (length (directory   (common:get-db-tmp-area) #f)) 0))
           (begin
           (debug:print-info 1 *default-log-port* (common:get-db-tmp-area) " not empty. Please remove it before trying to replicate db")
           (exit 1)))    
          ;; check if timestamp 
          (let* ((source (args:get-arg "-source"))
                (src     (if (not (equal? (substring source 0 1) "/"))
                             (conc (current-directory) "/" source)
                             source))
                (ts (if (args:get-arg "-time-stamp")   (args:get-arg "-time-stamp") "latest")))
              (if  (common:directory-exists? src)
                  (begin 
                  (archive:restore-db src ts)
            (set! *didsomething* #t))
       (begin
         (debug:print-error 1 *default-log-port* "Path " source " not found")
         (exit 1))))))   
    ;; else do a general-run-call
   (if (and (args:get-arg "-archive") (not (equal? (args:get-arg "-archive") "replicate-db"))) 
    (begin
      ;; for the archive get we need to preserve the starting dir as part of the target path
      (if (and (args:get-arg "-dest")
	       (not (equal? (substring (args:get-arg "-dest") 0 1) "/")))
	  (let ((newpath  (conc (current-directory) "/" (args:get-arg "-dest"))))
	    (debug:print-info 1 *default-log-port* "Preserving original path to destination, was " (args:get-arg "-dest") ", now " newpath)
	    (hash-table-set! args:arg-hash "-dest" newpath)))
      (general-run-call 
       "-archive"
       "Archive"
       (lambda (target runname keys keyvals)
	 (operate-on 'archive target-in: target runname-in: runname )))))

;;======================================================================
;; Extract a spreadsheet from the runs database
;;======================================================================

(if (args:get-arg "-extract-ods")
    (general-run-call
     "-extract-ods"
     "Make ods spreadsheet"
     (lambda (target runname keys keyvals)
       (let ((dbstruct   (make-dbr:dbstruct path: *toppath* local: #t))
	     (outputfile (args:get-arg "-extract-ods"))
	     (runspatt   (or (args:get-arg "-runname")(args:get-arg ":runname")))
	     (pathmod    (args:get-arg "-pathmod")))
	     ;; (keyvalalist (keys->alist keys "%")))
	 (debug:print 2 *default-log-port* "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvals: " keyvals)
	 (db:extract-ods-file dbstruct outputfile keyvals (if runspatt runspatt "%") pathmod)
	 (db:close-all dbstruct)
	 (set! *didsomething* #t)))))

;;======================================================================
;; execute the test
;;    - gets called on remote host
;;    - receives info from the -execute param
;;    - passes info to steps via MT_CMDINFO env var (future is to use a dot file)
;;    - gathers host info and 
;;======================================================================

(if (args:get-arg "-execute")
    (begin
      (launch:execute (args:get-arg "-execute"))
      (set! *didsomething* #t)))

;;======================================================================
;; recover from a test where the managing mtest was killed but the underlying
;; process might still be salvageable
;;======================================================================

(if (args:get-arg "-recover-test")
    (let* ((params (string-split (args:get-arg "-recover-test") ",")))
      (if (> (length params) 1) ;; run-id and test-id
	  (let ((run-id (string->number (car params)))
		(test-id (string->number (cadr params))))
	    (if (and run-id test-id)
		(begin
		  (launch:recover-test run-id test-id)
		  (set! *didsomething* #t))
		(begin
		  (debug:print-error 0 *default-log-port* "bad run-id or test-id, must be integers")
		  (exit 1)))))))

;;======================================================================
;; Test commands (i.e. for use inside tests)
;;======================================================================

(define (megatest:step step state status logfile msg)
  (if (not (getenv "MT_CMDINFO"))
      (begin
	(debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!")
	(exit 5))
      (let* ((cmdinfo   (common:read-encoded-string (getenv "MT_CMDINFO")))
	     (transport (assoc/default 'transport cmdinfo))
	     (testpath  (assoc/default 'testpath  cmdinfo))
	     (test-name (assoc/default 'test-name cmdinfo))
	     (runscript (assoc/default 'runscript cmdinfo))
	     (db-host   (assoc/default 'db-host   cmdinfo))
	     (run-id    (assoc/default 'run-id    cmdinfo))
	     (test-id   (assoc/default 'test-id   cmdinfo))
	     (itemdat   (assoc/default 'itemdat   cmdinfo))
	     (work-area (assoc/default 'work-area cmdinfo))
	     (db        #f))
	(change-directory testpath)
	(if (not (launch:setup))
	    (begin
	      (debug:print 0 *default-log-port* "Failed to setup, exiting")
	      (exit 1)))
	(if (and state status)
	    (let ((comment (launch:load-logpro-dat run-id test-id step)))
	      ;; (rmt:test-set-log! run-id test-id (conc stepname ".html"))))
	      (rmt:teststep-set-status! run-id test-id step state status (or comment msg) logfile))
	    (begin
	      (debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -step")
	      (exit 6))))))


(if (args:get-arg "-step")
    (begin
      (thread-sleep! 1.5)
      (megatest:step 
       (args:get-arg "-step")
       (or (args:get-arg "-state")(args:get-arg ":state"))
       (or (args:get-arg "-status")(args:get-arg ":status"))
       (args:get-arg "-setlog")
       (args:get-arg "-m"))
      ;; (if db (sqlite3:finalize! db))
      (set! *didsomething* #t)
      (thread-sleep! 1.5)))
    
(if (or (args:get-arg "-setlog")       ;; since setting up is so costly lets piggyback on -test-status
	;;     (not (args:get-arg "-step")))  ;; -setlog may have been processed already in the "-step" previous
	;;     NEW POLICY - -setlog sets test overall log on every call.
	(args:get-arg "-set-toplog")
	(args:get-arg "-test-status")
	(args:get-arg "-set-values")
	(args:get-arg "-load-test-data")
	(args:get-arg "-runstep")
	(args:get-arg "-summarize-items"))
    (if (not (getenv "MT_CMDINFO"))
	(begin
	  (debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!")
	  (exit 5))
	(let* ((startingdir (current-directory))
	       (cmdinfo   (common:read-encoded-string (getenv "MT_CMDINFO")))
	       (transport (assoc/default 'transport cmdinfo))
	       (testpath  (assoc/default 'testpath  cmdinfo))
	       (test-name (assoc/default 'test-name cmdinfo))
	       (runscript (assoc/default 'runscript cmdinfo))
	       (db-host   (assoc/default 'db-host   cmdinfo))
	       (run-id    (assoc/default 'run-id    cmdinfo))
	       (test-id   (assoc/default 'test-id   cmdinfo))
	       (itemdat   (assoc/default 'itemdat   cmdinfo))
	       (work-area (assoc/default 'work-area cmdinfo))
	       (db        #f) ;; (open-db))
	       (state     (args:get-arg ":state"))
	       (status    (args:get-arg ":status"))
	       (stepname  (args:get-arg "-step")))
	  (if (not (launch:setup))
	      (begin
		(debug:print 0 *default-log-port* "Failed to setup, exiting")
		(exit 1)))

	  (if (args:get-arg "-runstep")(debug:print-info 1 *default-log-port* "Running -runstep, first change to directory " work-area))
	  (change-directory work-area)
	  ;; can setup as client for server mode now
	  ;; (client:setup)

	  (if (args:get-arg "-load-test-data")
	      ;; has sub commands that are rdb:
	      ;; DO NOT put this one into either rmt: or open-run-close
	      (tdb:load-test-data run-id test-id))
	  (if (args:get-arg "-setlog")
	      (let ((logfname (args:get-arg "-setlog")))
		(rmt:test-set-log! run-id test-id logfname)))
	  (if (args:get-arg "-set-toplog")
	      ;; DO NOT run remote
	      (tests:test-set-toplog! run-id test-name (args:get-arg "-set-toplog")))
	  (if (args:get-arg "-summarize-items")
	      ;; DO NOT run remote
	      (tests:summarize-items run-id test-id test-name #t)) ;; do force here
	  (if (args:get-arg "-runstep")
	      (if (null? remargs)
		  (begin
		    (debug:print-error 0 *default-log-port* "nothing specified to run!")
		    (if db (sqlite3:finalize! db))
		    (exit 6))
		  (let* ((stepname   (args:get-arg "-runstep"))
			 (logprofile (args:get-arg "-logpro"))
			 (logfile    (conc stepname ".log"))
			 (cmd        (if (null? remargs) #f (car remargs)))
			 (params     (if cmd (cdr remargs) '()))
			 (exitstat   #f)
			 (shell      (let ((sh (get-environment-variable "SHELL") ))
				       (if sh 
					   (last (string-split sh "/"))
					   "bash")))
			 (redir      (case (string->symbol shell)
				       ((tcsh csh ksh)    ">&")
				       ((zsh bash sh ash) "2>&1 >")
				       (else ">&")))
			 (fullcmd    (conc "(" (string-intersperse 
						(cons cmd params) " ")
					   ") " redir " " logfile)))
		    ;; mark the start of the test
		    (rmt:teststep-set-status! run-id test-id stepname "start" "n/a" (args:get-arg "-m") logfile)
		    ;; run the test step
		    (debug:print-info 2 *default-log-port* "Running \"" fullcmd "\" in directory \"" startingdir)
		    (change-directory startingdir)
		    (set! exitstat (system fullcmd))
		    (set! *globalexitstatus* exitstat)
		    ;; (change-directory testpath)
		    ;; run logpro if applicable ;; (process-run "ls" (list "/foo" "2>&1" "blah.log"))
		    (if logprofile
			(let* ((htmllogfile (conc stepname ".html"))
			       (oldexitstat exitstat)
			       (cmd         (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " ")))
			  (debug:print-info 2 *default-log-port* "running \"" cmd "\"")
			  (change-directory startingdir)
			  (set! exitstat (system cmd))
			  (set! *globalexitstatus* exitstat) ;; no necessary
			  (change-directory testpath)
			  (rmt:test-set-log! run-id test-id htmllogfile)))
		    (let ((msg (args:get-arg "-m")))
		      (rmt:teststep-set-status! run-id test-id stepname "end" exitstat msg logfile))
		    )))
	  (if (or (args:get-arg "-test-status")
		  (args:get-arg "-set-values"))
	      (let ((newstatus (cond
				((number? status)       (if (equal? status 0) "PASS" "FAIL"))
				((and (string? status)
				      (string->number status))(if (equal? (string->number status) 0) "PASS" "FAIL"))
				(else status)))
		    ;; transfer relevant keys into a hash to be passed to test-set-status!
		    ;; could use an assoc list I guess. 
		    (otherdata (let ((res (make-hash-table)))
				 (for-each (lambda (key)
					     (if (args:get-arg key)
						 (hash-table-set! res key (args:get-arg key))))
					   (list ":value" ":tol" ":expected" ":first_err" ":first_warn" ":units" ":category" ":variable"))
				 res)))
		(if (and (args:get-arg "-test-status")
			 (or (not state)
			     (not status)))
		    (begin
		      (debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -test-status\n" help)
		      (if (sqlite3:database? db)(sqlite3:finalize! db))
		      (exit 6)))
		(let* ((msg    (args:get-arg "-m"))
		       (numoth (length (hash-table-keys otherdata))))
		  ;; Convert to rpc inside the tests:test-set-status! call, not here
		  (tests:test-set-status! run-id test-id state newstatus msg otherdata work-area: work-area))))
	  (if (sqlite3:database? db)(sqlite3:finalize! db))
	  (set! *didsomething* #t))))

;;======================================================================
;; Various helper commands can go below here
;;======================================================================

(if (or (args:get-arg "-showkeys")
        (args:get-arg "-show-keys"))
    (let ((db #f)
	  (keys #f))
      (if (not (launch:setup))
	  (begin
	    (debug:print 0 *default-log-port* "Failed to setup, exiting")
	    (exit 1)))
      (set! keys (rmt:get-keys)) ;;  db))
      (debug:print 1 *default-log-port* "Keys: " (string-intersperse keys ", "))
      (if (sqlite3:database? db)(sqlite3:finalize! db))
      (set! *didsomething* #t)))

(if (args:get-arg "-gui")
    (begin
      (debug:print 0 *default-log-port* "Look at the dashboard for now")
      ;; (megatest-gui)
      (set! *didsomething* #t)))

(if (args:get-arg "-create-megatest-area")
    (begin
      (genexample:mk-megatest.config)
      (set! *didsomething* #t)))

(if (args:get-arg "-create-test")
    (let ((testname (args:get-arg "-create-test")))
      (genexample:mk-megatest-test testname)
      (set! *didsomething* #t)))

;;======================================================================
;; Update the database schema, clean up the db
;;======================================================================

(if (args:get-arg "-rebuild-db")
    (begin
      (if (not (launch:setup))
	  (begin
	    (debug:print 0 *default-log-port* "Failed to setup, exiting") 
	    (exit 1)))
      ;; keep this one local
      ;; (open-run-close patch-db #f)
      (let ((dbstruct (db:setup #f areapath: *toppath*)))
        (common:cleanup-db dbstruct full: #t))
      (set! *didsomething* #t)))

(if (args:get-arg "-cleanup-db")
    (begin
      (if (not (launch:setup))
	  (begin
	    (debug:print 0 *default-log-port* "Failed to setup, exiting") 
	    (exit 1)))
      (let ((dbstruct (db:setup #f areapath: *toppath*)))
        (common:cleanup-db dbstruct))
      (set! *didsomething* #t)))

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

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

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

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

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


(when (args:get-arg "-diff-rep")
  (when (and
         (not (args:get-arg "-diff-html"))
         (not (args:get-arg "-diff-email")))
    (debug:print 0 *default-log-port* "Must specify -diff-html or -diff-email with -diff-rep")
    (set! *didsomething* 1)
    (exit 1))
  
  (let* ((toppath (launch:setup)))
    (do-diff-report
     (args:get-arg "-src-target")
     (args:get-arg "-src-runname")
     (args:get-arg "-target")
     (args:get-arg "-runname")
     (args:get-arg "-diff-html")
     (args:get-arg "-diff-email"))
    (set! *didsomething* #t)
    (exit 0)))

(if (or (getenv "MT_RUNSCRIPT")
	(args:get-arg "-repl")
	(args:get-arg "-load"))
    (let* ((toppath (launch:setup))
	   (dbstruct (if (and toppath
                              (common:on-homehost?))
                         (db:setup #t)
                         #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f)))
      (if *toppath*
	  (cond
	   ((getenv "MT_RUNSCRIPT")
	    ;; How to run megatest scripts
	    ;;
	    ;; #!/bin/bash
	    ;;
	    ;; export MT_RUNSCRIPT=yes
	    ;; megatest << EOF
	    ;; (print "Hello world")
	    ;; (exit)
	    ;; EOF

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

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

	    (exit)))
	  (set! *didsomething* #t))))

;;======================================================================
;; Wait on a run to complete
;;======================================================================

(if (and (args:get-arg "-run-wait")
	 (not (or (args:get-arg "-run")
		  (args:get-arg "-runtests")))) ;; run-wait is built into runtests now
    (begin
      (if (not (launch:setup))
	  (begin
	    (debug:print 0 *default-log-port* "Failed to setup, exiting") 
	    (exit 1)))
      (operate-on 'run-wait)
      (set! *didsomething* #t)))

;; ;; ;; redo me ;; Not converted to use dbstruct yet
;; ;; ;; redo me ;;
;; ;; ;; redo me (if (args:get-arg "-convert-to-norm")
;; ;; ;; redo me     (let* ((toppath (setup-for-run))
;; ;; ;; redo me 	   (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t))))
;; ;; ;; redo me       (for-each 
;; ;; ;; redo me        (lambda (field)
;; ;; ;; redo me 	 (let ((dat '()))
;; ;; ;; redo me 	   (debug:print-info 0 *default-log-port* "Getting data for field " field)
;; ;; ;; redo me 	   (sqlite3:for-each-row
;; ;; ;; redo me 	    (lambda (id val)
;; ;; ;; redo me 	      (set! dat (cons (list id val) dat)))
;; ;; ;; redo me 	    (db:get-db db run-id)
;; ;; ;; redo me 	    (conc "SELECT id," field " FROM tests;"))
;; ;; ;; redo me 	   (debug:print-info 0 *default-log-port* "found " (length dat) " items for field " field)
;; ;; ;; redo me 	   (let ((qry (sqlite3:prepare db (conc "UPDATE tests SET " field "=? WHERE id=?;"))))
;; ;; ;; redo me 	     (for-each
;; ;; ;; redo me 	      (lambda (item)
;; ;; ;; redo me 		(let ((newval ;; (sdb:qry 'getid 
;; ;; ;; redo me 		       (cadr item))) ;; )
;; ;; ;; redo me 		  (if (not (equal? newval (cadr item)))
;; ;; ;; redo me 		      (debug:print-info 0 *default-log-port* "Converting " (cadr item) " to " newval " for test #" (car item)))
;; ;; ;; redo me 		  (sqlite3:execute qry newval (car item))))
;; ;; ;; redo me 	      dat)
;; ;; ;; redo me 	     (sqlite3:finalize! qry))))
;; ;; ;; redo me        (db:close-all dbstruct)
;; ;; ;; redo me        (list "uname" "rundir" "final_logf" "comment"))
;; ;; ;; redo me       (set! *didsomething* #t)))

(if (args:get-arg "-import-megatest.db")
    (begin
      (db:multi-db-sync 
       (db:setup #f)
       'killservers
       'dejunk
       'adj-testids
       'old2new
       ;; 'new2old
       )

      (set! *didsomething* #t)))

(when (args:get-arg "-sync-brute-force")
  ((server:get-bruteforce-syncer (db:setup #t) persist-until-sync: #t))
  (set! *didsomething* #t))

(if (args:get-arg "-sync-to-megatest.db")
    (let* ((dbstruct (db:setup #f))
	   (tmpdbpth (cdr (dbr:dbstruct-tmpdb dbstruct)))
	   (lockfile (conc tmpdbpth ".lock"))
	   (locked   (common:simple-file-lock lockfile)) 
	   (res      (if locked
			 (db:multi-db-sync 
			  dbstruct
			  'new2old)
			 #f)))
      (if res
	  (begin
	    (common:simple-file-release-lock lockfile)
	    (print "Synced " res " records to megatest.db"))
	  (print "Skipping sync, there is a sync in progress."))
      (set! *didsomething* #t)))

(if (args:get-arg "-sync-to")
    (let ((toppath (launch:setup)))
      (tasks:sync-to-postgres *configdat* (args:get-arg "-sync-to"))
      (set! *didsomething* #t)))

(if (args:get-arg "-list-test-time")
     (let* ((toppath (launch:setup))) 
     (task:get-test-times)  
     (set! *didsomething* #t)))

(if (args:get-arg "-list-run-time")
     (let* ((toppath (launch:setup))) 
     (task:get-run-times)  
     (set! *didsomething* #t)))
     
(if (args:get-arg "-generate-html")
    (let* ((toppath (launch:setup)))
      (if (tests:create-html-tree #f)
          (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/page0.html")
          (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html"))
      (set! *didsomething* #t)))

(if (args:get-arg "-generate-html-structure")
    (let* ((toppath (launch:setup)))
      ;(if (tests:create-html-tree #f)
 				(if (tests:create-html-summary #f)
          (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/targets.html")
          (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html"))
      (set! *didsomething* #t)))

(if (args:get-arg "-syscheck")
    (begin
      (mutils:syscheck common:raw-get-remote-host-load
		       server:get-best-guess-address
		       read-config)
      (set! *didsomething* #t)))

(if (args:get-arg "-extract-skeleton")
    (let* ((toppath (launch:setup)))
      (genexample:extract-skeleton-area (args:get-arg "-extract-skeleton"))
      (set! *didsomething* #t)))

;;======================================================================
;; Exit and clean up
;;======================================================================

(if (not *didsomething*)
    (debug:print 0 *default-log-port* help)
    (set! *time-to-exit* #t)
    )

;;(debug:print-info 13 *default-log-port* "thread-join! watchdog")

;; join the watchdog thread if it has been thread-start!ed  (it may not have been started in the case of a server that never enters running state)
;;   (symbols returned by thread-state: created ready running blocked suspended sleeping terminated dead)
;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
(if (thread? *watchdog*)
    (case (thread-state *watchdog*)
      ((ready running blocked sleeping terminated dead)
       (thread-join! *watchdog*))))

(set! *time-to-exit* #t)

(if (not (eq? *globalexitstatus* 0))
    (if (or (args:get-arg "-run")(args:get-arg "-runtests")(args:get-arg "-runall"))
        (begin
           (debug:print 0 *default-log-port* "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*)
           (exit 0))
        (case *globalexitstatus*
         ((0)(exit 0))
         ((1)(exit 1))
         ((2)(exit 2))
         (else (exit 3)))))













>
>
>
>
>
>
|
>
>
>
>
>
>
|

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>


>
>

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|


>
>







>
>
>


|
|
|
|
|
<
|
|
>
|
|
|
|
|
|
<
>
|
|
|
>
>
>
>
>
>
>
>
>

<
>
>
>
|
<
<
<
<
>
|
<
|
<
<
<
<
|
>
>
|
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
<
|
<
<
<
<
<
<
|
|
>
>
>
>
>
>
|
|
|
|
<
|
>
|
<
|
<
<
<
|
|
|
|
|
|
|
|
|
<
|
|
<
<
|
|
|
<
|
|
|
>
>
>
>
>
>
>
<
<
|
|
>
|
|
|
>
>
|
|
<
<
|
<
|
|
<
<
|
<
|
|
>
|
|
|
|
|
|
|
|
<
<
<
|
<
|
>
|
<
>
>
|
|
|
>
>
|
|
|
|
|
|
|
|
|
>
>
|
<
|
|
|
|
|
|
<
|
<
>
|
<
|
|
|
|
|
|
|
|
|
<
<
|
>
|
>
|
|
|
>
|
<
|
|
<
|
|
|
|
|
|
|
|
|
|
|
<
|
>
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
<
<
|
|
>
|
|
>
|
|
|
|
>
>
|
|
<
<
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
<
|
|
|
|
|
|
<
|
|
>
>
|
<
|
|
|
>
>
>
>
>
>
|
>
>
>
|
>
>
>
>
>
>
>
>
|
<
>
>
|
<
|
|
|
<
<
<
<
<
<
<
<
<
<
<
|
>
>
|
>
|
|
|
|
|
>
|
|
>
|
>
>
>
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
<
<
>
|
>
>
|
>
>
>
|
|
|
>
|
<
>
|
>
>
>
>
>
>
|
<
<
<
|
<
<
<
<
<
<
<
|
|
>
|
|
|
|
|
|
<
|
>
>
>
|
|
<
<
|
>
>
|
>
>
|
|
>
|
>
|
|
>
|
|
|
>
>
|
>
>
|
<
<
<
|
>
>
|
>
>
>
|
|
|
>
>
|
|
<
|
<
|
|
<
|
<
|
|
<
<
<
<
|
|
|
|
|
|
|
|
|
>
>
>
|
<
|
<
|
|
|
>
>
>
|
|
|
|
|
|
<
>
|
<
|
>
>
>
>
>
|
>
>
|
<
<
>
|
<
<
<
<
<
|
|
>
>
>
>
>
>
>
>
|
|
<
<
<
<
>
>
>
>
|
<
<
|
<
>
|
>
>
>
>
>
>
>
>
|
<
|
<
|
|
<
<
|
|
<
<
<
<
>
>
>
>
>
|
<
|
>
>
>
|
<
<
<
|
|
|
|
|
>
>
>
|
<
>
>
>
>
>
>
|
|
|
|
|
<
>
|
>
>
|
|
<
>
|
<
<
|
<
|
>
|
|
|
<
<
|
|
|
|
>
|
<
|
|
|
<
<
|
>
>
|
|
|
|
|
|
|
|
|
|
|
>
>
|
|
|
<
<
<
<
<
<
<
|
>
>
>
|
<
>
|
|
|
|
<
<
<
<
>
>
|
|
|
<
|
>
|
|
|
<
<
<
<
|
|
>
>
|
>
>
|
|
|
|
|
|
>
>
|
|
<
|
<
|
<
<
<
<
<
<
<
<
|
|
|
<
>
|
<
>
>
>
>
|
<
<
<
|
|
<
>
>
|
|
|
|
|
|
|
<
>
>
>
|
<
<
>
|
<
|
|
|
|
>
>
>
|
|
|
|
|
|
|
|
|
|
>
>
|
|
>
>
>
|
<
|
<
<
>
>
|
>
>
>
>
>
|
>
|
|
|
|
>
|
|
|
|
<
<
<
<
<
<
|
|
<
>
|
>
>
>
|
<
<
<
|
|
|
>
>
|
<
<
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
<
>
|
|
|
|
|
|
|
|
|
|
|
<
<
|
<
<
<
<
<
<
<
<
<
|
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
>
>
>
>
>
>
|
<
<
<
<
<
<
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
>
>
>
>
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187

188
189
190
191
192
193
194
195
196

197
198
199
200
201
202
203
204
205
206
207
208
209
210

211
212
213
214




215
216

217




218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244



245






246
247
248
249
250
251
252
253
254
255
256
257

258
259
260

261



262
263
264
265
266
267
268
269
270

271
272


273
274
275

276
277
278
279
280
281
282
283
284
285


286
287
288
289
290
291
292
293
294
295


296

297
298


299

300
301
302
303
304
305
306
307
308
309
310



311

312
313
314

315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333

334
335
336
337
338
339

340

341
342

343
344
345
346
347
348
349
350
351


352
353
354
355
356
357
358
359
360

361
362

363
364
365
366
367
368
369
370
371
372
373

374
375
376
377
378
379
380
381
382

383
384
385
386
387
388
389


390
391
392
393
394
395
396
397
398
399
400
401
402
403


404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422



423
424
425
426
427
428

429
430
431
432
433

434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456

457
458
459

460
461
462











463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482

483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501




502
503
504
505
506
507
508
509
510
511
512
513
514

515
516
517
518
519
520
521
522
523



524







525
526
527
528
529
530
531
532
533

534
535
536
537
538
539


540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562



563
564
565
566
567
568
569
570
571
572
573
574
575
576

577

578
579

580

581
582




583
584
585
586
587
588
589
590
591
592
593
594
595

596

597
598
599
600
601
602
603
604
605
606
607
608

609
610

611
612
613
614
615
616
617
618
619
620


621
622





623
624
625
626
627
628
629
630
631
632
633
634




635
636
637
638
639


640

641
642
643
644
645
646
647
648
649
650
651

652

653
654


655
656




657
658
659
660
661
662

663
664
665
666
667



668
669
670
671
672
673
674
675
676

677
678
679
680
681
682
683
684
685
686
687

688
689
690
691
692
693

694
695


696

697
698
699
700
701


702
703
704
705
706
707

708
709
710


711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729







730
731
732
733
734

735
736
737
738
739




740
741
742
743
744

745
746
747
748
749




750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766

767

768








769
770
771

772
773

774
775
776
777
778



779
780

781
782
783
784
785
786
787
788
789

790
791
792
793


794
795

796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820

821


822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840






841
842

843
844
845
846
847
848



849
850
851
852
853
854


855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890

891
892
893
894
895
896
897
898
899
900
901
902


903









904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184








1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444







1445












1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473

1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544


1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756

1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806


1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588

2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645

2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718

2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
;;     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))
(declare (uses adjutant))

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

;;;                    (seconds->local-time (current-seconds))
;;;                    "%Yww%V.%w %H:%M:%S"))


;;;               " "
;;;               (current-user-name) " "
;;;               (current-directory) " "

;;;               "\"" (string-intersperse (argv) " ") "\""))
;;;            #:append))
;;;      
;;;      ;; Disabled help items
;;;      ;;  -rollup                 : (currently disabled) fill run (set by :runname)  with latest test(s)
;;;      ;;                            from prior runs with same keys
;;;      ;;  -daemonize              : fork into background and disconnect from stdin/out
;;;      
;;;      (define help (conc "
;;;      Megatest, documentation at http://www.kiatoa.com/fossils/megatest


;;;        version " megatest-version "
;;;        license GPL, Copyright Matt Welland 2006-2017
;;;       
;;;      Usage: megatest [options]
;;;        -h                      : this help
;;;        -manual                 : show the Megatest user manual
;;;        -version                : print megatest version (currently " megatest-version ")
;;;      
;;;      Launching and managing runs
;;;        -run                    : run all tests or as specified by -testpatt


;;;        -remove-runs            : remove the data for a run, requires -runname and -testpatt

;;;                                  Optionally use :state and :status, use -keep-records to remove only
;;;                                  the run data. Use -kill-wait to override the 10 second


;;;                                  per test wait after kill delay (e.g. -kill-wait 0). 

;;;        -kill-runs              : kill existing run(s) (all incomplete tests killed)
;;;        -kill-rerun             : kill an existing run (all incomplete tests killed and run is rerun)
;;;        -set-state-status X,Y   : set state to X and status to Y, requires controls per -remove-runs
;;;        -rerun FAIL,WARN...     : force re-run for tests with specificed status(s)
;;;        -rerun-clean            : set all tests not COMPLETED+PASS,WARN,WAIVED to NOT_STARTED,n/a
;;;                                  and then run the specified testpatt with -preclean
;;;        -rerun-all              : set all tests to NOT_STARTED,n/a and run with -preclean
;;;        -lock                   : lock run specified by target and runname
;;;        -unlock                 : unlock run specified by target and runname
;;;        -set-run-status status  : sets status for run to status, requires -target and -runname
;;;        -get-run-status         : gets status for run specified by target and runname



;;;        -run-wait               : wait on run specified by target and runname

;;;        -preclean               : remove the existing test directory before running the test
;;;        -clean-cache            : remove the cached megatest.config and runconfigs.config files
;;;        -no-cache               : do not use the cached config files. 

;;;        -one-pass               : launch as many tests as you can but do not wait for more to be ready
;;;        -remove-keep N          : remove all but N most recent runs per target; use '-actions, -age, -precmd'
;;;        -age <age>              : 120d,3h,20m to apply only to runs older than the 
;;;                                       specified age. NB// M=month, m=minute
;;;        -actions <action>[,...] : actions to take; print,remove-runs,archive,kill-runs
;;;        -precmd                 : insert a wrapper command in front of the commands run
;;;      
;;;      Selectors (e.g. use for -runtests, -remove-runs, -set-state-status, -list-runs etc.)
;;;        -target key1/key2/...   : run for key1, key2, etc.
;;;        -reqtarg key1/key2/...  : run for key1, key2, etc. but key1/key2 must be in runconfigs
;;;        -testpatt patt1/patt2,patt3/...  : % is wildcard
;;;        -runname                : required, name for this particular test run
;;;        -state                  : Applies to runs, tests or steps depending on context
;;;        -status                 : Applies to runs, tests or steps depending on context
;;;        -modepatt key           : load testpatt from <key> in runconfigs instead of default TESTPATT if -testpatt and -tagexpr are not specified
;;;        -tagexpr tag1,tag2%,..  : select tests with tags matching expression
;;;        
;;;      
;;;      Test helpers (for use inside tests)

;;;        -step stepname
;;;        -test-status            : set the state and status of a test (use :state and :status)
;;;        -setlog logfname        : set the path/filename to the final log relative to the test
;;;                                  directory. may be used with -test-status
;;;        -set-toplog logfname    : set the overall log for a suite of sub-tests
;;;        -summarize-items        : for an itemized test create a summary html 

;;;        -m comment              : insert a comment for this test

;;;      
;;;      Test data capture

;;;        -set-values             : update or set values in the testdata table
;;;        :category               : set the category field (optional)
;;;        :variable               : set the variable name (optional)
;;;        :value                  : value measured (required)
;;;        :expected               : value expected (required)
;;;        :tol                    : |value-expect| <= tol (required, can be <, >, >=, <= or number)
;;;        :units                  : name of the units for value, expected_value etc. (optional)
;;;        -load-test-data         : read test specific data for storage in the test_data table
;;;                                  from standard in. Each line is comma delimited with four


;;;                                  fields category,variable,value,comment
;;;      
;;;      Queries
;;;        -list-runs patt         : list runs matching pattern \"patt\", % is the wildcard
;;;        -show-keys              : show the keys used in this megatest setup
;;;        -test-files targpatt    : get the most recent test path/file matching targpatt e.g. %/% or '*.log'
;;;                                  returns list sorted by age ascending, see examples below
;;;        -test-paths             : get the test paths matching target, runname, item and test
;;;                                  patterns.

;;;        -list-disks             : list the disks available for storing runs
;;;        -list-targets           : list the targets in runconfigs.config

;;;        -list-db-targets        : list the target combinations used in the db
;;;        -show-config            : dump the internal representation of the megatest.config file
;;;        -show-runconfig         : dump the internal representation of the runconfigs.config file
;;;        -dumpmode MODE          : dump in MODE format instead of sexpr, MODE=json,ini,sexp etc. (add -debug 0,9 to see which file contributes each line)
;;;        -show-cmdinfo           : dump the command info for a test (run in test environment)
;;;        -section sectionName
;;;        -var varName            : for config and runconfig lookup value for sectionName varName
;;;        -since N                : get list of runs changed since time N (Unix seconds)
;;;        -fields fieldspec       : fields to include in json dump; runs:id,runame+tests:testname+steps
;;;        -sort fieldname         : in -list-runs sort tests by this field
;;;        -testdata-csv [categorypatt/]varpatt  : dump testdata for given category

;;;      
;;;      Misc 
;;;        -start-dir path         : switch to this directory before running megatest
;;;        -contour cname          : add a level of hierarcy to the linktree and run paths
;;;        -area-tag tagname       : add a tag to an area while syncing to pgdb
;;;        -run-tag tagname        : add a tag to a run while syncing to pgdb
;;;        -rebuild-db             : bring the database schema up to date
;;;        -cleanup-db             : remove any orphan records, vacuum the db
;;;        -import-megatest.db     : push data from megatest.db to cache db files in /tmp/$USER

;;;        -sync-to-megatest.db    : pull data from cache files in /tmp/$USER to megatest.db
;;;        -sync-to dest           : sync to new postgresql central style database
;;;        -update-meta            : update the tests metadata for all tests
;;;        -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are
;;;                                       overwritten by values set in config files.
;;;        -server -|hostname      : start the server (reduces contention on megatest.db), use
;;;                                  - to automatically figure out hostname


;;;        -adjutant C,M           : start the server/adjutant with allocated cores C and Mem M (Gig), 
;;;                                  use 0,0 to auto use full machine
;;;        -transport http|rpc     : use http or rpc for transport (default is http) 
;;;        -log logfile            : send stdout and stderr to logfile
;;;        -list-servers           : list the servers 
;;;        -kill-servers           : kill all servers
;;;        -repl                   : start a repl (useful for extending megatest)
;;;        -load file.scm          : load and run file.scm
;;;        -mark-incompletes       : find and mark incomplete tests
;;;        -ping run-id|host:port  : ping server, exit with 0 if found
;;;        -debug N|N,M,O...       : enable debug 0-N or N and M and O ...
;;;        -debug-noprop N|M,M,O...: enable debug but do not propagate to subprocesses via MT_DEBUG
;;;        -config fname           : override the megatest.config file with fname
;;;        -append-config fname    : append fname to the megatest.config file


;;;      
;;;      Utilities
;;;        -env2file fname         : write the environment to fname.csh and fname.sh
;;;        -envcap a               : save current variables labeled as context 'a' in file envdat.db
;;;        -envdelta a-b           : output enviroment delta from context a to context b to -o fname
;;;                                  set the output mode with -dumpmode csh, bash or ini
;;;                                  note: ini format will use calls to use curr and minimize path
;;;        -refdb2dat refdb        : convert refdb to sexp or to format specified by s-dumpmode
;;;                                  formats: perl, ruby, sqlite3, csv (for csv the -o param
;;;                                  will substitute %s for the sheet name in generating 
;;;                                  multiple sheets)
;;;        -o                      : output file for refdb2dat (defaults to stdout)
;;;        -archive cmd            : archive runs specified by selectors to one of disks specified
;;;                                  in the [archive-disks] section.
;;;                                  cmd: keep-html, restore, save, save-remove, get, replicate-db (use 
;;;                                  -dest to set destination), -include path1,path2... to get or save specific files
;;;        -generate-html          : create a simple html dashboard for browsing your runs
;;;        -generate-html-structure  : create a top level html veiw to list targets/runs and a Run view within each run directory.  
;;;        -list-run-time          : list time requered to complete runs. It supports following switches



;;;                                  -run-patt <patt> -target-patt <patt> -dumpmode <csv,json,plain-text>
;;;        -list-test-time	  : list time requered to complete each test in a run. It following following arguments
;;;                                  -runname <patt> -target <patt> -dumpmode <csv,json,plain-text>
;;;        -syscheck               : do some very basic checks; write access and space in tmp, home, runs, links and 
;;;                                  is $DISPLAY valid 
;;;        -list-waivers           : dump waivers for specified target, runname, testpatt to stdout

;;;      
;;;      Diff report
;;;        -diff-rep               : generate diff report (must include -src-target, -src-runname, -target, -runname
;;;                                                        and either -diff-email or -diff-html)
;;;        -src-target <target>

;;;        -src-runname <target>
;;;        -diff-email <emails>    : comma separated list of email addresses to send diff report
;;;        -diff-html  <rep.html>  : path to html file to generate
;;;      
;;;      Spreadsheet generation
;;;        -extract-ods fname.ods  : extract an open document spreadsheet from the database
;;;        -pathmod path           : insert path, i.e. path/runame/itempath/logfile.html
;;;                                  will clear the field if no rundir/testname/itempath/logfile
;;;                                  if it contains forward slashes the path will be converted
;;;                                  to windows style
;;;      Getting started
;;;        -create-megatest-area   : create a skeleton megatest area. You will be prompted for paths
;;;        -create-test testname   : create a skeleton megatest test. You will be prompted for info
;;;      
;;;      Examples
;;;      
;;;      # Get test path, use '.' to get a single path or a specific path/file pattern
;;;      megatest -test-files 'logs/*.log' -target ubuntu/n%/no% -runname w49% -testpatt test_mt%
;;;      
;;;      Called as " (string-intersperse (argv) " ") "
;;;      Version " megatest-version ", built from " megatest-fossil-hash ))
;;;      
;;;      ;;  -gui                    : start a gui interface

;;;      ;;  -config fname           : override the runconfigs file with fname
;;;      
;;;      ;; process args

;;;      (define remargs (args:get-args 
;;;      		 (argv)
;;;      		 (list  "-runtests"  ;; run a specific test











;;;      			"-config"    ;; override the config file name
;;;      			"-append-config"
;;;      			"-execute"   ;; run the command encoded in the base64 parameter
;;;      			"-step"
;;;      			"-target"
;;;      			"-reqtarg"
;;;      			":runname"
;;;      			"-runname"
;;;      			":state"  
;;;      			"-state"
;;;      			":status"
;;;      			"-status"
;;;      			"-list-runs"
;;;                              "-testdata-csv"
;;;      			"-testpatt"
;;;                              "--modepatt"
;;;                              "-modepatt"
;;;                              "-tagexpr"
;;;      			"-itempatt"
;;;      			"-setlog"

;;;      			"-set-toplog"
;;;      			"-runstep"
;;;      			"-logpro"
;;;      			"-m"
;;;      			"-rerun"
;;;      
;;;      			"-days"
;;;      			"-rename-run"
;;;      			"-to"
;;;      			"-dest"
;;;                              "-source" 
;;;                              "-time-stamp" 
;;;      			;; values and messages
;;;      			":category"
;;;      			":variable"
;;;      			":value"
;;;      			":expected"
;;;      			":tol"
;;;      			":units"




;;;      
;;;      			;; misc
;;;      			"-start-dir"
;;;                              "-run-patt"
;;;                              "-target-patt"   
;;;      			"-contour"
;;;                              "-area-tag"  
;;;                              "-area"  
;;;      			"-run-tag"
;;;      			"-server"
;;;      			"-adjutant"
;;;      			"-transport"
;;;      			"-port"

;;;      			"-extract-ods"
;;;      			"-pathmod"
;;;      			"-env2file"
;;;      			"-envcap"
;;;      			"-envdelta"
;;;      			"-setvars"
;;;      			"-set-state-status"
;;;      
;;;                              ;; move runs stuff here



;;;                              "-remove-keep"           







;;;      			"-set-run-status"
;;;      			"-age"
;;;      
;;;      			;; archive 
;;;      			"-archive"
;;;      			"-actions"
;;;      			"-precmd"
;;;      			"-include"
;;;      			"-exclude-rx"

;;;      			"-exclude-rx-from"
;;;      			
;;;      			"-debug" ;; for *verbosity* > 2
;;;      			"-debug-noprop"
;;;      			"-create-test"
;;;      			"-override-timeout"


;;;      			"-test-files"  ;; -test-paths is for listing all
;;;      			"-load"        ;; load and exectute a scheme file
;;;      			"-section"
;;;      			"-var"
;;;      			"-dumpmode"
;;;      			"-run-id"
;;;      			"-ping"
;;;      			"-refdb2dat"
;;;      			"-o"
;;;      			"-log"
;;;                              "-sync-log"
;;;      			"-since"
;;;      			"-fields"
;;;      			"-recover-test" ;; run-id,test-id - used internally to recover a test stuck in RUNNING state
;;;      			"-sort"
;;;      			"-target-db"
;;;      			"-source-db"
;;;      			"-prefix-target"
;;;      
;;;                              "-src-target"
;;;                              "-src-runname"
;;;                              "-diff-email"
;;;      			"-sync-to"			



;;;      			"-pgsync"
;;;      			"-kill-wait"    ;; wait this long before removing test (default is 10 sec)
;;;                              "-diff-html"
;;;      
;;;      			;; wizards, area capture, setup new ...
;;;      			"-extract-skeleton"
;;;      			)
;;;       		 (list  "-h" "-help" "--help"
;;;      			"-manual"
;;;      			"-version"
;;;      		        "-force"
;;;      		        "-xterm"
;;;      		        "-showkeys"
;;;      		        "-show-keys"

;;;      		        "-test-status"

;;;      			"-set-values"
;;;      			"-load-test-data"

;;;      			"-summarize-items"

;;;      		        "-gui"
;;;      			"-daemonize"




;;;      			"-preclean"
;;;      			"-rerun-clean"
;;;      			"-rerun-all"
;;;      			"-clean-cache"
;;;      			"-no-cache"
;;;      			"-cache-db"
;;;      			"-cp-eventtime-to-publishtime"
;;;                              "-use-db-cache"
;;;                              "-prepend-contour"
;;;      
;;;      
;;;      			;; misc
;;;      			"-repl"

;;;      			"-lock"

;;;      			"-unlock"
;;;      			"-list-servers"
;;;      			"-kill-servers"
;;;                              "-run-wait"      ;; wait on a run to complete (i.e. no RUNNING)
;;;      			"-one-pass"      ;;
;;;      			"-local"         ;; run some commands using local db access
;;;      			"-generate-html"
;;;      			"-generate-html-structure" 
;;;      			"-list-run-time"
;;;                              "-list-test-time"
;;;      			
;;;      			;; misc queries

;;;      			"-list-disks"
;;;      			"-list-targets"

;;;      			"-list-db-targets"
;;;      			"-show-runconfig"
;;;      			"-show-config"
;;;      			"-show-cmdinfo"
;;;      			"-get-run-status"
;;;      			"-list-waivers"
;;;      
;;;      			;; queries
;;;      			"-test-paths" ;; get path(s) to a test, ordered by youngest first
;;;      


;;;      			"-runall"    ;; run all tests, respects -testpatt, defaults to %
;;;      			"-run"       ;; alias for -runall





;;;      			"-remove-runs"
;;;                              "-kill-runs"
;;;                              "-kill-rerun"
;;;                              "-keep-records" ;; use with -remove-runs to remove only the run data
;;;      			"-rebuild-db"
;;;      			"-cleanup-db"
;;;      			"-rollup"
;;;      			"-update-meta"
;;;      			"-create-megatest-area"
;;;      			"-mark-incompletes"
;;;      
;;;      			"-convert-to-norm"




;;;      			"-convert-to-old"
;;;      			"-import-megatest.db"
;;;      			"-sync-to-megatest.db"
;;;                              "-sync-brute-force"
;;;      			"-logging"


;;;      			"-v" ;; verbose 2, more than normal (normal is 1)

;;;      			"-q" ;; quiet 0, errors/warnings only
;;;      
;;;                              "-diff-rep"
;;;      
;;;      			"-syscheck"
;;;      			"-obfuscate"
;;;      			;; junk placeholder
;;;      			;; "-:p"
;;;      			
;;;                              )
;;;      		 args:arg-hash

;;;      		 0))

;;;      
;;;      ;; Add args that use remargs here


;;;      ;;
;;;      (if (and (not (null? remargs))




;;;      	 (not (or
;;;      	       (args:get-arg "-runstep")
;;;      	       (args:get-arg "-envcap")
;;;      	       (args:get-arg "-envdelta")
;;;      	       )
;;;      	      ))

;;;          (debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv))  " ")))
;;;      
;;;      ;; before doing anything else change to the start-dir if provided
;;;      ;;
;;;      (if (args:get-arg "-start-dir")



;;;          (if (common:file-exists? (args:get-arg "-start-dir"))
;;;              (let ((fullpath (common:real-path (args:get-arg "-start-dir"))))
;;;                (setenv "PWD" fullpath)
;;;                (change-directory fullpath))
;;;      	(begin
;;;      	  (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.")
;;;      	  (exit 1))))
;;;      
;;;      ;; immediately set MT_TARGET if -reqtarg or -target are available

;;;      ;;
;;;      (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target"))))
;;;        (if targ (setenv "MT_TARGET" targ)))
;;;      
;;;      ;; The watchdog is to keep an eye on things like db sync etc.
;;;      ;;
;;;      
;;;      ;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
;;;      (define *watchdog* (make-thread
;;;      		    (lambda ()
;;;      		      (handle-exceptions

;;;      			  exn
;;;      			  (begin
;;;      			    (print-call-chain)
;;;      			    (print " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn))
;;;      			(common:watchdog)))
;;;      		    "Watchdog thread"))

;;;      
;;;      ;;(if (not (args:get-arg "-server"))


;;;      ;;    (thread-start! *watchdog*)) ;; if starting a server; wait till we get to running state before kicking off watchdog

;;;      (let* ((no-watchdog-args
;;;             '("-list-runs"
;;;               "-testdata-csv"
;;;               "-list-servers"
;;;               "-server"


;;;      	 "-adjutant"
;;;               "-list-disks"
;;;               "-list-targets"
;;;               "-show-runconfig"
;;;               ;;"-list-db-targets"
;;;               "-show-runconfig"

;;;               "-show-config"
;;;               "-show-cmdinfo"
;;;      	 "-cleanup-db"


;;;                  ))
;;;             (no-watchdog-argvals (list '("-archive" . "replicate-db")))
;;;             (start-watchdog-specail-arg-val (let loop ((hed  (car no-watchdog-argvals))
;;;                                                        (tail (cdr   no-watchdog-argvals)))
;;;                                                   ;; (print "hed" hed " arg " (args:get-arg (car hed)) " val:" (cdr hed)  " eql" (equal? (args:get-arg (car hed)) (cdr hed)))  
;;;                                                   (if (equal? (args:get-arg (car hed)) (cdr hed))
;;;                                                     #f
;;;                                                     (if (null? tail)
;;;                                                       #t
;;;                                                       (loop (car tail) (cdr tail))))))      
;;;             (no-watchdog-args-vals (filter (lambda (x) x)
;;;                                            (map args:get-arg no-watchdog-args)))
;;;             (start-watchdog (and (null? no-watchdog-args-vals) start-watchdog-specail-arg-val)))
;;;             ;(print  "no-watchdog-args="no-watchdog-args "no-watchdog-args-vals="no-watchdog-args-vals " start-watchdog-specail-arg-val:" start-watchdog-specail-arg-val " start-watchdog:" start-watchdog) 
;;;        (if start-watchdog
;;;            (thread-start! *watchdog*)))
;;;      
;;;      
;;;      ;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions







;;;      (define (open-logfile logpath-in)
;;;        (condition-case
;;;         (let* ((log-dir (or (pathname-directory logpath-in) "."))
;;;      	  (fname   (pathname-strip-directory logpath-in))
;;;      	  (logpath (if (> (string-length fname) 250)

;;;      		       (let ((newlogf (conc log-dir "/" (common:get-signature fname) ".log")))
;;;      			 (debug:print 0 *default-log-port* "WARNING: log file " logpath-in " path too long, converted to " newlogf)
;;;      			 newlogf)
;;;      		       logpath-in)))
;;;           (if (not (directory-exists? log-dir))




;;;               (system (conc "mkdir -p " log-dir)))
;;;           (open-output-file logpath))
;;;         (exn ()
;;;              (debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath-in)
;;;              (define *didsomething* #t)  

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




;;;      ;;
;;;      (if (or (args:get-arg "-log")(args:get-arg "-server")) ;; redirect the log always when a server
;;;          (handle-exceptions
;;;      	exn
;;;      	(begin
;;;      	  (print "ERROR: Failed to switch to log output. " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
;;;      	  )
;;;            (let* ((tl   (or (args:get-arg "-log")(launch:setup)))   ;; run launch:setup if -server, ensure we do NOT run launch:setup if -log specified
;;;      	     (logf (or (args:get-arg "-log") ;; use -log unless we are a server, then craft a logfile name
;;;      		       (conc tl "/logs/server-" (current-process-id) "-" (get-host-name) ".log")))
;;;      	     (oup  (open-logfile logf)))
;;;      	(if (not (args:get-arg "-log"))
;;;      	    (hash-table-set! args:arg-hash "-log" logf)) ;; fake out future queries of -log
;;;      	(debug:print-info 0 *default-log-port* "Sending log output to " logf)
;;;      	(set! *default-log-port* oup))))
;;;      
;;;      (if (or (args:get-arg "-h")

;;;      	(args:get-arg "-help")

;;;      	(args:get-arg "--help"))








;;;          (begin
;;;            (print help)
;;;            (exit)))

;;;      
;;;      (if (args:get-arg "-manual")

;;;          (let* ((htmlviewercmd (or (configf:lookup *configdat* "setup" "htmlviewercmd")
;;;      			      (common:which '("firefox" "arora"))))
;;;      	   (install-home  (common:get-install-area))
;;;      	   (manual-html   (conc install-home "/share/docs/megatest_manual.html")))
;;;            (if (and install-home



;;;      	       (common:file-exists? manual-html))
;;;      	  (system (conc "(" htmlviewercmd " " manual-html " ) &"))

;;;      	  (system (conc "(" htmlviewercmd " http://www.kiatoa.com/cgi-bin/fossils/megatest/doc/tip/docs/manual/megatest_manual.html ) &")))
;;;            (exit)))
;;;      
;;;      (if (args:get-arg "-version")
;;;          (begin
;;;            (print (common:version-signature)) ;; (print megatest-version)
;;;            (exit)))
;;;      
;;;      (define *didsomething* #f)

;;;      
;;;      ;; Overall exit handling setup immediately
;;;      ;;
;;;      (if (or (args:get-arg "-process-reap"))


;;;              ;; (args:get-arg "-runtests")
;;;      	;; (args:get-arg "-execute")

;;;      	;; (args:get-arg "-remove-runs")
;;;      	;; (args:get-arg "-runstep"))
;;;          (let ((original-exit (exit-handler)))
;;;            (exit-handler (lambda (#!optional (exit-code 0))
;;;      		      (printf "Preparing to exit with exit code ~A ...\n" exit-code)
;;;      		      (for-each
;;;      		       
;;;      		       (lambda (pid)
;;;      			 (handle-exceptions
;;;      			     exn
;;;      			   (begin
;;;      			     (printf "process reap failed. exn=~A\n" exn)
;;;      			     #t)
;;;      			  (let-values (((pid-val exit-status exit-code) (process-wait pid #t)))
;;;      				      (if (or (eq? pid-val pid)
;;;      					      (eq? pid-val 0))
;;;      					  (begin
;;;      					    (printf "Sending signal/term to ~A\n" pid)
;;;      					    (process-signal pid signal/term))))))
;;;      		       (process:children #f))
;;;      		      (original-exit exit-code)))))
;;;      
;;;      ;; for some switches always print the command to stderr
;;;      ;;
;;;      (if (args:any? "-run" "-runall" "-remove-runs" "-set-state-status" "-kill-runs" "-kill-rerun")

;;;          (debug:print 0 *default-log-port* (string-intersperse (argv) " ")))


;;;      
;;;      ;; some switches imply homehost. Exit here if not on homehost
;;;      ;;
;;;      (let ((homehost-required  (list "-cleanup-db" "-server")))
;;;        (if (apply args:any? homehost-required)
;;;            (if (not (common:on-homehost?))
;;;      	  (for-each
;;;      	   (lambda (switch)
;;;      	     (if (args:get-arg switch)
;;;      		 (begin
;;;      		   (debug:print 0 *default-log-port* "ERROR: you must be on the homehost to run with " switch
;;;      				", you can move homehost by removing the .homehost file but this will disrupt any runs in progress.")
;;;      		   (exit 1))))
;;;      	   homehost-required))))
;;;      
;;;      ;;======================================================================
;;;      ;; Misc setup stuff
;;;      ;;======================================================================
;;;      






;;;      (debug:setup)
;;;      

;;;      (if (args:get-arg "-logging")(set! *logging* #t))
;;;      
;;;      ;;(if (debug:debug-mode 3) ;; we are obviously debugging
;;;      ;;    (set! open-run-close open-run-close-no-exception-handling))
;;;      
;;;      (if (args:get-arg "-itempatt")



;;;          (let ((newval (conc (args:get-arg "-testpatt") "/" (args:get-arg "-itempatt"))))
;;;            (debug:print 0 *default-log-port* "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval)
;;;            (hash-table-set! args:arg-hash "-testpatt" newval)
;;;            (hash-table-delete! args:arg-hash "-itempatt")))
;;;      
;;;      (if (args:get-arg "-runtests")


;;;          (debug:print 0 *default-log-port* "WARNING: \"-runtests\" is deprecated. Use \"-run\" with \"-testpatt\" instead"))
;;;      
;;;      (on-exit std-exit-procedure)
;;;      
;;;      ;;======================================================================
;;;      ;; Misc general calls
;;;      ;;======================================================================
;;;      
;;;      (if (and (args:get-arg "-cache-db")
;;;               (args:get-arg "-source-db"))
;;;          (let* ((temp-dir (or (args:get-arg "-target-db") (create-directory (conc "/tmp/" (getenv "USER") "/" (string-translate (current-directory) "/" "_")))))
;;;                 (target-db (conc temp-dir "/cached.db"))
;;;                 (source-db (args:get-arg "-source-db")))        
;;;            (db:cache-for-read-only source-db target-db)
;;;            (set! *didsomething* #t)))
;;;      
;;;      ;; handle a clean-cache request as early as possible
;;;      ;;
;;;      (if (args:get-arg "-clean-cache")
;;;          (let ((toppath  (launch:setup)))
;;;            (set! *didsomething* #t) ;; suppress the help output.
;;;            (runs:clean-cache (common:args-get-target)
;;;      			(args:get-arg "-runname")
;;;      			toppath)))
;;;      	  
;;;      (if (args:get-arg "-env2file")
;;;          (begin
;;;            (save-environment-as-files (args:get-arg "-env2file"))
;;;            (set! *didsomething* #t)))
;;;      
;;;      (if (args:get-arg "-list-disks")
;;;          (let ((toppath (launch:setup)))
;;;            (print 
;;;             (string-intersperse 
;;;      	(map (lambda (x)
;;;      	       (string-intersperse 

;;;      		x
;;;      		" => "))
;;;      	     (common:get-disks *configdat*))
;;;      	"\n"))
;;;            (set! *didsomething* #t)))
;;;      
;;;      ;; csv processing record
;;;      (define (make-refdb:csv)
;;;        (vector 
;;;         (make-sparse-array)
;;;         (make-hash-table)
;;;         (make-hash-table)


;;;         0









;;;         0))
;;;      (define-inline (refdb:csv-get-svec     vec)    (vector-ref  vec 0))
;;;      (define-inline (refdb:csv-get-rows     vec)    (vector-ref  vec 1))
;;;      (define-inline (refdb:csv-get-cols     vec)    (vector-ref  vec 2))
;;;      (define-inline (refdb:csv-get-maxrow   vec)    (vector-ref  vec 3))
;;;      (define-inline (refdb:csv-get-maxcol   vec)    (vector-ref  vec 4))
;;;      (define-inline (refdb:csv-set-svec!    vec val)(vector-set! vec 0 val))
;;;      (define-inline (refdb:csv-set-rows!    vec val)(vector-set! vec 1 val))
;;;      (define-inline (refdb:csv-set-cols!    vec val)(vector-set! vec 2 val))
;;;      (define-inline (refdb:csv-set-maxrow!  vec val)(vector-set! vec 3 val))
;;;      (define-inline (refdb:csv-set-maxcol!  vec val)(vector-set! vec 4 val))
;;;      
;;;      (define (get-dat results sheetname)
;;;        (or (hash-table-ref/default results sheetname #f)
;;;            (let ((tmp-vec  (make-refdb:csv)))
;;;      	(hash-table-set! results sheetname tmp-vec)
;;;      	tmp-vec)))
;;;      
;;;      (if (args:get-arg "-refdb2dat")
;;;          (let* ((input-db (args:get-arg "-refdb2dat"))
;;;      	   (out-file (args:get-arg "-o"))
;;;      	   (out-fmt  (or (args:get-arg "-dumpmode") "scheme"))
;;;      	   (out-port (if (and out-file 
;;;      			      (not (member out-fmt '("sqlite3" "csv"))))
;;;      			 (open-output-file out-file)
;;;      			 (current-output-port)))
;;;      	   (res-data (configf:read-refdb input-db))
;;;      	   (data     (car res-data))
;;;      	   (msg      (cadr res-data)))
;;;            (if (not data)
;;;      	  (debug:print 0 *default-log-port* "Bad input? data=" data) ;; some error occurred
;;;      	  (with-output-to-port out-port
;;;      	    (lambda ()
;;;      	      (case (string->symbol out-fmt)
;;;      		((scheme)(pp data))
;;;      		((perl)
;;;      		 ;; (print "%hash = (")
;;;      		 ;;        key1 => 'value1',
;;;      		 ;;        key2 => 'value2',
;;;      		 ;;        key3 => 'value3',
;;;      		 ;; );
;;;      		 (configf:map-all-hier-alist 
;;;      		  data 
;;;      		  (lambda (sheetname sectionname varname val)
;;;      		    (print "$data{\"" sheetname "\"}{\"" sectionname "\"}{\"" varname "\"} = \"" val "\";"))))
;;;      		((python ruby)
;;;      		 (print "data={}")
;;;      		 (configf:map-all-hier-alist
;;;      		  data
;;;      		  (lambda (sheetname sectionname varname val)
;;;      		    (print "data[\"" sheetname "\"][\"" sectionname "\"][\"" varname "\"] = \"" val "\""))
;;;      		  initproc1:
;;;      		  (lambda (sheetname)
;;;      		    (print "data[\"" sheetname "\"] = {}"))
;;;      		  initproc2:
;;;      		  (lambda (sheetname sectionname)
;;;      		    (print "data[\"" sheetname "\"][\"" sectionname "\"] = {}"))))
;;;      		((csv)
;;;      		 (let* ((results  (make-hash-table)) ;; (make-sparse-array)))
;;;      			(row-cols (make-hash-table))) ;; hash of hashes where section => ht { row-<name> => num or col-<name> => num
;;;      		   ;; (print "data=")
;;;      		   ;; (pp data)
;;;      		   (configf:map-all-hier-alist
;;;      		    data
;;;      		    (lambda (sheetname sectionname varname val)
;;;      		      ;; (print "sheetname: " sheetname ", sectionname: " sectionname ", varname: " varname ", val: " val)
;;;      		      (let* ((dat      (get-dat results sheetname))
;;;      			     (vec      (refdb:csv-get-svec dat))
;;;      			     (rownames (refdb:csv-get-rows dat))
;;;      			     (colnames (refdb:csv-get-cols dat))
;;;      			     (currrown (hash-table-ref/default rownames varname #f))
;;;      			     (currcoln (hash-table-ref/default colnames sectionname #f))
;;;      			     (rown     (or currrown 
;;;      					   (let* ((lastn   (refdb:csv-get-maxrow dat))
;;;      						  (newrown (+ lastn 1)))
;;;      					     (refdb:csv-set-maxrow! dat newrown)
;;;      					     newrown)))
;;;      			     (coln     (or currcoln 
;;;      					   (let* ((lastn   (refdb:csv-get-maxcol dat))
;;;      						  (newcoln (+ lastn 1)))
;;;      					     (refdb:csv-set-maxcol! dat newcoln)
;;;      					     newcoln))))
;;;      			(if (not (sparse-array-ref vec 0 coln)) ;; (eq? rown 0)
;;;      			    (begin
;;;      			      (sparse-array-set! vec 0 coln sectionname)
;;;      			      ;; (print "sparse-array-ref " 0 "," coln "=" (sparse-array-ref vec 0 coln))
;;;      			      ))
;;;      			(if (not (sparse-array-ref vec rown 0)) ;; (eq? coln 0)
;;;      			    (begin
;;;      			      (sparse-array-set! vec rown 0 varname)
;;;      			      ;; (print "sparse-array-ref " rown "," 0 "=" (sparse-array-ref vec rown 0))
;;;      			      ))
;;;      			(if (not currrown)(hash-table-set! rownames varname rown))
;;;      			(if (not currcoln)(hash-table-set! colnames sectionname coln))
;;;      			;; (print "dat=" dat ", rown=" rown ", coln=" coln)
;;;      			(sparse-array-set! vec rown coln val)
;;;      			;; (print "sparse-array-ref " rown "," coln "=" (sparse-array-ref vec rown coln))
;;;      			)))
;;;      		   (for-each
;;;      		    (lambda (sheetname)
;;;      		      (let* ((sheetdat (get-dat results sheetname))
;;;      			     (svec     (refdb:csv-get-svec sheetdat))
;;;      			     (maxrow   (refdb:csv-get-maxrow sheetdat))
;;;      			     (maxcol   (refdb:csv-get-maxcol sheetdat))
;;;      			     (fname    (if out-file 
;;;      					   (string-substitute "%s" sheetname out-file) ;; "/foo/bar/%s.csv")
;;;      					   (conc sheetname ".csv"))))
;;;      			(with-output-to-file fname
;;;      			  (lambda ()
;;;      			    ;; (print "Sheetname: " sheetname)
;;;      			    (let loop ((row       0)
;;;      				       (col       0)
;;;      				       (curr-row '())
;;;      				       (result   '()))
;;;      			      (let* ((val (sparse-array-ref svec row col))
;;;      				     (disp-val (if val
;;;      						   (conc "\"" val "\"")
;;;      						   "")))
;;;      				(if (> col 0)(display ","))
;;;      				(display disp-val)
;;;      				(cond
;;;      				 ((> row maxrow)(display "\n") result)
;;;      				 ((>= col maxcol)
;;;      				  (display "\n")
;;;      				  (loop (+ row 1) 0 '() (append result (list curr-row))))
;;;      				 (else
;;;      				  (loop row (+ col 1) (append curr-row (list val)) result)))))))))
;;;      		    (hash-table-keys results))))
;;;      		((sqlite3)
;;;      		 (let* ((db-file   (or out-file (pathname-file input-db)))
;;;      			(db-exists (common:file-exists? db-file))
;;;      			(db        (sqlite3:open-database db-file)))
;;;      		   (if (not db-exists)(sqlite3:execute db "CREATE TABLE data (sheet,section,var,val);"))
;;;      		   (configf:map-all-hier-alist
;;;      		    data
;;;      		    (lambda (sheetname sectionname varname val)
;;;      		      (sqlite3:execute db
;;;      				       "INSERT OR REPLACE INTO data (sheet,section,var,val) VALUES (?,?,?,?);"
;;;      				       sheetname sectionname varname val)))
;;;      		   (sqlite3:finalize! db)))
;;;      		(else
;;;      		 (pp data))))))
;;;            (if out-file (close-output-port out-port))
;;;            (exit) ;; yes, bending the rules here - need to exit since this is a utility
;;;            ))
;;;      
;;;      (if (args:get-arg "-ping")
;;;          (let* ((server-id     (string->number (args:get-arg "-ping"))) ;; extract run-id (i.e. no ":"
;;;      	   (host:port     (args:get-arg "-ping")))
;;;            (server:ping (or server-id host:port) #f do-exit: #t)))
;;;      
;;;      ;;======================================================================
;;;      ;; Capture, save and manipulate environments
;;;      ;;======================================================================
;;;      
;;;      ;; NOTE: Keep these above the section where the server or client code is setup
;;;      
;;;      (let ((envcap (args:get-arg "-envcap")))
;;;        (if envcap
;;;            (let* ((db      (env:open-db (if (null? remargs) "envdat.db" (car remargs)))))
;;;      	(env:save-env-vars db envcap)
;;;      	(env:close-database db)
;;;      	(set! *didsomething* #t))))
;;;      
;;;      ;; delta "language" will eventually be res=a+b-c but for now it is just res=a-b 
;;;      ;;
;;;      (let ((envdelta (args:get-arg "-envdelta")))
;;;        (if envdelta
;;;            (let ((match (string-split envdelta "-")));; (string-match "([a-z0-9_]+)=([a-z0-9_\\-,]+)" envdelta)))
;;;      	(if (not (null? match))
;;;      	    (let* ((db        (env:open-db (if (null? remargs) "envdat.db" (car remargs))))
;;;      		   ;; (resctx    (cadr match))
;;;      		   ;; (equn      (caddr match))
;;;      		   (parts     match) ;; (string-split equn "-"))
;;;      		   (minuend   (car parts))
;;;      		   (subtraend (cadr parts))
;;;      		   (added     (env:get-added   db minuend subtraend))
;;;      		   (removed   (env:get-removed db minuend subtraend))
;;;      		   (changed   (env:get-changed db minuend subtraend)))
;;;      	      ;; (pp (hash-table->alist added))
;;;      	      ;; (pp (hash-table->alist removed))
;;;      	      ;; (pp (hash-table->alist changed))
;;;      	      (if (args:get-arg "-o")
;;;      		  (with-output-to-file
;;;      		      (args:get-arg "-o")
;;;      		    (lambda ()
;;;      		      (env:print added removed changed)))
;;;      		  (env:print added removed changed))
;;;      	      (env:close-database db)
;;;      	      (set! *didsomething* #t))
;;;      	    (debug:print-error 0 *default-log-port* "Parameter to -envdelta should be new=start-end")))))
;;;      
;;;      ;;======================================================================
;;;      ;; Start the server - can be done in conjunction with -runall or -runtests (one day...)
;;;      ;;   we start the server if not running else start the client thread
;;;      ;;======================================================================
;;;      
;;;      ;; Server? Start up here.
;;;      ;;
;;;      (if (args:get-arg "-server")
;;;          (let ((tl        (launch:setup))
;;;                (transport-type (string->symbol (or (args:get-arg "-transport") "http"))))
;;;            (server:launch 0 transport-type)
;;;            (set! *didsomething* #t)))
;;;      
;;;      ;; The adjutant is a bit different, it does NOT run (launch:setup) as it is not necessarily tied to
;;;      ;; a specific Megatest area. Detail are being hashed out and this may change.
;;;      ;;
;;;      (if (args:get-arg "-adjutant")
;;;          (begin
;;;            (adjutant-run)
;;;            (set! *didsomething* #t)))
;;;      
;;;      (if (or (args:get-arg "-list-servers")
;;;              (args:get-arg "-kill-servers"))
;;;          (let ((tl (launch:setup)))
;;;            (if tl ;; all roads from here exit
;;;      	  (let* ((servers (server:get-list *toppath*))
;;;      		 (fmtstr  "~8a~22a~20a~20a~8a\n"))
;;;      	    (format #t fmtstr "pid" "Interface:port" "age (hms)" "Last mod" "State")
;;;      	    (format #t fmtstr "===" "==============" "=========" "========" "=====")
;;;      	    (for-each ;;  ( mod-time host port start-time pid )
;;;      	     (lambda (server)
;;;      	       (let* ((mtm (any->number (car server)))
;;;      		      (mod (if mtm (- (current-seconds) mtm) "unk"))
;;;      		      (age (- (current-seconds)(or (any->number (list-ref server 3)) (current-seconds))))
;;;      		      (url (conc (cadr server) ":" (caddr server)))
;;;      		      (pid (list-ref server 4))
;;;      		      (alv (if (number? mod)(< mod 10) #f)))
;;;      		 (format #t
;;;      			 fmtstr
;;;      			 pid
;;;      			 url
;;;      			 (seconds->hr-min-sec age)
;;;      			 (seconds->hr-min-sec mod)
;;;      			 (if alv "alive" "dead"))
;;;      		 (if (and alv
;;;      			  (args:get-arg "-kill-servers"))
;;;      		     (begin
;;;      		       (debug:print-info 0 *default-log-port* "Attempting to kill server with pid " pid)
;;;      		       (server:kill server)))))
;;;      	     (sort servers (lambda (a b)
;;;      			     (let ((ma (or (any->number (car a)) 9e9))
;;;      				   (mb (or (any->number (car b)) 9e9)))
;;;      			       (> ma mb)))))
;;;      	    ;; (debug:print-info 1 *default-log-port* "Done with listservers")
;;;      	    (set! *didsomething* #t)
;;;      	    (exit))
;;;      	  (exit))))
;;;            ;; must do, would have to add checks to many/all calls below
;;;      
;;;      ;;======================================================================
;;;      ;; Weird special calls that need to run *after* the server has started?
;;;      ;;======================================================================
;;;      
;;;      (if (args:get-arg "-list-targets")
;;;          (if (launch:setup)
;;;              (let ((targets (common:get-runconfig-targets)))
;;;                ;; (debug:print 1 *default-log-port* "Found "(length targets) " targets")
;;;                (case (string->symbol (or (args:get-arg "-dumpmode") "alist"))
;;;                  ((alist)
;;;                   (for-each (lambda (x)
;;;                               ;; (print "[" x "]"))
;;;                               (print x))
;;;                             targets))
;;;                  ((json)
;;;                   (json-write targets))
;;;                  (else
;;;                   (debug:print-error 0 *default-log-port* "dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets")))
;;;                (set! *didsomething* #t))))
;;;      
;;;      ;; cache the runconfigs in $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME/.runconfig
;;;      ;;
;;;      (define (full-runconfigs-read)
;;;      ;; in the envprocessing branch the below code replaces the further below code
;;;      ;;  (if (eq? *configstatus* 'fulldata)
;;;      ;;      *runconfigdat*
;;;      ;;      (begin
;;;      ;;	(launch:setup)
;;;      ;;	*runconfigdat*)))
;;;      








;;;        (let* ((rundir (if (and (getenv "MT_LINKTREE")(getenv "MT_TARGET")(getenv "MT_RUNNAME"))
;;;      		     (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME"))
;;;      		     #f))
;;;      	 (cfgf   (if rundir (conc rundir "/.runconfig." megatest-version "-" megatest-fossil-hash) #f)))
;;;          (if (and cfgf
;;;      	     (common:file-exists? cfgf)
;;;      	     (file-writable? cfgf)
;;;      	     (common:use-cache?))
;;;      	(configf:read-alist cfgf)
;;;      	(let* ((keys   (rmt:get-keys))
;;;      	       (target (common:args-get-target))
;;;      	       (key-vals (if target (keys:target->keyval keys target) #f))
;;;      	       (sections (if target (list "default" target) #f))
;;;      	       (data     (begin
;;;      			   (setenv "MT_RUN_AREA_HOME" *toppath*)
;;;      			   (if key-vals
;;;      			       (for-each (lambda (kt)
;;;      					   (setenv (car kt) (cadr kt)))
;;;      					 key-vals))
;;;      			   ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections))))
;;;                                 (runconfig:read (conc *toppath* "/runconfigs.config") target #f))))
;;;      	  (if (and rundir ;; have all needed variabless
;;;      		   (directory-exists? rundir)
;;;      		   (file-writable? rundir))
;;;      	      (begin
;;;                      (if (not (common:in-running-test?))
;;;                          (configf:write-alist data cfgf))
;;;      		;; force re-read of megatest.config - this resolves circular references between megatest.config
;;;      		(launch:setup force-reread: #t)
;;;      		;; (launch:cache-config) ;; there are two independent config cache locations, turning this one off for now. MRW.
;;;      		)) ;; we can safely cache megatest.config since we have a valid runconfig
;;;      	  data))))
;;;      
;;;      (if (args:get-arg "-show-runconfig")
;;;          (let ((tl (launch:setup)))
;;;            (push-directory *toppath*)
;;;            (let ((data (full-runconfigs-read)))
;;;      	;; keep this one local
;;;      	(cond
;;;      	 ((and (args:get-arg "-section")
;;;      	       (args:get-arg "-var"))
;;;      	  (let ((val (or (configf:lookup data (args:get-arg "-section")(args:get-arg "-var"))
;;;      			 (configf:lookup data "default" (args:get-arg "-var")))))
;;;      	    (if val (print val))))
;;;      	 ((or (not (args:get-arg "-dumpmode"))
;;;                    (string=? (args:get-arg "-dumpmode") "ini"))
;;;      	  (configf:config->ini data))
;;;      	 ((string=? (args:get-arg "-dumpmode") "sexp")
;;;      	  (pp (hash-table->alist data)))
;;;      	 ((string=? (args:get-arg "-dumpmode") "json")
;;;      	  (json-write data))
;;;      	 (else
;;;      	  (debug:print-error 0 *default-log-port* "-dumpmode of " (args:get-arg "-dumpmode") " not recognised")))
;;;      	(set! *didsomething* #t))
;;;            (pop-directory)))
;;;      
;;;      (if (args:get-arg "-show-config")
;;;          (let ((tl   (launch:setup))
;;;      	  (data *configdat*)) ;; (read-config "megatest.config" #f #t)))
;;;            (push-directory *toppath*)
;;;            ;; keep this one local
;;;            (cond 
;;;             ((and (args:get-arg "-section")
;;;      	     (args:get-arg "-var"))
;;;      	(let ((val (configf:lookup data (args:get-arg "-section")(args:get-arg "-var"))))
;;;      	  (if val (print val))))
;;;      
;;;             ;; print just a section if only -section
;;;      
;;;             ((equal? (args:get-arg "-dumpmode") "sexp")
;;;      	(pp (hash-table->alist data)))
;;;             ((equal? (args:get-arg "-dumpmode") "json")
;;;      	(json-write data))
;;;             ((or (not (args:get-arg "-dumpmode"))
;;;      	    (string=? (args:get-arg "-dumpmode") "ini"))
;;;      	(configf:config->ini data))
;;;             (else
;;;      	(debug:print-error 0 *default-log-port* "-dumpmode of " (args:get-arg "-dumpmode") " not recognised")))
;;;            (set! *didsomething* #t)
;;;            (pop-directory)
;;;            (set! *time-to-exit* #t)))
;;;      
;;;      (if (args:get-arg "-show-cmdinfo")
;;;          (if (or (args:get-arg ":value")(getenv "MT_CMDINFO"))
;;;      	(let ((data (common:read-encoded-string (or (args:get-arg ":value")(getenv "MT_CMDINFO")))))
;;;      	  (if (equal? (args:get-arg "-dumpmode") "json")
;;;      	      (json-write data)
;;;      	      (pp data))
;;;      	  (set! *didsomething* #t))
;;;      	(debug:print-info 0 *default-log-port* "environment variable MT_CMDINFO is not set")))
;;;      
;;;      ;;======================================================================
;;;      ;; Remove old run(s)
;;;      ;;======================================================================
;;;      
;;;      ;; since several actions can be specified on the command line the removal
;;;      ;; is done first
;;;      (define (operate-on action #!key (mode #f)(target-in #f)(runname-in #f)(keys-in #f)(keyvals-in #f)) ;; #f is "use default"
;;;        (let* ((runrec (runs:runrec-make-record))
;;;      	 (target (or target-in   (common:args-get-target))) ;; eventually get rid of the call to common:args-get-target
;;;      	 (runname (or runname-in
;;;      		      (args:get-arg "-runname"))) ;; eventually get rid of the get-arg calls
;;;      	 (testpatt (or (args:get-arg "-testpatt")
;;;      		       (and (eq? action 'archive) ;; if it is an archive command fallback to MT_TEST_NAME and MT_ITEMPATH
;;;      			    (common:get-full-test-name))
;;;      		       (and (eq? action 'kill-runs)
;;;      			    "%/%") ;; I'm just guessing that this is correct :(
;;;      		       (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")))
;;;      		       ))) ;;
;;;          (cond
;;;           ((not target)
;;;            (debug:print-error 0 *default-log-port* "Missing required parameter for "
;;;      			 action ", you must specify -target or -reqtarg")
;;;            (exit 1))
;;;           ((not runname)
;;;            (debug:print-error 0 *default-log-port* "Missing required parameter for "
;;;      			 action ", you must specify the run name pattern with -runname patt")
;;;            (exit 2))
;;;           ((not testpatt)
;;;            (debug:print-error 0 *default-log-port* "Missing required parameter for "
;;;      			 action ", you must specify the test pattern with -testpatt")
;;;            (exit 3))
;;;           (else
;;;            (if (not (car *configinfo*))
;;;      	  (begin
;;;      	    (debug:print-error 0 *default-log-port* "Attempted " action "on test(s) but run area config file not found")
;;;      	    (exit 1))
;;;      	  ;; put test parameters into convenient variables
;;;      	  (begin
;;;      	    ;; check for correct version, exit with message if not correct
;;;      	    (common:exit-on-version-changed)
;;;      	    (runs:operate-on  action
;;;      			      target
;;;      			      runname
;;;      			      testpatt
;;;      			      state:  (common:args-get-state)
;;;      			      status: (common:args-get-status)
;;;      			      new-state-status: (args:get-arg "-set-state-status")
;;;                                    mode: mode)))
;;;            (set! *didsomething* #t)))))
;;;      
;;;      (if (args:get-arg "-kill-runs")
;;;          (general-run-call 
;;;           "-kill-runs"
;;;           "kill runs"
;;;           (lambda (target runname keys keyvals)
;;;             (operate-on 'kill-runs mode: #f)
;;;             )))
;;;      
;;;      (if (args:get-arg "-kill-rerun")
;;;          (let* ((target-patt (common:args-get-target))
;;;                 (runname-patt (args:get-arg "-runname")))
;;;            (cond ((not target-patt)
;;;                   (debug:print-error 0 *default-log-port* "Missing target, must specify target for -kill-rerun with -target <target name>")
;;;                   (exit 1))
;;;                  ((not runname-patt)
;;;                   (debug:print-error 0 *default-log-port* "Missing runname, must specify runname for -kill-rerun with -runname <run name>")
;;;                   (exit 1))
;;;                  ((string-search "[ ,%]" target-patt)
;;;                   (debug:print-error 0 *default-log-port* "Invalid target ["target-patt"], must specify exact target (no wildcards) for -kill-rerun with -target <target name>")
;;;                   (exit 1))
;;;                  ((string-search "[ ,%]" runname-patt)
;;;                   (debug:print-error 0 *default-log-port* "Invalid runname ["runname-patt"], must specify exact runname (no wildcards) for -kill-rerun with -runname <runname name>")
;;;                   (exit 1))
;;;                  (else
;;;                   (general-run-call 
;;;                    "-kill-runs"
;;;                    "kill runs"
;;;                    (lambda (target runname keys keyvals)
;;;                      (operate-on 'kill-runs mode: #f)
;;;                      ))
;;;            
;;;                   (thread-sleep! 15))
;;;                  ;; fall thru and let "-run" loop fire
;;;                  )))
;;;      
;;;      
;;;      (if (args:get-arg "-remove-runs")
;;;          (general-run-call 
;;;           "-remove-runs"
;;;           "remove runs"
;;;           (lambda (target runname keys keyvals)
;;;             (operate-on 'remove-runs mode: (if (args:get-arg "-keep-records")
;;;                                                'remove-data-only
;;;                                                'remove-all)))))
;;;      
;;;      (if (args:get-arg "-remove-keep")
;;;          (general-run-call 
;;;           "-remove-keep"
;;;           "remove keep"
;;;           (lambda (target runname keys keyvals)
;;;             (let ((actions (map string->symbol
;;;                                 (string-split
;;;      			    (or (args:get-arg "-actions")
;;;      				"print")
;;;      			    ",")))) ;; default to printing the output
;;;               (runs:remove-all-but-last-n-runs-per-target target runname
;;;      						     (string->number (args:get-arg "-remove-keep"))
;;;      						     actions: actions)))))
;;;      
;;;      (if (args:get-arg "-set-state-status")
;;;          (general-run-call 
;;;           "-set-state-status"
;;;           "set state and status"
;;;           (lambda (target runname keys keyvals)
;;;             (operate-on 'set-state-status))))
;;;      
;;;      (if (or (args:get-arg "-set-run-status")
;;;      	(args:get-arg "-get-run-status"))
;;;          (general-run-call
;;;           "-set-run-status"
;;;           "set run status"
;;;           (lambda (target runname keys keyvals)
;;;             (let* ((runsdat  (rmt:get-runs-by-patt keys runname 
;;;      					(common:args-get-target)
;;;      					#f #f #f #f))
;;;      	      (header   (vector-ref runsdat 0))
;;;      	      (rows     (vector-ref runsdat 1)))
;;;      	 (if (null? rows)
;;;      	     (begin
;;;      	       (debug:print-info 0 *default-log-port* "No matching run found.")
;;;      	       (exit 1))
;;;      	     (let* ((row      (car (vector-ref runsdat 1)))
;;;      		    (run-id   (db:get-value-by-header row header "id")))
;;;      	       (if (args:get-arg "-set-run-status")
;;;      		   (rmt:set-run-status run-id (args:get-arg "-set-run-status") msg: (args:get-arg "-m"))
;;;      		   (print (rmt:get-run-status run-id))
;;;      		   )))))))
;;;      
;;;      ;;======================================================================
;;;      ;; Query runs
;;;      ;;======================================================================
;;;      
;;;      ;; -fields runs:id,target,runname,comment+tests:id,testname,item_path+steps
;;;      ;;
;;;      ;; csi> (extract-fields-constraints "runs:id,target,runname,comment+tests:id,testname,item_path+steps")
;;;      ;;         => (("runs" "id" "target" "runname" "comment") ("tests" "id" "testname" "item_path") ("steps"))
;;;      ;;
;;;      ;;   NOTE: remember that the cdr will be the list you expect (cdr ("runs" "id" "target" "runname" "comment")) => ("id" "target" "runname" "comment")
;;;      ;;         and so alist-ref will yield what you expect
;;;      ;;
;;;      (define (extract-fields-constraints fields-spec)
;;;        (map (lambda (table-spec) ;; runs:id,target,runname
;;;      	 (let ((dat (string-split table-spec ":"))) ;; ("runs" "id,target,runname")
;;;      	   (if (> (length dat) 1)
;;;      	       (cons (car dat)(string-split (cadr dat) ",")) ;; "id,target,runname"
;;;      	       dat)))
;;;             (string-split fields-spec "+")))
;;;      
;;;      (define (get-value-by-fieldname datavec test-field-index fieldname)
;;;        (let ((indx (hash-table-ref/default test-field-index fieldname #f)))
;;;          (if indx
;;;      	(if (>= indx (vector-length datavec))
;;;      	    #f ;; index too high, should raise an error I suppose
;;;      	    (vector-ref datavec indx))
;;;      	#f)))
;;;      
;;;      
;;;      
;;;      







;;;      












;;;      (when (args:get-arg "-testdata-csv")
;;;        (if (launch:setup)
;;;            (let* ((keys        (rmt:get-keys)) ;; (db:get-keys dbstruct))
;;;                   (runpatt     (or (args:get-arg "-runname") "%"))
;;;                   (testpatt    (common:args-get-testpatt #f))
;;;                   (datapatt    (args:get-arg "-testdata-csv"))
;;;                   (match-data  (string-match "^([^/]+)/(.*)" (args:get-arg "-testdata-csv")))
;;;                   (categorypatt (if match-data (list-ref match-data 1) "%"))
;;;                   (setvarpatt  (if match-data
;;;                                    (list-ref match-data 2)
;;;                                    (args:get-arg "-testdata-csv")))
;;;                   (runsdat     (rmt:get-runs-by-patt keys (or runpatt "%") 
;;;                                                      (common:args-get-target) #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
;;;                   (header      (db:get-header runsdat))
;;;                   (access-mode (db:get-access-mode))
;;;                   (testpatt    (common:args-get-testpatt #f))
;;;                   (fields-spec (if (args:get-arg "-fields")
;;;                                    (extract-fields-constraints (args:get-arg "-fields"))
;;;                                    (list (cons "runs" (append keys (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count")))
;;;                                          (cons "tests"  db:test-record-fields) ;; "id" "testname" "test_path")
;;;                                          (list "steps" "id" "stepname"))))
;;;                   (tests-spec  (let ((t (alist-ref "tests" fields-spec equal?)))
;;;                                  (if (and t (null? t)) ;; all fields
;;;                                      db:test-record-fields
;;;                                      t)))
;;;                   (adj-tests-spec (delete-duplicates (if tests-spec (cons "id" tests-spec) db:test-record-fields))) 
;;;                   (test-field-index (make-hash-table))
;;;                   (runs (db:get-rows runsdat))

;;;                   )
;;;              (if (and tests-spec (not (null? tests-spec))) ;; do some validation and processing of the test-spec
;;;                  (let ((invalid-tests-spec (filter (lambda (x)(not (member x db:test-record-fields))) tests-spec)))
;;;                    (if (null? invalid-tests-spec)
;;;                        ;; generate the lookup map test-field-name => index-number
;;;                        (let loop ((hed (car adj-tests-spec))
;;;                                   (tal (cdr adj-tests-spec))
;;;                                   (idx 0))
;;;                          (hash-table-set! test-field-index hed idx)
;;;                          (if (not (null? tal))(loop (car tal)(cdr tal)(+ idx 1))))
;;;                        (begin
;;;                          (debug:print-error 0 *default-log-port* "Invalid test fields specified: " (string-intersperse invalid-tests-spec ", "))
;;;                          (exit)))))
;;;              (let* ((table-header (string-split "target,run,test,itempath,category,var,value,comment" ","))
;;;                     (table-rows
;;;                      (apply append (map  
;;;                                     (lambda (run)
;;;                                       (let* ((target (string-intersperse (map (lambda (x)
;;;      							 (db:get-value-by-header run header x))
;;;      						       keys) "/"))
;;;                                              (statuses (string-split (or (args:get-arg "-status") "") ","))
;;;                                              (run-id  (db:get-value-by-header run header "id"))
;;;                                              (runname (db:get-value-by-header run header "runname")) 
;;;                                              (states  (string-split (or (args:get-arg "-state") "") ","))
;;;                                              (tests   (if tests-spec
;;;                                                           (rmt:get-tests-for-run run-id testpatt states statuses #f #f #f 'testname 'asc ;; (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc 
;;;                                                                              ;; use qryvals if test-spec provided
;;;                                                                              (if tests-spec
;;;                                                                                  (string-intersperse adj-tests-spec ",")
;;;                                                                                  ;; db:test-record-fields
;;;                                                                                  #f)
;;;                                                                              #f
;;;                                                                              'normal)
;;;                                                           '())))
;;;                                         (apply append
;;;                                                (map
;;;                                                 (lambda (test)
;;;                                                   (let* (
;;;                                                          (test-id      (if (member "id"           tests-spec)(get-value-by-fieldname test test-field-index "id"          ) #f)) ;; (db:test-get-id         test))
;;;                                                          (testname     (if (member "testname"     tests-spec)(get-value-by-fieldname test test-field-index "testname"    ) #f)) ;; (db:test-get-testname   test))
;;;                                                          (itempath     (if (member "item_path"    tests-spec)(get-value-by-fieldname test test-field-index "item_path"   ) #f)) ;; (db:test-get-item-path  test))
;;;                                                          (fullname     (conc testname
;;;                                                                              (if (equal? itempath "")
;;;                                                                                  "" 
;;;                                                                                  (conc "/" itempath ))))
;;;                                                          (testdat-raw (map vector->list (rmt:read-test-data-varpatt run-id test-id categorypatt setvarpatt)))
;;;                                                          (testdat (filter
;;;                                                                    (lambda (x)
;;;                                                                      (not (equal? "logpro"
;;;                                                                                   (list-ref x 10))))
;;;                                                                    testdat-raw)))
;;;                                                     (map 
;;;                                                      (lambda (item)
;;;                                                        (receive (id test_id category
;;;                                                                     variable value expected
;;;                                                                     tol units comment status type)
;;;                                                            (apply values item)
;;;                                                          (list target runname testname itempath category variable value comment)))
;;;                                                      testdat)))
;;;                                                 tests))))
;;;                                     runs))))
;;;                (print (string-join table-header ","))
;;;                (for-each (lambda(table-row)
;;;                            (print (string-join (map ->string table-row) ",")))
;;;      
;;;                          
;;;                                  table-rows))))
;;;        (set! *didsomething* #t)
;;;        (set! *time-to-exit* #t))
;;;      
;;;      


;;;      
;;;      ;; NOTE: list-runs and list-db-targets operate on local db!!!
;;;      ;;
;;;      ;; IDEA: megatest list -runname blah% ...
;;;      ;;
;;;      (if (or (args:get-arg "-list-runs")
;;;      	(args:get-arg "-list-db-targets"))
;;;          (if (launch:setup)
;;;      	(let* (;; (dbstruct    (make-dbr:dbstruct path: *toppath* local: (args:get-arg "-local")))
;;;      	       (runpatt     (args:get-arg "-list-runs"))
;;;                     (access-mode (db:get-access-mode))
;;;      	       (testpatt    (common:args-get-testpatt #f))
;;;      	       ;; (if (args:get-arg "-testpatt") 
;;;      	       ;;  	        (args:get-arg "-testpatt") 
;;;      	       ;;  	        "%"))
;;;      	       (keys        (rmt:get-keys)) ;; (db:get-keys dbstruct))
;;;      	       ;; (runsdat  (db:get-runs dbstruct runpatt #f #f '()))
;;;      	;; (runsdat     (rmt:get-runs-by-patt keys (or runpatt "%") (common:args-get-target) ;; (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target)
;;;      	;; 		           	 #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
;;;      	       (runsdat     (rmt:get-runs-by-patt keys (or runpatt "%") 
;;;                                                        (common:args-get-target) #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
;;;      	       (runstmp     (db:get-rows runsdat))
;;;      	       (header      (db:get-header runsdat))
;;;      	       ;; this is "-since" support. This looks at last mod times of <run-id>.db files
;;;      	       ;; and collects those modified since the -since time.
;;;      	       (runs        runstmp)
;;;                              ;; (if (and (not (null? runstmp))
;;;      			;;        (args:get-arg "-since"))
;;;      			;;   (let ((changed-ids (db:get-changed-run-ids (string->number (args:get-arg "-since")))))
;;;      			;;     (let loop ((hed (car runstmp))
;;;      			;;   	     (tal (cdr runstmp))
;;;      			;;   	     (res '()))
;;;      			;;       (let ((new-res (if (member (db:get-value-by-header hed header "id") changed-ids)
;;;      			;;   		       (cons hed res)
;;;      			;;   		       res)))
;;;      			;;         (if (null? tal)
;;;      			;;   	  (reverse new-res)
;;;      			;;   	  (loop (car tal)(cdr tal) new-res)))))
;;;      			;;   runstmp))
;;;      	       (db-targets  (args:get-arg "-list-db-targets"))
;;;      	       (seen        (make-hash-table))
;;;      	       (dmode       (let ((d (args:get-arg "-dumpmode"))) ;; json, sexpr
;;;      			      (if d (string->symbol d) #f)))
;;;      	       (data        (make-hash-table))
;;;      	       (fields-spec (if (args:get-arg "-fields")
;;;      				(extract-fields-constraints (args:get-arg "-fields"))
;;;      				(list (cons "runs" (append keys (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count")))
;;;      				      (cons "tests"  db:test-record-fields) ;; "id" "testname" "test_path")
;;;      				      (list "steps" "id" "stepname"))))
;;;      	       (runs-spec   (let ((r (alist-ref "runs"  fields-spec equal?))) ;; the check is now unnecessary
;;;      			      (if (and r (not (null? r))) r (list "id" ))))
;;;      	       (tests-spec  (let ((t (alist-ref "tests" fields-spec equal?)))
;;;      			      (if (and t (null? t)) ;; all fields
;;;      				  db:test-record-fields
;;;      				  t)))
;;;      	       (adj-tests-spec (delete-duplicates (if tests-spec (cons "id" tests-spec) db:test-record-fields))) ;; '("id"))))
;;;      	       (steps-spec  (alist-ref "steps" fields-spec equal?))
;;;      	       (test-field-index (make-hash-table)))
;;;      	  (if (and tests-spec (not (null? tests-spec))) ;; do some validation and processing of the test-spec
;;;      	      (let ((invalid-tests-spec (filter (lambda (x)(not (member x db:test-record-fields))) tests-spec)))
;;;      		(if (null? invalid-tests-spec)
;;;      		    ;; generate the lookup map test-field-name => index-number
;;;      		    (let loop ((hed (car adj-tests-spec))
;;;      			       (tal (cdr adj-tests-spec))
;;;      			       (idx 0))
;;;      		      (hash-table-set! test-field-index hed idx)
;;;      		      (if (not (null? tal))(loop (car tal)(cdr tal)(+ idx 1))))
;;;      		    (begin
;;;      		      (debug:print-error 0 *default-log-port* "Invalid test fields specified: " (string-intersperse invalid-tests-spec ", "))
;;;      		      (exit)))))
;;;      	  ;; Each run
;;;      	  (for-each 
;;;      	   (lambda (run)
;;;      	     (let ((targetstr (string-intersperse (map (lambda (x)
;;;      							 (db:get-value-by-header run header x))
;;;      						       keys) "/")))
;;;      	       (if db-targets
;;;      		   (if (not (hash-table-ref/default seen targetstr #f))
;;;      		       (begin
;;;      			 (hash-table-set! seen targetstr #t)
;;;      			 ;; (print "[" targetstr "]"))))
;;;      			 (if (not dmode)
;;;      			     (print targetstr)
;;;      			     (hash-table-set! data "targets" (cons targetstr (hash-table-ref/default data "targets" '())))
;;;      			     )))
;;;      		   (let* ((run-id  (db:get-value-by-header run header "id"))
;;;      			  (runname (db:get-value-by-header run header "runname")) 
;;;      			  (states  (string-split (or (args:get-arg "-state") "") ","))
;;;      			  (statuses (string-split (or (args:get-arg "-status") "") ","))
;;;      			  (tests   (if tests-spec
;;;      				       (rmt:get-tests-for-run run-id testpatt states statuses #f #f #f 'testname 'asc ;; (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc 
;;;      							     ;; use qryvals if test-spec provided
;;;      							     (if tests-spec
;;;      								 (string-intersperse adj-tests-spec ",")
;;;      								 ;; db:test-record-fields
;;;      								 #f)
;;;      							     #f
;;;      							     'normal)
;;;      				       '())))
;;;      		     (case dmode
;;;      		       ((json ods sexpr)
;;;      			(if runs-spec
;;;      			    (for-each 
;;;      			     (lambda (field-name)
;;;      			       (mutils:hierhash-set! data (conc (db:get-value-by-header run header field-name)) targetstr runname "meta" field-name))
;;;      			     runs-spec)))
;;;      			;; (mutils:hierhash-set! data (db:get-value-by-header run header "status")     targetstr runname "meta" "status"     )
;;;      			;; (mutils:hierhash-set! data (db:get-value-by-header run header "state")      targetstr runname "meta" "state"      )
;;;      			;; (mutils:hierhash-set! data (conc (db:get-value-by-header run header "id"))  targetstr runname "meta" "id"         )
;;;      			;; (mutils:hierhash-set! data (db:get-value-by-header run header "event_time") targetstr runname "meta" "event_time" )
;;;      			;; (mutils:hierhash-set! data (db:get-value-by-header run header "comment")    targetstr runname "meta" "comment"    )
;;;      			;; ;; add last entry twice - seems to be a bug in hierhash?
;;;      			;; (mutils:hierhash-set! data (db:get-value-by-header run header "comment")    targetstr runname "meta" "comment"    )
;;;      		       (else
;;;      			(if (null? runs-spec)
;;;      			    (print "Run: " targetstr "/" runname 
;;;      				   " status: " (db:get-value-by-header run header "state")
;;;      				   " run-id: " run-id ", number tests: " (length tests)
;;;      				   " event_time: " (db:get-value-by-header run header "event_time"))
;;;      			    (begin
;;;      			      (if (not (member "target" runs-spec))
;;;      			          ;; (display (conc "Target: " targetstr))
;;;      			          (display (conc "Run: " targetstr "/" runname " ")))
;;;      			      (for-each
;;;      			       (lambda (field-name)
;;;      				 (if (equal? field-name "target")
;;;      				     (display (conc "target: " targetstr " "))
;;;      				     (display (conc field-name ": " (db:get-value-by-header run header (conc field-name)) " "))))
;;;      			       runs-spec)
;;;      			      (newline)))))
;;;      		       
;;;      		     (for-each 
;;;      		      (lambda (test)
;;;      		      	(common:debug-handle-exceptions #f
;;;      			 exn
;;;      			 (begin
;;;      			   (debug:print-error 0 *default-log-port* "Bad data in test record? " test)
;;;      			   (debug:print-error 5 *default-log-port* "exn=" (condition->list exn))
;;;      			   (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
;;;      			   (print-call-chain (current-error-port)))
;;;      			 (let* ((test-id      (if (member "id"           tests-spec)(get-value-by-fieldname test test-field-index "id"          ) #f)) ;; (db:test-get-id         test))
;;;      				(testname     (if (member "testname"     tests-spec)(get-value-by-fieldname test test-field-index "testname"    ) #f)) ;; (db:test-get-testname   test))
;;;      				(itempath     (if (member "item_path"    tests-spec)(get-value-by-fieldname test test-field-index "item_path"   ) #f)) ;; (db:test-get-item-path  test))
;;;      				(comment      (if (member "comment"      tests-spec)(get-value-by-fieldname test test-field-index "comment"     ) #f)) ;; (db:test-get-comment    test))
;;;      				(tstate       (if (member "state"        tests-spec)(get-value-by-fieldname test test-field-index "state"       ) #f)) ;; (db:test-get-state      test))
;;;      				(tstatus      (if (member "status"       tests-spec)(get-value-by-fieldname test test-field-index "status"      ) #f)) ;; (db:test-get-status     test))
;;;      				(event-time   (if (member "event_time"   tests-spec)(get-value-by-fieldname test test-field-index "event_time"  ) #f)) ;; (db:test-get-event_time test))
;;;      				(rundir       (if (member "rundir"       tests-spec)(get-value-by-fieldname test test-field-index "rundir"      ) #f)) ;; (db:test-get-rundir     test))
;;;      				(final_logf   (if (member "final_logf"   tests-spec)(get-value-by-fieldname test test-field-index "final_logf"  ) #f)) ;; (db:test-get-final_logf test))
;;;      				(run_duration (if (member "run_duration" tests-spec)(get-value-by-fieldname test test-field-index "run_duration") #f)) ;; (db:test-get-run_duration test))
;;;      				(fullname     (conc testname
;;;      						    (if (equal? itempath "")
;;;      							"" 
;;;      							(conc "(" itempath ")")))))
;;;      			   (case dmode
;;;      			     ((json ods sexpr)
;;;      			      (if tests-spec
;;;      				  (for-each
;;;      				   (lambda (field-name)
;;;      				     (mutils:hierhash-set! data  (get-value-by-fieldname test test-field-index field-name) targetstr runname "data" (conc test-id) field-name))
;;;      				   tests-spec)))
;;;      			     ;; ;; (mutils:hierhash-set! data  fullname   targetstr runname "data" (conc test-id) "tname"     )
;;;      			     ;;  (mutils:hierhash-set! data  testname   targetstr runname "data" (conc test-id) "testname"  )
;;;      			     ;;  (mutils:hierhash-set! data  itempath   targetstr runname "data" (conc test-id) "itempath"  )
;;;      			     ;;  (mutils:hierhash-set! data  comment    targetstr runname "data" (conc test-id) "comment"   )
;;;      			     ;;  (mutils:hierhash-set! data  tstate     targetstr runname "data" (conc test-id) "state"     )
;;;      			     ;;  (mutils:hierhash-set! data  tstatus    targetstr runname "data" (conc test-id) "status"    )
;;;      			     ;;  (mutils:hierhash-set! data  rundir     targetstr runname "data" (conc test-id) "rundir"    )
;;;      			     ;;  (mutils:hierhash-set! data  final_logf targetstr runname "data" (conc test-id) "final_logf")
;;;      			     ;;  (mutils:hierhash-set! data  run_duration targetstr runname "data" (conc test-id) "run_duration")
;;;      			     ;;  (mutils:hierhash-set! data  event-time targetstr runname "data" (conc test-id) "event_time")
;;;      			     ;;  ;; add last entry twice - seems to be a bug in hierhash?
;;;      			     ;;  (mutils:hierhash-set! data  event-time targetstr runname "data" (conc test-id) "event_time")
;;;      			     ;;  )
;;;      			     (else
;;;      			      (if (and tstate tstatus event-time)
;;;      				  (format #t
;;;      					  "  Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n"
;;;      					  (if fullname fullname "")
;;;      					  (if tstate   tstate   "")
;;;      					  (if tstatus  tstatus  "")
;;;      					  (get-value-by-fieldname test test-field-index "run_duration");;(if test     (db:test-get-run_duration test) "")
;;;      					  (if event-time event-time "")
;;;      					  (get-value-by-fieldname test test-field-index "host")) ;;(if test (db:test-get-host test)) "")
;;;      				  (print "  Test: " fullname
;;;      					 (if tstate  (conc " State: "  tstate)  "")
;;;      					 (if tstatus (conc " Status: " tstatus) "")
;;;      					 (if (get-value-by-fieldname test test-field-index "run_duration")
;;;      					     (conc " Runtime: " (get-value-by-fieldname test test-field-index "run_duration"))
;;;      					     "")
;;;      					 (if event-time (conc " Time: " event-time) "")
;;;      					 (if (get-value-by-fieldname test test-field-index "host")
;;;      					     (conc " Host: " (get-value-by-fieldname test test-field-index "host"))
;;;      					     "")))
;;;      			      (if (not (or (equal? (get-value-by-fieldname test test-field-index "status") "PASS")
;;;      					   (equal? (get-value-by-fieldname test test-field-index "status") "WARN")
;;;      					   (equal? (get-value-by-fieldname test test-field-index "state")  "NOT_STARTED")))
;;;      				  (begin
;;;      				    (print   (if (get-value-by-fieldname test test-field-index "cpuload")
;;;      						 (conc "         cpuload:  "   (get-value-by-fieldname test test-field-index "cpuload"))
;;;      						 "") ;; (db:test-get-cpuload test)
;;;      					     (if (get-value-by-fieldname test test-field-index "diskfree")
;;;      						 (conc "\n         diskfree: " (get-value-by-fieldname test test-field-index "diskfree")) ;; (db:test-get-diskfree test)
;;;      						 "")
;;;      					     (if (get-value-by-fieldname test test-field-index "uname")
;;;      						 (conc "\n         uname:    " (get-value-by-fieldname test test-field-index "uname")) ;; (db:test-get-uname test)
;;;      						 "")
;;;      					     (if (get-value-by-fieldname test test-field-index "rundir")
;;;      						 (conc "\n         rundir:   " (get-value-by-fieldname test test-field-index "rundir")) ;; (db:test-get-rundir test)
;;;      						 "")
;;;      ;;					     "\n         rundir:   " (get-value-by-fieldname test test-field-index "") ;; (sdb:qry 'getstr ;; (filedb:get-path *fdb* 
;;;      ;; 					     (db:test-get-rundir test) ;; )

;;;      					     )
;;;      				    ;; Each test
;;;      				    ;; DO NOT remote run
;;;      				    (let ((steps (rmt:get-steps-for-test run-id (db:test-get-id test)))) ;; (db:get-steps-for-test dbstruct run-id (db:test-get-id test))))
;;;      				      (for-each 
;;;      				       (lambda (step)
;;;      					 (format #t 
;;;      						 "    Step: ~20a State: ~10a Status: ~10a Time ~22a\n"
;;;      						 (tdb:step-get-stepname step)
;;;      						 (tdb:step-get-state step)
;;;      						 (tdb:step-get-status step)
;;;      						 (tdb:step-get-event_time step)))
;;;      				       steps)))))))))
;;;      		      (if (args:get-arg "-sort")
;;;      			  (sort tests
;;;      				(lambda (a-test b-test)
;;;      				  (let* ((key    (args:get-arg "-sort"))
;;;      					 (first  (get-value-by-fieldname a-test test-field-index key))
;;;      					 (second (get-value-by-fieldname b-test test-field-index key)))
;;;      				    ((cond 
;;;      				      ((and (number? first)(number? second)) <)
;;;      				      ((and (string? first)(string? second)) string<=?)
;;;      				      (else equal?))
;;;      				     first second))))
;;;      			  tests))))))
;;;      	   runs)
;;;      	  (case dmode
;;;      	    ((json)  (json-write data))
;;;      	    ((sexpr) (pp (common:to-alist data))))
;;;      	  (let* ((metadat-fields (delete-duplicates
;;;      				  (append keys '( "runname" "time" "owner" "pass_count" "fail_count" "state" "status" "comment" "id"))))
;;;      		 (run-fields    '(
;;;      				  "testname"
;;;      				  "item_path"
;;;      				  "state"
;;;      				  "status"
;;;      				  "comment"
;;;      				  "event_time"
;;;      				  "host"
;;;      				  "run_id"
;;;      				  "run_duration"
;;;      				  "attemptnum"
;;;      				  "id"
;;;      				  "archived"
;;;      				  "diskfree"
;;;      				  "cpuload"
;;;      				  "final_logf"
;;;      				  "shortdir"
;;;      				  "rundir"
;;;      				  "uname"


;;;      				  )
;;;      				)
;;;      		 (newdat          (common:to-alist data))
;;;      		 (allrundat       (if (null? newdat)
;;;      				      '()
;;;      				      (car (map cdr newdat)))) ;; (car (map cdr (car (map cdr newdat)))))
;;;      		 (runs            (append
;;;      				   (list "runs" ;; sheetname
;;;      					 metadat-fields)
;;;      				   (map (lambda (run)
;;;      					  ;; (print "run: " run)
;;;      					  (let* ((runname (car run))
;;;      						 (rundat  (cdr run))
;;;      						 (metadat (let ((tmp (assoc "meta" rundat)))
;;;      							    (if tmp (cdr tmp) #f))))
;;;      					    ;; (print "runname: " runname "\n\nrundat: " )(pp rundat)(print "\n\nmetadat: ")(pp metadat)
;;;      					    (if metadat
;;;      						(map (lambda (field)
;;;      						       (let ((tmp (assoc field metadat)))
;;;      							 (if tmp (cdr tmp) "")))
;;;      						     metadat-fields)
;;;      						(begin
;;;      						  (debug:print 0 *default-log-port* "WARNING: meta data for run " runname " not found")
;;;      						  '()))))
;;;      					allrundat)))
;;;      		 ;; '( ( "target" ( "runname" ( "data" ( "runid" ( "id . "37" ) ( ... ))))
;;;      		 (run-pages      (map (lambda (targdat)
;;;      					(let* ((target  (car targdat))
;;;      					       (runsdat (cdr targdat)))
;;;      					  (if runsdat
;;;      					      (map (lambda (rundat)
;;;      						     (let* ((runname  (car rundat))
;;;      							    (rundat   (cdr rundat))
;;;      							    (testsdat (let ((tmp (assoc "data" rundat)))
;;;      									(if tmp (cdr tmp) #f))))
;;;      						       (if testsdat
;;;      							   (let ((tests (map (lambda (test)
;;;      									       (let* ((test-id  (car test))
;;;      										      (test-dat (cdr test)))
;;;      										 (map (lambda (field)
;;;      											(let ((tmp (assoc field test-dat)))
;;;      											  (if tmp (cdr tmp) "")))
;;;      										      run-fields)))
;;;      									     testsdat)))
;;;      							     ;; (print "Target: " target "/" runname " tests:")
;;;      							     ;; (pp tests)
;;;      							     (cons (conc target "/" runname)
;;;      								   (cons (list (conc target "/" runname))
;;;      									 (cons '()
;;;      									       (cons run-fields tests)))))
;;;      							   (begin
;;;      							     (debug:print 4 *default-log-port* "WARNING: run " target "/" runname " appears to have no data")
;;;      							     ;; (pp rundat)
;;;      							     '()))))
;;;      						   runsdat)
;;;      					      '())))
;;;      				      newdat)) ;; we use newdat to get target
;;;      		 (sheets         (filter (lambda (x)
;;;      					   (not (null? x)))
;;;      					 (cons runs (map car run-pages)))))
;;;      	    ;; (print "allrundat:")
;;;      	    ;; (pp allrundat)
;;;      	    ;; (print "runs:")
;;;      	    ;; (pp runs)
;;;      	    ;(print "sheets: ")
;;;      	    ;; (pp sheets)
;;;      	    (if (eq? dmode 'ods)
;;;      		(let* ((tempdir    (conc "/tmp/" (current-user-name) "/" (pseudo-random-integer 10000) "_" (current-process-id)))
;;;      		       (outputfile (or (args:get-arg "-o") "out.ods"))
;;;      		       (ouf        (if (string-match (regexp "^[/~]+.*") outputfile) ;; full path?
;;;      				       outputfile
;;;      				       (begin
;;;      					 (debug:print 0 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory")
;;;      					 (conc (current-directory) "/" outputfile)))))
;;;      		  (create-directory tempdir #t)
;;;      		  (ods:list->ods tempdir ouf sheets))))
;;;      	  ;; (system (conc "rm -rf " tempdir))
;;;      	  (set! *didsomething* #t)
;;;                (set! *time-to-exit* #t)
;;;                ) ;; end if true branch (end of a let)
;;;              ) ;; end if
;;;          ) ;; end if -list-runs
;;;      
;;;      ;; list-waivers
;;;      (if (and (args:get-arg "-list-waivers")
;;;      	 (launch:setup))
;;;          (let* ((runpatt     (or (args:get-arg "-runname") "%"))
;;;      	   (testpatt    (common:args-get-testpatt #f))
;;;      	   (keys        (rmt:get-keys)) 
;;;      	   (runsdat     (rmt:get-runs-by-patt
;;;      			 keys runpatt 
;;;      			 (common:args-get-target) #f #f
;;;      			 '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
;;;      	   (runs        (db:get-rows runsdat))
;;;      	   (header      (db:get-header runsdat))
;;;      	   (results     (make-hash-table))  ;; [target] ( (testname/itempath . "comment") ... )
;;;      	   (addtest     (lambda (target testname itempath comment)
;;;      			  (hash-table-set! results target (cons (cons (conc testname "/" itempath) comment)
;;;      								(hash-table-ref/default results target '())))))
;;;      	   (last-target #f))
;;;            (for-each
;;;             (lambda (run)
;;;      	 (let* ((run-id  (db:get-value-by-header run header "id"))
;;;      		(target  (rmt:get-target run-id))
;;;      		(runname (db:get-value-by-header run header "runname")) 
;;;      		(tests   (rmt:get-tests-for-run
;;;      			  run-id testpatt '("COMPLETED") '("WAIVED") #f #f #f 'testname 'asc							     ;; use qryvals if test-spec provided
;;;      			  #f #f #f)))
;;;      	   (if (not (equal? target last-target))
;;;      	       (print "[" target "]"))
;;;      	   (set! last-target target)
;;;      	   (print "# " runname)
;;;      	   (for-each
;;;      	    (lambda (testdat)
;;;      	      (let* ((testfullname (conc (db:test-get-testname testdat)
;;;      					 (if (equal? "" (db:test-get-item-path testdat))
;;;      					     ""
;;;      					     (conc "/" (db:test-get-item-path testdat)))
;;;      					 )))
;;;      	      (print testfullname " " (db:test-get-comment testdat))))
;;;      	    tests)))
;;;             runs)
;;;            (set! *didsomething* #t)))
;;;            
;;;      ;;======================================================================
;;;      ;; full run
;;;      ;;======================================================================
;;;      
;;;      (define (handle-run-requests target runname keys keyvals need-clean)	 
;;;        (if (or (args:get-arg "-kill-rerun") (args:get-arg "-rerun-clean")) ;; first set states/statuses correct
;;;            ;; For rerun-clean do we or do we not support the testpatt?
;;;            (let ((states   (or (configf:lookup *configdat* "validvalues" "cleanrerun-states")
;;;      			  "KILLREQ,KILLED,UNKNOWN,INCOMPLETE,STUCK,NOT_STARTED"))
;;;      	    (statuses (or (configf:lookup *configdat* "validvalues" "cleanrerun-statuses")
;;;      			  "FAIL,INCOMPLETE,ABORT,CHECK,DEAD,PREQ_FAIL,PREQ_DISCARDED")))
;;;      	(hash-table-set! args:arg-hash "-preclean" #t)
;;;      	(runs:operate-on 'set-state-status
;;;      			 target
;;;      			 (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
;;;      			 ;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
;;;      			 (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
;;;      			 state:  states
;;;      			 ;; status: statuses
;;;      			 new-state-status: "NOT_STARTED,n/a")
;;;      	(runs:clean-cache target runname *toppath*)
;;;      	(runs:operate-on 'set-state-status
;;;      			 target
;;;      			 (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
;;;      			 ;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
;;;      			 (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
;;;      			 ;; state:  states
;;;      			 status: statuses
;;;      			 new-state-status: "NOT_STARTED,n/a")))
;;;        ;; RERUN ALL
;;;        (if (args:get-arg "-rerun-all") ;; first set states/statuses correct
;;;            (let* ((rconfig (full-runconfigs-read)))
;;;      	(hash-table-set! args:arg-hash "-preclean" #t)
;;;      	(runs:operate-on 'set-state-status
;;;      			 target
;;;      			 (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
;;;      			 (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt")
;;;      			 state:  #f
;;;      			 ;; status: statuses
;;;      			 new-state-status: "NOT_STARTED,n/a")
;;;      	(runs:clean-cache target runname *toppath*)
;;;      	(runs:operate-on 'set-state-status
;;;      			 target
;;;      			 (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
;;;      			 (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt")
;;;      			 ;; state:  states
;;;      			 status: #f
;;;      			 new-state-status: "NOT_STARTED,n/a")))
;;;        (let* ((config-reruns      (let ((x (configf:lookup *configdat* "setup" "reruns")))
;;;      			       (if x (string->number x) #f)))
;;;      	 (rerun-cnt (if config-reruns
;;;      			config-reruns
;;;      			1)))
;;;      
;;;          (runs:run-tests target
;;;      		    runname
;;;      		    #f ;; (common:args-get-testpatt #f)
;;;      		    ;; (or (args:get-arg "-testpatt")
;;;      		    ;;     "%")
;;;      		    user
;;;      		    args:arg-hash
;;;      		    run-count: rerun-cnt)))
;;;      
;;;      ;; get lock in db for full run for this directory
;;;      ;; for all tests with deps
;;;      ;;   walk tree of tests to find head tasks
;;;      ;;   add head tasks to task queue
;;;      ;;   add dependant tasks to task queue 
;;;      ;;   add remaining tasks to task queue
;;;      ;; for each task in task queue
;;;      ;;   if have adequate resources
;;;      ;;     launch task
;;;      ;;   else
;;;      ;;     put task in deferred queue
;;;      ;; if still ok to run tasks
;;;      ;;   process deferred tasks per above steps
;;;      
;;;      ;; run all tests are are Not COMPLETED and PASS or CHECK
;;;      (if (or (args:get-arg "-runall")
;;;      	(args:get-arg "-run")
;;;      	(args:get-arg "-rerun-clean")
;;;      	(args:get-arg "-rerun-all")
;;;      	(args:get-arg "-runtests")
;;;              (args:get-arg "-kill-rerun"))
;;;          (let ((need-clean (or (args:get-arg "-rerun-clean")
;;;                                (args:get-arg "-rerun-all")))
;;;      	  (orig-cmdline (string-intersperse (argv) " ")))
;;;            (general-run-call 
;;;             "-runall"
;;;             "run all tests"
;;;             (lambda (target runname keys keyvals)
;;;      	 (if (or (string-search "%" target)
;;;      		 (string-search "%" runname)) ;; we are being asked to re-run multiple runs
;;;      	     (let* ((run-specs (rmt:simple-get-runs runname #f #f target #f))) ;; list of simple-run records
;;;      	       (debug:print-info 0 *default-log-port* "Pattern supplied for target or runname with "
;;;      				 (length run-specs) " matches round. Running each in turn.")
;;;      	       (if (null? run-specs)
;;;      		   (debug:print 0 *default-log-port* "WARNING: No runs match target " target " and runname " runname))
;;;      	       (for-each (lambda (spec) 
;;;      			   (let* ((precmd     (if (args:get-arg "-precmd")(conc (args:get-arg "-precmd") " ") ""))
;;;      				  (newcmdline (conc
;;;      					       precmd
;;;      					       (string-substitute
;;;      						(conc "target " target)
;;;      						(conc "target " (simple-run-target spec))
;;;      						(string-substitute
;;;      						 (conc "runname " runname)
;;;      						 (conc "runname " (simple-run-runname spec))
;;;      						 orig-cmdline)))))
;;;      			     (debug:print 0 *default-log-port* "ORIG: " orig-cmdline)
;;;      			     (debug:print 0 *default-log-port* "NEW:  " newcmdline)
;;;      			     (system newcmdline)))
;;;      			 run-specs))
;;;      	     (handle-run-requests target runname keys keyvals need-clean))))))
;;;      
;;;      ;;======================================================================
;;;      ;; run one test
;;;      ;;======================================================================
;;;      
;;;      ;; 1. find the config file
;;;      ;; 2. change to the test directory
;;;      ;; 3. update the db with "test started" status, set running host
;;;      ;; 4. process launch the test
;;;      ;;    - monitor the process, update stats in the db every 2^n minutes
;;;      ;; 5. as the test proceeds internally it calls megatest as each step is
;;;      ;;    started and completed
;;;      ;;    - step started, timestamp
;;;      ;;    - step completed, exit status, timestamp
;;;      ;; 6. test phone home
;;;      ;;    - if test run time > allowed run time then kill job
;;;      ;;    - if cannot access db > allowed disconnect time then kill job
;;;      
;;;      ;; == duplicated == (if (or (args:get-arg "-run")(args:get-arg "-runtests"))
;;;      ;; == duplicated ==   (general-run-call 
;;;      ;; == duplicated ==    "-runtests" 
;;;      ;; == duplicated ==    "run a test" 
;;;      ;; == duplicated ==    (lambda (target runname keys keyvals)
;;;      ;; == duplicated ==      ;;
;;;      ;; == duplicated ==      ;; May or may not implement it this way ...
;;;      ;; == duplicated ==      ;;
;;;      ;; == duplicated ==      ;; Insert this run into the tasks queue
;;;      ;; == duplicated ==      ;; (open-run-close tasks:add tasks:open-db 
;;;      ;; == duplicated ==      ;;    	     "runtests" 
;;;      ;; == duplicated ==      ;;    	     user
;;;      ;; == duplicated ==      ;;    	     target
;;;      ;; == duplicated ==      ;;    	     runname
;;;      ;; == duplicated ==      ;;    	     (args:get-arg "-runtests")
;;;      ;; == duplicated ==      ;;    	     #f))))
;;;      ;; == duplicated ==      (runs:run-tests target
;;;      ;; == duplicated == 		     runname
;;;      ;; == duplicated == 		     (common:args-get-testpatt #f) ;; (args:get-arg "-runtests")
;;;      ;; == duplicated == 		     user
;;;      ;; == duplicated == 		     args:arg-hash))))
;;;      
;;;      ;;======================================================================
;;;      ;; Rollup into a run
;;;      ;;======================================================================
;;;      
;;;      ;; (if (args:get-arg "-rollup")
;;;      ;;     (general-run-call 
;;;      ;;      "-rollup" 
;;;      ;;      "rollup tests" 
;;;      ;;      (lambda (target runname keys keyvals)
;;;      ;;        (runs:rollup-run keys
;;;      ;; 			keyvals
;;;      ;; 			(or (args:get-arg "-runname")(args:get-arg ":runname") )
;;;      ;; 			user))))
;;;      
;;;      ;;======================================================================
;;;      ;; Lock or unlock a run
;;;      ;;======================================================================
;;;      
;;;      (if (or (args:get-arg "-lock")(args:get-arg "-unlock"))
;;;          (general-run-call 
;;;           (if (args:get-arg "-lock") "-lock" "-unlock")
;;;           "lock/unlock tests" 
;;;           (lambda (target runname keys keyvals)
;;;             (runs:handle-locking 
;;;      		  target
;;;      		  keys
;;;      		  (or (args:get-arg "-runname")(args:get-arg ":runname") )
;;;      		  (args:get-arg "-lock")
;;;      		  (args:get-arg "-unlock")
;;;      		  user))))
;;;      
;;;      ;;======================================================================
;;;      ;; Get paths to tests
;;;      ;;======================================================================
;;;      ;; Get test paths matching target, runname, and testpatt
;;;      (if (or (args:get-arg "-test-files")(args:get-arg "-test-paths"))
;;;          ;; if we are in a test use the MT_CMDINFO data
;;;          (if (getenv "MT_CMDINFO")
;;;      	(let* ((startingdir (current-directory))
;;;      	       (cmdinfo   (common:read-encoded-string (getenv "MT_CMDINFO")))
;;;      	       (transport (assoc/default 'transport cmdinfo))
;;;      	       (testpath  (assoc/default 'testpath  cmdinfo))
;;;      	       (test-name (assoc/default 'test-name cmdinfo))
;;;      	       (runscript (assoc/default 'runscript cmdinfo))
;;;      	       (db-host   (assoc/default 'db-host   cmdinfo))
;;;      	       (run-id    (assoc/default 'run-id    cmdinfo))
;;;      	       (itemdat   (assoc/default 'itemdat   cmdinfo))
;;;      	       (state     (args:get-arg ":state"))
;;;      	       (status    (args:get-arg ":status"))
;;;      	       ;;(target    (args:get-arg "-target"))
;;;      	       (target    (common:args-get-target))
;;;      	       (toppath   (assoc/default 'toppath   cmdinfo)))
;;;      	  (change-directory toppath)
;;;      	  (if (not target)
;;;      	      (begin
;;;      		(debug:print-error 0 *default-log-port* "-target is required.")
;;;      		(exit 1)))
;;;      	  (if (not (launch:setup))
;;;      	      (begin
;;;      		(debug:print 0 *default-log-port* "Failed to setup, giving up on -test-paths or -test-files, exiting")
;;;      		(exit 1)))
;;;      	  (let* ((keys     (rmt:get-keys))
;;;      		 ;; db:test-get-paths must not be run remote
;;;      		 (paths    (tests:test-get-paths-matching keys target (args:get-arg "-test-files"))))
;;;      	    (set! *didsomething* #t)
;;;      	    (for-each (lambda (path)
;;;      			(if (common:file-exists? path)
;;;      			(print path)))	
;;;      		      paths)))
;;;      	;; else do a general-run-call
;;;      	(general-run-call 
;;;      	 "-test-files"
;;;      	 "Get paths to test"
;;;      	 (lambda (target runname keys keyvals)
;;;      	   (let* ((db       #f)
;;;      		  ;; DO NOT run remote
;;;      		  (paths    (tests:test-get-paths-matching keys target (args:get-arg "-test-files"))))
;;;      	     (for-each (lambda (path)
;;;      			 (print path))
;;;      		       paths))))))
;;;      
;;;      ;;======================================================================
;;;      ;; Archive tests
;;;      ;;======================================================================
;;;      ;; Archive tests matching target, runname, and testpatt
;;;      (if (equal? (args:get-arg "-archive") "replicate-db")
;;;          (begin
;;;                ;; check if source
;;;                ;; check if megatest.db exist
;;;               (launch:setup)
;;;               (if (not (args:get-arg "-source"))
;;;                   (begin 
;;;                   (debug:print-info 1 *default-log-port* "Missing required argument -source <archive path>")
;;;                   (exit 1)))
;;;               (if (common:file-exists? (conc  *toppath* "/megatest.db"))
;;;                   (begin  
;;;                     (debug:print-info 1 *default-log-port* "File " (conc  *toppath* "/megatest.db") " already exists. Please remove it before trying to replicate db")
;;;                     (exit 1)))
;;;               (if (and (common:get-db-tmp-area) (> (length (directory   (common:get-db-tmp-area) #f)) 0))
;;;                 (begin
;;;                 (debug:print-info 1 *default-log-port* (common:get-db-tmp-area) " not empty. Please remove it before trying to replicate db")
;;;                 (exit 1)))    
;;;                ;; check if timestamp 
;;;                (let* ((source (args:get-arg "-source"))
;;;                      (src     (if (not (equal? (substring source 0 1) "/"))
;;;                                   (conc (current-directory) "/" source)
;;;                                   source))
;;;                      (ts (if (args:get-arg "-time-stamp")   (args:get-arg "-time-stamp") "latest")))
;;;                    (if  (common:directory-exists? src)
;;;                        (begin 
;;;                        (archive:restore-db src ts)
;;;                  (set! *didsomething* #t))
;;;             (begin
;;;               (debug:print-error 1 *default-log-port* "Path " source " not found")
;;;               (exit 1))))))   
;;;          ;; else do a general-run-call
;;;         (if (and (args:get-arg "-archive") (not (equal? (args:get-arg "-archive") "replicate-db"))) 
;;;          (begin
;;;            ;; for the archive get we need to preserve the starting dir as part of the target path
;;;            (if (and (args:get-arg "-dest")
;;;      	       (not (equal? (substring (args:get-arg "-dest") 0 1) "/")))
;;;      	  (let ((newpath  (conc (current-directory) "/" (args:get-arg "-dest"))))
;;;      	    (debug:print-info 1 *default-log-port* "Preserving original path to destination, was " (args:get-arg "-dest") ", now " newpath)
;;;      	    (hash-table-set! args:arg-hash "-dest" newpath)))
;;;            (general-run-call 
;;;             "-archive"
;;;             "Archive"
;;;             (lambda (target runname keys keyvals)
;;;      	 (operate-on 'archive target-in: target runname-in: runname )))))
;;;      
;;;      ;;======================================================================
;;;      ;; Extract a spreadsheet from the runs database
;;;      ;;======================================================================
;;;      
;;;      (if (args:get-arg "-extract-ods")
;;;          (general-run-call
;;;           "-extract-ods"
;;;           "Make ods spreadsheet"
;;;           (lambda (target runname keys keyvals)
;;;             (let ((dbstruct   (make-dbr:dbstruct path: *toppath* local: #t))
;;;      	     (outputfile (args:get-arg "-extract-ods"))
;;;      	     (runspatt   (or (args:get-arg "-runname")(args:get-arg ":runname")))
;;;      	     (pathmod    (args:get-arg "-pathmod")))
;;;      	     ;; (keyvalalist (keys->alist keys "%")))
;;;      	 (debug:print 2 *default-log-port* "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvals: " keyvals)
;;;      	 (db:extract-ods-file dbstruct outputfile keyvals (if runspatt runspatt "%") pathmod)
;;;      	 (db:close-all dbstruct)
;;;      	 (set! *didsomething* #t)))))
;;;      
;;;      ;;======================================================================
;;;      ;; execute the test
;;;      ;;    - gets called on remote host
;;;      ;;    - receives info from the -execute param
;;;      ;;    - passes info to steps via MT_CMDINFO env var (future is to use a dot file)
;;;      ;;    - gathers host info and 
;;;      ;;======================================================================
;;;      
;;;      (if (args:get-arg "-execute")
;;;          (begin
;;;            (launch:execute (args:get-arg "-execute"))
;;;            (set! *didsomething* #t)))
;;;      
;;;      ;;======================================================================
;;;      ;; recover from a test where the managing mtest was killed but the underlying
;;;      ;; process might still be salvageable
;;;      ;;======================================================================
;;;      
;;;      (if (args:get-arg "-recover-test")
;;;          (let* ((params (string-split (args:get-arg "-recover-test") ",")))
;;;            (if (> (length params) 1) ;; run-id and test-id
;;;      	  (let ((run-id (string->number (car params)))
;;;      		(test-id (string->number (cadr params))))
;;;      	    (if (and run-id test-id)
;;;      		(begin
;;;      		  (launch:recover-test run-id test-id)
;;;      		  (set! *didsomething* #t))
;;;      		(begin
;;;      		  (debug:print-error 0 *default-log-port* "bad run-id or test-id, must be integers")
;;;      		  (exit 1)))))))
;;;      
;;;      ;;======================================================================
;;;      ;; Test commands (i.e. for use inside tests)
;;;      ;;======================================================================
;;;      
;;;      (define (megatest:step step state status logfile msg)
;;;        (if (not (getenv "MT_CMDINFO"))
;;;            (begin
;;;      	(debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!")
;;;      	(exit 5))
;;;            (let* ((cmdinfo   (common:read-encoded-string (getenv "MT_CMDINFO")))
;;;      	     (transport (assoc/default 'transport cmdinfo))
;;;      	     (testpath  (assoc/default 'testpath  cmdinfo))
;;;      	     (test-name (assoc/default 'test-name cmdinfo))
;;;      	     (runscript (assoc/default 'runscript cmdinfo))
;;;      	     (db-host   (assoc/default 'db-host   cmdinfo))
;;;      	     (run-id    (assoc/default 'run-id    cmdinfo))
;;;      	     (test-id   (assoc/default 'test-id   cmdinfo))
;;;      	     (itemdat   (assoc/default 'itemdat   cmdinfo))
;;;      	     (work-area (assoc/default 'work-area cmdinfo))
;;;      	     (db        #f))
;;;      	(change-directory testpath)
;;;      	(if (not (launch:setup))
;;;      	    (begin
;;;      	      (debug:print 0 *default-log-port* "Failed to setup, exiting")
;;;      	      (exit 1)))
;;;      	(if (and state status)
;;;      	    (let ((comment (launch:load-logpro-dat run-id test-id step)))
;;;      	      ;; (rmt:test-set-log! run-id test-id (conc stepname ".html"))))
;;;      	      (rmt:teststep-set-status! run-id test-id step state status (or comment msg) logfile))
;;;      	    (begin
;;;      	      (debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -step")
;;;      	      (exit 6))))))
;;;      
;;;      (define (main)
;;;      (if (args:get-arg "-step")
;;;          (begin
;;;            (thread-sleep! 1.5)
;;;            (megatest:step 
;;;             (args:get-arg "-step")
;;;             (or (args:get-arg "-state")(args:get-arg ":state"))
;;;             (or (args:get-arg "-status")(args:get-arg ":status"))
;;;             (args:get-arg "-setlog")
;;;             (args:get-arg "-m"))
;;;            ;; (if db (sqlite3:finalize! db))
;;;            (set! *didsomething* #t)
;;;            (thread-sleep! 1.5)))
;;;          
;;;      (if (or (args:get-arg "-setlog")       ;; since setting up is so costly lets piggyback on -test-status
;;;      	;;     (not (args:get-arg "-step")))  ;; -setlog may have been processed already in the "-step" previous
;;;      	;;     NEW POLICY - -setlog sets test overall log on every call.
;;;      	(args:get-arg "-set-toplog")
;;;      	(args:get-arg "-test-status")
;;;      	(args:get-arg "-set-values")
;;;      	(args:get-arg "-load-test-data")
;;;      	(args:get-arg "-runstep")
;;;      	(args:get-arg "-summarize-items"))
;;;          (if (not (getenv "MT_CMDINFO"))
;;;      	(begin
;;;      	  (debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!")
;;;      	  (exit 5))
;;;      	(let* ((startingdir (current-directory))
;;;      	       (cmdinfo   (common:read-encoded-string (getenv "MT_CMDINFO")))
;;;      	       (transport (assoc/default 'transport cmdinfo))
;;;      	       (testpath  (assoc/default 'testpath  cmdinfo))
;;;      	       (test-name (assoc/default 'test-name cmdinfo))
;;;      	       (runscript (assoc/default 'runscript cmdinfo))
;;;      	       (db-host   (assoc/default 'db-host   cmdinfo))
;;;      	       (run-id    (assoc/default 'run-id    cmdinfo))
;;;      	       (test-id   (assoc/default 'test-id   cmdinfo))
;;;      	       (itemdat   (assoc/default 'itemdat   cmdinfo))
;;;      	       (work-area (assoc/default 'work-area cmdinfo))
;;;      	       (db        #f) ;; (open-db))
;;;      	       (state     (args:get-arg ":state"))
;;;      	       (status    (args:get-arg ":status"))
;;;      	       (stepname  (args:get-arg "-step")))
;;;      	  (if (not (launch:setup))
;;;      	      (begin
;;;      		(debug:print 0 *default-log-port* "Failed to setup, exiting")
;;;      		(exit 1)))
;;;      
;;;      	  (if (args:get-arg "-runstep")(debug:print-info 1 *default-log-port* "Running -runstep, first change to directory " work-area))
;;;      	  (change-directory work-area)
;;;      	  ;; can setup as client for server mode now
;;;      	  ;; (client:setup)
;;;      
;;;      	  (if (args:get-arg "-load-test-data")
;;;      	      ;; has sub commands that are rdb:
;;;      	      ;; DO NOT put this one into either rmt: or open-run-close
;;;      	      (tdb:load-test-data run-id test-id))
;;;      	  (if (args:get-arg "-setlog")
;;;      	      (let ((logfname (args:get-arg "-setlog")))
;;;      		(rmt:test-set-log! run-id test-id logfname)))
;;;      	  (if (args:get-arg "-set-toplog")
;;;      	      ;; DO NOT run remote
;;;      	      (tests:test-set-toplog! run-id test-name (args:get-arg "-set-toplog")))
;;;      	  (if (args:get-arg "-summarize-items")
;;;      	      ;; DO NOT run remote
;;;      	      (tests:summarize-items run-id test-id test-name #t)) ;; do force here
;;;      	  (if (args:get-arg "-runstep")
;;;      	      (if (null? remargs)
;;;      		  (begin
;;;      		    (debug:print-error 0 *default-log-port* "nothing specified to run!")
;;;      		    (if db (sqlite3:finalize! db))
;;;      		    (exit 6))
;;;      		  (let* ((stepname   (args:get-arg "-runstep"))
;;;      			 (logprofile (args:get-arg "-logpro"))
;;;      			 (logfile    (conc stepname ".log"))
;;;      			 (cmd        (if (null? remargs) #f (car remargs)))
;;;      			 (params     (if cmd (cdr remargs) '()))
;;;      			 (exitstat   #f)
;;;      			 (shell      (let ((sh (get-environment-variable "SHELL") ))
;;;      				       (if sh 
;;;      					   (last (string-split sh "/"))
;;;      					   "bash")))
;;;      			 (redir      (case (string->symbol shell)
;;;      				       ((tcsh csh ksh)    ">&")
;;;      				       ((zsh bash sh ash) "2>&1 >")
;;;      				       (else ">&")))
;;;      			 (fullcmd    (conc "(" (string-intersperse 
;;;      						(cons cmd params) " ")
;;;      					   ") " redir " " logfile)))
;;;      		    ;; mark the start of the test
;;;      		    (rmt:teststep-set-status! run-id test-id stepname "start" "n/a" (args:get-arg "-m") logfile)
;;;      		    ;; run the test step
;;;      		    (debug:print-info 2 *default-log-port* "Running \"" fullcmd "\" in directory \"" startingdir)
;;;      		    (change-directory startingdir)
;;;      		    (set! exitstat (system fullcmd))
;;;      		    (set! *globalexitstatus* exitstat)
;;;      		    ;; (change-directory testpath)
;;;      		    ;; run logpro if applicable ;; (process-run "ls" (list "/foo" "2>&1" "blah.log"))
;;;      		    (if logprofile
;;;      			(let* ((htmllogfile (conc stepname ".html"))
;;;      			       (oldexitstat exitstat)
;;;      			       (cmd         (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " ")))
;;;      			  (debug:print-info 2 *default-log-port* "running \"" cmd "\"")
;;;      			  (change-directory startingdir)
;;;      			  (set! exitstat (system cmd))
;;;      			  (set! *globalexitstatus* exitstat) ;; no necessary
;;;      			  (change-directory testpath)
;;;      			  (rmt:test-set-log! run-id test-id htmllogfile)))
;;;      		    (let ((msg (args:get-arg "-m")))
;;;      		      (rmt:teststep-set-status! run-id test-id stepname "end" exitstat msg logfile))
;;;      		    )))
;;;      	  (if (or (args:get-arg "-test-status")
;;;      		  (args:get-arg "-set-values"))
;;;      	      (let ((newstatus (cond
;;;      				((number? status)       (if (equal? status 0) "PASS" "FAIL"))
;;;      				((and (string? status)
;;;      				      (string->number status))(if (equal? (string->number status) 0) "PASS" "FAIL"))
;;;      				(else status)))
;;;      		    ;; transfer relevant keys into a hash to be passed to test-set-status!
;;;      		    ;; could use an assoc list I guess. 
;;;      		    (otherdata (let ((res (make-hash-table)))
;;;      				 (for-each (lambda (key)
;;;      					     (if (args:get-arg key)
;;;      						 (hash-table-set! res key (args:get-arg key))))
;;;      					   (list ":value" ":tol" ":expected" ":first_err" ":first_warn" ":units" ":category" ":variable"))
;;;      				 res)))
;;;      		(if (and (args:get-arg "-test-status")
;;;      			 (or (not state)
;;;      			     (not status)))
;;;      		    (begin
;;;      		      (debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -test-status\n" help)
;;;      		      (if (sqlite3:database? db)(sqlite3:finalize! db))
;;;      		      (exit 6)))
;;;      		(let* ((msg    (args:get-arg "-m"))
;;;      		       (numoth (length (hash-table-keys otherdata))))
;;;      		  ;; Convert to rpc inside the tests:test-set-status! call, not here
;;;      		  (tests:test-set-status! run-id test-id state newstatus msg otherdata work-area: work-area))))
;;;      	  (if (sqlite3:database? db)(sqlite3:finalize! db))
;;;      	  (set! *didsomething* #t))))
;;;      
;;;      ;;======================================================================
;;;      ;; Various helper commands can go below here
;;;      ;;======================================================================
;;;      
;;;      (if (or (args:get-arg "-showkeys")
;;;              (args:get-arg "-show-keys"))
;;;          (let ((db #f)
;;;      	  (keys #f))
;;;            (if (not (launch:setup))
;;;      	  (begin
;;;      	    (debug:print 0 *default-log-port* "Failed to setup, exiting")
;;;      	    (exit 1)))
;;;            (set! keys (rmt:get-keys)) ;;  db))
;;;            (debug:print 1 *default-log-port* "Keys: " (string-intersperse keys ", "))
;;;            (if (sqlite3:database? db)(sqlite3:finalize! db))
;;;            (set! *didsomething* #t)))
;;;      
;;;      (if (args:get-arg "-gui")
;;;          (begin
;;;            (debug:print 0 *default-log-port* "Look at the dashboard for now")
;;;            ;; (megatest-gui)
;;;            (set! *didsomething* #t)))
;;;      
;;;      (if (args:get-arg "-create-megatest-area")
;;;          (begin
;;;            (genexample:mk-megatest.config)
;;;            (set! *didsomething* #t)))
;;;      
;;;      (if (args:get-arg "-create-test")
;;;          (let ((testname (args:get-arg "-create-test")))
;;;            (genexample:mk-megatest-test testname)
;;;            (set! *didsomething* #t)))
;;;      
;;;      ;;======================================================================
;;;      ;; Update the database schema, clean up the db
;;;      ;;======================================================================
;;;      
;;;      (if (args:get-arg "-rebuild-db")
;;;          (begin
;;;            (if (not (launch:setup))
;;;      	  (begin
;;;      	    (debug:print 0 *default-log-port* "Failed to setup, exiting") 
;;;      	    (exit 1)))
;;;            ;; keep this one local
;;;            ;; (open-run-close patch-db #f)
;;;            (let ((dbstruct (db:setup #f areapath: *toppath*)))
;;;              (common:cleanup-db dbstruct full: #t))
;;;            (set! *didsomething* #t)))
;;;      
;;;      (if (args:get-arg "-cleanup-db")
;;;          (begin
;;;            (if (not (launch:setup))
;;;      	  (begin
;;;      	    (debug:print 0 *default-log-port* "Failed to setup, exiting") 
;;;      	    (exit 1)))
;;;            (let ((dbstruct (db:setup #f areapath: *toppath*)))
;;;              (common:cleanup-db dbstruct))
;;;            (set! *didsomething* #t)))
;;;      
;;;      (if (args:get-arg "-mark-incompletes")
;;;          (begin
;;;            (if (not (launch:setup))
;;;      	  (begin
;;;      	    (debug:print 0 *default-log-port* "Failed to setup, exiting")
;;;      	    (exit 1)))
;;;            (rmt:find-and-mark-incomplete #f)
;;;            (set! *didsomething* #t)))
;;;      
;;;      ;;======================================================================
;;;      ;; Update the tests meta data from the testconfig files
;;;      ;;======================================================================
;;;      
;;;      (if (args:get-arg "-update-meta")
;;;          (begin
;;;            (if (not (launch:setup))
;;;      	  (begin
;;;      	    (debug:print 0 *default-log-port* "Failed to setup, exiting") 
;;;      	    (exit 1)))
;;;            (runs:update-all-test_meta #f)
;;;            (set! *didsomething* #t)))
;;;      
;;;      ;;======================================================================
;;;      ;; Start a repl
;;;      ;;======================================================================
;;;      
;;;      ;; fakeout readline
;;;      ;; (include "readline-fix.scm")
;;;      
;;;      
;;;      (when (args:get-arg "-diff-rep")
;;;        (when (and
;;;               (not (args:get-arg "-diff-html"))
;;;               (not (args:get-arg "-diff-email")))
;;;          (debug:print 0 *default-log-port* "Must specify -diff-html or -diff-email with -diff-rep")
;;;          (set! *didsomething* 1)
;;;          (exit 1))
;;;        
;;;        (let* ((toppath (launch:setup)))
;;;          (do-diff-report
;;;           (args:get-arg "-src-target")
;;;           (args:get-arg "-src-runname")
;;;           (args:get-arg "-target")
;;;           (args:get-arg "-runname")
;;;           (args:get-arg "-diff-html")
;;;           (args:get-arg "-diff-email"))
;;;          (set! *didsomething* #t)
;;;          (exit 0)))
;;;      
;;;      (if (or (getenv "MT_RUNSCRIPT")
;;;      	(args:get-arg "-repl")
;;;      	(args:get-arg "-load"))
;;;          (let* ((toppath (launch:setup))
;;;      	   (dbstruct (if (and toppath
;;;                                    (common:on-homehost?))
;;;                               (db:setup #t)
;;;                               #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f)))
;;;            (if *toppath*
;;;      	  (cond
;;;      	   ((getenv "MT_RUNSCRIPT")
;;;      	    ;; How to run megatest scripts
;;;      	    ;;
;;;      	    ;; #!/bin/bash
;;;      	    ;;
;;;      	    ;; export MT_RUNSCRIPT=yes
;;;      	    ;; megatest << EOF
;;;      	    ;; (print "Hello world")
;;;      	    ;; (exit)
;;;      	    ;; EOF
;;;      
;;;      	    (repl))
;;;      	   (else
;;;      	    (begin
;;;      	      (set! *db* dbstruct)
;;;      	      ;; (import extras) ;; might not be needed
;;;      	      ;; (import csi)
;;;      	      ;; (import readline)
;;;      	      (import apropos)
;;;      	      ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
;;;      
;;;      	;; (if *use-new-readline*
;;;      	;; 	  (begin
;;;      	;; 	    (install-history-file (get-environment-variable "HOME") ".megatest_history") ;;  [homedir] [filename] [nlines])
;;;      	;; 	    (current-input-port (make-readline-port "megatest> ")))
;;;      	;; 	  (begin
;;;      	;; 	    (gnu-history-install-file-manager
;;;      	;; 	     (string-append
;;;      	;; 	      (or (get-environment-variable "HOME") ".") "/.megatest_history"))
;;;      	;; 	    (current-input-port (make-gnu-readline-port "megatest> "))))
;;;      	      (if (args:get-arg "-repl")
;;;      		  (repl)
;;;      		  (load (args:get-arg "-load")))
;;;      	      ;; (db:close-all dbstruct) <= taken care of by on-exit call

;;;      	      )
;;;      	    (exit)))
;;;      	  (set! *didsomething* #t))))
;;;      
;;;      ;;======================================================================
;;;      ;; Wait on a run to complete
;;;      ;;======================================================================
;;;      
;;;      (if (and (args:get-arg "-run-wait")
;;;      	 (not (or (args:get-arg "-run")
;;;      		  (args:get-arg "-runtests")))) ;; run-wait is built into runtests now
;;;          (begin
;;;            (if (not (launch:setup))
;;;      	  (begin
;;;      	    (debug:print 0 *default-log-port* "Failed to setup, exiting") 
;;;      	    (exit 1)))
;;;            (operate-on 'run-wait)
;;;            (set! *didsomething* #t)))
;;;      
;;;      ;; ;; ;; redo me ;; Not converted to use dbstruct yet
;;;      ;; ;; ;; redo me ;;
;;;      ;; ;; ;; redo me (if (args:get-arg "-convert-to-norm")
;;;      ;; ;; ;; redo me     (let* ((toppath (setup-for-run))
;;;      ;; ;; ;; redo me 	   (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t))))
;;;      ;; ;; ;; redo me       (for-each 
;;;      ;; ;; ;; redo me        (lambda (field)
;;;      ;; ;; ;; redo me 	 (let ((dat '()))
;;;      ;; ;; ;; redo me 	   (debug:print-info 0 *default-log-port* "Getting data for field " field)
;;;      ;; ;; ;; redo me 	   (sqlite3:for-each-row
;;;      ;; ;; ;; redo me 	    (lambda (id val)
;;;      ;; ;; ;; redo me 	      (set! dat (cons (list id val) dat)))
;;;      ;; ;; ;; redo me 	    (db:get-db db run-id)
;;;      ;; ;; ;; redo me 	    (conc "SELECT id," field " FROM tests;"))
;;;      ;; ;; ;; redo me 	   (debug:print-info 0 *default-log-port* "found " (length dat) " items for field " field)
;;;      ;; ;; ;; redo me 	   (let ((qry (sqlite3:prepare db (conc "UPDATE tests SET " field "=? WHERE id=?;"))))
;;;      ;; ;; ;; redo me 	     (for-each
;;;      ;; ;; ;; redo me 	      (lambda (item)
;;;      ;; ;; ;; redo me 		(let ((newval ;; (sdb:qry 'getid 
;;;      ;; ;; ;; redo me 		       (cadr item))) ;; )
;;;      ;; ;; ;; redo me 		  (if (not (equal? newval (cadr item)))
;;;      ;; ;; ;; redo me 		      (debug:print-info 0 *default-log-port* "Converting " (cadr item) " to " newval " for test #" (car item)))
;;;      ;; ;; ;; redo me 		  (sqlite3:execute qry newval (car item))))
;;;      ;; ;; ;; redo me 	      dat)
;;;      ;; ;; ;; redo me 	     (sqlite3:finalize! qry))))
;;;      ;; ;; ;; redo me        (db:close-all dbstruct)
;;;      ;; ;; ;; redo me        (list "uname" "rundir" "final_logf" "comment"))
;;;      ;; ;; ;; redo me       (set! *didsomething* #t)))
;;;      
;;;      (if (args:get-arg "-import-megatest.db")
;;;          (begin
;;;            (db:multi-db-sync 
;;;             (db:setup #f)
;;;             'killservers
;;;             'dejunk
;;;             'adj-testids
;;;             'old2new
;;;             ;; 'new2old

;;;             )
;;;            (set! *didsomething* #t)))
;;;      
;;;      (when (args:get-arg "-sync-brute-force")
;;;        ((server:get-bruteforce-syncer (db:setup #t) persist-until-sync: #t))
;;;        (set! *didsomething* #t))
;;;      
;;;      (if (args:get-arg "-sync-to-megatest.db")
;;;          (let* ((dbstruct (db:setup #f))
;;;      	   (tmpdbpth (cdr (dbr:dbstruct-tmpdb dbstruct)))
;;;      	   (lockfile (conc tmpdbpth ".lock"))
;;;      	   (locked   (common:simple-file-lock lockfile)) 
;;;      	   (res      (if locked
;;;      			 (db:multi-db-sync 
;;;      			  dbstruct
;;;      			  'new2old)
;;;      			 #f)))
;;;            (if res
;;;      	  (begin
;;;      	    (common:simple-file-release-lock lockfile)
;;;      	    (print "Synced " res " records to megatest.db"))
;;;      	  (print "Skipping sync, there is a sync in progress."))
;;;            (set! *didsomething* #t)))
;;;      
;;;      (if (args:get-arg "-sync-to")
;;;          (let ((toppath (launch:setup)))
;;;            (tasks:sync-to-postgres *configdat* (args:get-arg "-sync-to"))
;;;            (set! *didsomething* #t)))
;;;      
;;;      (if (args:get-arg "-list-test-time")
;;;           (let* ((toppath (launch:setup))) 
;;;           (task:get-test-times)  
;;;           (set! *didsomething* #t)))
;;;      
;;;      (if (args:get-arg "-list-run-time")
;;;           (let* ((toppath (launch:setup))) 
;;;           (task:get-run-times)  
;;;           (set! *didsomething* #t)))
;;;           
;;;      (if (args:get-arg "-generate-html")
;;;          (let* ((toppath (launch:setup)))
;;;            (if (tests:create-html-tree #f)
;;;                (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/page0.html")
;;;                (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html"))
;;;            (set! *didsomething* #t)))
;;;      
;;;      (if (args:get-arg "-generate-html-structure")
;;;          (let* ((toppath (launch:setup)))
;;;            ;(if (tests:create-html-tree #f)
;;;       				(if (tests:create-html-summary #f)
;;;                (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/targets.html")
;;;                (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html"))
;;;            (set! *didsomething* #t)))
;;;      
;;;      (if (args:get-arg "-syscheck")
;;;          (begin
;;;            (mutils:syscheck common:raw-get-remote-host-load
;;;      		       server:get-best-guess-address
;;;      		       read-config)
;;;            (set! *didsomething* #t)))
;;;      
;;;      (if (args:get-arg "-extract-skeleton")
;;;          (let* ((toppath (launch:setup)))
;;;            (genexample:extract-skeleton-area (args:get-arg "-extract-skeleton"))
;;;            (set! *didsomething* #t)))
;;;      
;;;      ;;======================================================================
;;;      ;; Exit and clean up
;;;      ;;======================================================================
;;;      
;;;      (if (not *didsomething*)
;;;          (debug:print 0 *default-log-port* help)
;;;          (set! *time-to-exit* #t)

;;;          )
;;;      ;;(debug:print-info 13 *default-log-port* "thread-join! watchdog")
;;;      
;;;      ;; join the watchdog thread if it has been thread-start!ed  (it may not have been started in the case of a server that never enters running state)
;;;      ;;   (symbols returned by thread-state: created ready running blocked suspended sleeping terminated dead)
;;;      ;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
;;;      (if (thread? *watchdog*)
;;;          (case (thread-state *watchdog*)
;;;            ((ready running blocked sleeping terminated dead)
;;;             (thread-join! *watchdog*))))
;;;      
;;;      (set! *time-to-exit* #t)
;;;      
;;;      (if (not (eq? *globalexitstatus* 0))
;;;          (if (or (args:get-arg "-run")(args:get-arg "-runtests")(args:get-arg "-runall"))
;;;              (begin
;;;                 (debug:print 0 *default-log-port* "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*)
;;;                 (exit 0))
;;;              (case *globalexitstatus*
;;;               ((0)(exit 0))
;;;               ((1)(exit 1))
;;;               ((2)(exit 2))
;;;               (else (exit 3)))))
;;;      )

)

;; (main)
(print "Got here")

Modified mt.scm from [e9055c2687] to [872eb49e64].

13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;


(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) posix-extras directory-utils call-with-environment-variables)
(import (prefix sqlite3 sqlite3:))

(declare (unit mt))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
(declare (uses server))
(declare (uses runs))
(declare (uses rmt))
;; (declare (uses filedb))

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

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

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







|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|







13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;


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

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

;;======================================================================
;;  R U N S
;;======================================================================
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
			actual-state  " "
			actual-status " "
			event-time
			))
	 (prev-nbfake-log (get-environment-variable "NBFAKE_LOG")))
    (setenv "NBFAKE_LOG" (conc (cond
				((and (directory-exists? test-rundir)
				      (file-write-access? test-rundir))
				 test-rundir)
				((and (directory-exists? *toppath*)
				      (file-write-access? *toppath*))
				 *toppath*)
				(else (conc "/tmp/" (current-user-name))))
			       "/" logname))
    (debug:print-info 0 *default-log-port* "TRIGGERED on " trigger ", running command " fullcmd " output at " (get-environment-variable "NBFAKE_LOG"))
    ;; (call-with-environment-variables
    ;;  `(("NBFAKE_LOG" . ,(conc test-rundir "/" logname)))
    ;;  (lambda ()







|


|







153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
			actual-state  " "
			actual-status " "
			event-time
			))
	 (prev-nbfake-log (get-environment-variable "NBFAKE_LOG")))
    (setenv "NBFAKE_LOG" (conc (cond
				((and (directory-exists? test-rundir)
				      (file-writable? test-rundir))
				 test-rundir)
				((and (directory-exists? *toppath*)
				      (file-writable? *toppath*))
				 *toppath*)
				(else (conc "/tmp/" (current-user-name))))
			       "/" logname))
    (debug:print-info 0 *default-log-port* "TRIGGERED on " trigger ", running command " fullcmd " output at " (get-environment-variable "NBFAKE_LOG"))
    ;; (call-with-environment-variables
    ;;  `(("NBFAKE_LOG" . ,(conc test-rundir "/" logname)))
    ;;  (lambda ()
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
	tconf
	(let ((test-dirs (tests:get-tests-search-path *configdat*)))
	  (let loop ((hed (car test-dirs))
		     (tal (cdr test-dirs)))
	    ;; Setting MT_LINKTREE here is almost certainly unnecessary. 
	    (let ((tconfig-file (conc hed "/" test-name "/testconfig")))
	      (if (and (common:file-exists? tconfig-file)
		       (file-read-access? tconfig-file))
		  (let ((link-tree-path (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree"))
			(old-link-tree  (get-environment-variable "MT_LINKTREE")))
		    (if link-tree-path (setenv "MT_LINKTREE" link-tree-path))
		    (let ((newtcfg (read-config tconfig-file #f #f))) ;; NOTE: Does NOT run [system ...]
		      (hash-table-set! *testconfigs* test-name newtcfg)
		      (if old-link-tree 
			  (setenv "MT_LINKTREE" old-link-tree)







|







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

Modified mtargs/mtargs.scm from [e2f1c247b7] to [40b7a0d6eb].

24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
     usage
     get-args
     print-args
     any-defined?
     help
     )

(import scheme chicken data-structures extras posix ports files)
(use srfi-69 srfi-1)

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

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







|
<







24
25
26
27
28
29
30
31

32
33
34
35
36
37
38
     usage
     get-args
     print-args
     any-defined?
     help
     )

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


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

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

Added mtver.scm version [88befd643e].



























































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
;;  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/>.

;; Always use two or four digit decimal
;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00..

(declare (unit mtver))

(module mtver *

(import scheme chicken.module)

(define megatest-version 1.6584)

)

Modified mutils/mutils.scm from [9fa9e34972] to [b79d63c449].

10
11
12
13
14
15
16
17













18
19
20
21
22
23
24
25
26
27


28


29
30
31
32
33
34
35
;; This is from the perl world, a hash of hashes is a super easy way to keep a handle on
;; lots of disparate data
;;

(module mutils
    *

  (import chicken scheme













	  ;; data-structures posix
	  srfi-1
	  ;; srfi-13
	  srfi-69
	  ports
	  extras
	  regex
	  posix
	  data-structures
	  matchable


	  )



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







|
>
>
>
>
>
>
>
>
>
>
>
>
>




|
|

<
<

>
>
|
>
>







10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37


38
39
40
41
42
43
44
45
46
47
48
49
50
;; This is from the perl world, a hash of hashes is a super easy way to keep a handle on
;; lots of disparate data
;;

(module mutils
    *

  (import scheme

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

	  regex


	  matchable
	  sparse-vectors
	  system-information
	  
	  )


(define (mutils:hierhash-ref hh . keys)
  (if (null? keys)
      #f
      (let loop ((ht   hh)
		 (key  (car keys))
		 (tail (cdr keys)))
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
      (if (eof-object? l)
	  (reverse res)
	  (if (or (string-match comment l)
		  (string-match blank l))
	      (loop (read-line fh) res)
	      (loop (read-line fh) (cons l res)))))))

(use sparse-vectors)

;; this is a simple two dimensional sparse array

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







<
<







103
104
105
106
107
108
109


110
111
112
113
114
115
116
      (if (eof-object? l)
	  (reverse res)
	  (if (or (string-match comment l)
		  (string-match blank l))
	      (loop (read-line fh) res)
	      (loop (read-line fh) (cons l res)))))))



;; this is a simple two dimensional sparse array

;; ONLY TWO DIMENSIONS!!! SEE ARRAY-LIB IF YOUR NEEDS ARE GREATER!!
;;
(define (mutils:make-sparse-array)
  (let ((a (make-sparse-vector)))
    (sparse-vector-set! a 0 (make-sparse-vector))
187
188
189
190
191
192
193
194
195

196
197
198
199
200
201
202
	   (apply mutils:hier-list-get @hierlist @path))))

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

(define (check-write-create fpath)
  (and (file-write-access? fpath)
       (let ((fname (conc fpath "/.junk-" (current-seconds) "-" (random 10000))))

	 ;;(print "trying to create/remove " fname)
	 (handle-exceptions
	  exn
	  #f
	  (begin
	    (with-output-to-file fname
	      (lambda ()







|
|
>







200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
	   (apply mutils:hier-list-get @hierlist @path))))

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

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

Modified ods.scm from [42e94b826f] to [58135ee6ad].

12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;

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

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







|
|
|







12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;

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

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

Modified pkts/pkts.scm from [90f8c93eeb] to [c88a79173d].

160
161
162
163
164
165
166

167
168
169
170
171
172
173
174
175
pktdb-pktspec

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


(import chicken scheme data-structures posix srfi-1 regex srfi-13 srfi-69 ports extras)
(use crypt sha1 message-digest (prefix dbi dbi:) typed-records)

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

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







>
|
|







160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
pktdb-pktspec

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

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

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

(define-inline (unescape-data data)
  (string-translate* data '(("\\n" . "\n") ("\\\\" . "\\"))))
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
     (for-each
      (lambda (pktsdir) ;; look at all
	(cond
	 ((not (file-exists? pktsdir))
	  (print "ERROR: packets directory " pktsdir " does not exist."))
	 ((not (directory? pktsdir))
	  (print "ERROR: packets directory path " pktsdir " is not a directory."))
	 ((not (file-read-access? pktsdir))
	  (print "ERROR: packets directory path " pktsdir " is not readable."))
	 (else
	  ;; (print "INFO: Loading packets found in " pktsdir)
	  (let ((pkts (glob (conc pktsdir "/*.pkt"))))
	    (for-each
	     (lambda (pkt)
	       (let* ((uuid    (cadr (string-match ".*/([0-9a-f]+).pkt" pkt)))







|







694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
     (for-each
      (lambda (pktsdir) ;; look at all
	(cond
	 ((not (file-exists? pktsdir))
	  (print "ERROR: packets directory " pktsdir " does not exist."))
	 ((not (directory? pktsdir))
	  (print "ERROR: packets directory path " pktsdir " is not a directory."))
	 ((not (file-readable? pktsdir))
	  (print "ERROR: packets directory path " pktsdir " is not readable."))
	 (else
	  ;; (print "INFO: Loading packets found in " pktsdir)
	  (let ((pkts (glob (conc pktsdir "/*.pkt"))))
	    (for-each
	     (lambda (pkt)
	       (let* ((uuid    (cadr (string-match ".*/([0-9a-f]+).pkt" pkt)))

Added pktsmod.scm version [4f496b5684].















































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
;;======================================================================
;; Copyright 2019, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

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

(declare (unit pkts))

(include "pkts/pkts.scm")

Modified portlogger.scm from [36a4964f50] to [e7dc27d254].

13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;

(require-extension (srfi 18) extras tcp s11n)

(use sqlite3 srfi-1 posix srfi-69 hostinfo dot-locking z3)
(import (prefix sqlite3 sqlite3:))

(declare (unit portlogger))
(declare (uses db))

;; lsof -i

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







|
|
|
|
|
|
|












|







13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;

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

;; lsof -i

(define (portlogger:open-db fname)
  (let* ((avail    (tasks:wait-on-journal fname 5 remove: #t)) ;; wait up to about 10 seconds for the journal to go away
	 (exists   (common:file-exists? fname))
	 (db       (if avail 
		       (sqlite3:open-database fname)
		       (begin
			 (system (conc "rm -f " fname))
			 (sqlite3:open-database fname))))
	 (handler  (sqlite3:make-busy-timeout 136000))
	 (canwrite (file-writable? fname)))
	 ;; (db-init  (lambda ()
	 ;;             (sqlite3:execute 
	 ;;              db
	 ;;              "CREATE TABLE IF NOT EXISTS ports (
         ;;                 port INTEGER PRIMARY KEY,
         ;;                 state TEXT DEFAULT 'not-used',
         ;;                 fail_count INTEGER DEFAULT 0,
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
  (let* ((lowport (let ((val (configf:lookup *configdat* "server" "lowport")))
		    (if (and val 
			     (string->number val))
			(string->number val)
			32768)))
	 (portnum (or (portlogger:get-prev-used-port db)
		      (+ lowport ;; top of registered ports is 49152 but lets use ports in the registered range
			 (random (- 64000 lowport))))))
    (handle-exceptions
     exn
     (begin
       (debug:print 0 *default-log-port* "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db")
       (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
       (debug:print 5 *default-log-port* "exn=" (condition->list exn))
       (print-call-chain (current-error-port))







|







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

Modified process.scm from [f9dfbe5500] to [df1baf0131].

18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33

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

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

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

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








|
|







18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33

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

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

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

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

Modified rmt.scm from [ed2cbd88f2] to [9c5b8773ea].

14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;
;;======================================================================

(use format typed-records) ;; RADT => purpose of json format??

(declare (unit rmt))
(declare (uses api))
(declare (uses http-transport))
(include "common_records.scm")
;; (declare (uses rmtmod))

;; (import rmtmod)

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







|
|
|
|
|
|







14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;
;;======================================================================

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

;; (import rmtmod)

;;
;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!!
;;
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
                        payload: `((rid . ,rid)
                                   (params . ,params)))
                          
  (if (> attemptnum 2)
      (debug:print 0 *default-log-port* "INFO: attemptnum in rmt:send-receive is " attemptnum))
    
  (cond
   ((> attemptnum 2) (thread-sleep! 0.05))
   ((> attemptnum 10) (thread-sleep! 0.5))
   ((> attemptnum 20) (thread-sleep! 1)))
  (if (and (> attemptnum 5) (= 0 (modulo attemptnum 15)))  
    (begin (server:run *toppath*) (thread-sleep! 3))) 
  
  
  ;;DOT digraph megatest_state_status {







|







66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
                        payload: `((rid . ,rid)
                                   (params . ,params)))
                          
  (if (> attemptnum 2)
      (debug:print 0 *default-log-port* "INFO: attemptnum in rmt:send-receive is " attemptnum))
    
  (cond
   ((> attemptnum 2) (thread-sleep! 0.053))
   ((> attemptnum 10) (thread-sleep! 0.5))
   ((> attemptnum 20) (thread-sleep! 1)))
  (if (and (> attemptnum 5) (= 0 (modulo attemptnum 15)))  
    (begin (server:run *toppath*) (thread-sleep! 3))) 
  
  
  ;;DOT digraph megatest_state_status {
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
    (mutex-unlock! *db-stats-mutex*)
    res))

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







|







369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
    (mutex-unlock! *db-stats-mutex*)
    res))

(define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5))
  (let* ((qry-is-write   (not (member cmd api:read-only-queries)))
	 (db-file-path   (db:dbfile-path)) ;;  0))
	 (dbstruct-local (db:setup #t))  ;; make-dbr:dbstruct path:  dbdir local: #t)))
	 (read-only      (not (file-writable? db-file-path)))
	 (start          (current-milliseconds))
	 (resdat         (if (not (and read-only qry-is-write))
			     (let ((v (api:execute-requests dbstruct-local (vector (symbol->string cmd) params))))
			       (handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong..
				exn               ;;  This is an attempt to detect that situation and recover gracefully
				(begin
				  (debug:print 0 *default-log-port* "ERROR: bad data from server " v " message: "  ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
	 (duration       (- (current-milliseconds) start)))
    (if (and read-only qry-is-write)
        (debug:print 0 *default-log-port* "ERROR: attempt to write to read-only database ignored. cmd=" cmd))
    (if (not success)
	(if (> remretries 0)
	    (begin
	      (debug:print-error 0 *default-log-port* "local query failed. Trying again.")
	      (thread-sleep! (/ (random 5000) 1000)) ;; some random delay 
	      (rmt:open-qry-close-locally cmd run-id params remretries: (- remretries 1)))
	    (begin
	      (debug:print-error 0 *default-log-port* "too many retries in rmt:open-qry-close-locally, giving up")
	      #f))
	(begin
	  ;; (rmt:update-db-stats run-id cmd params duration)
	  ;; mark this run as dirty if this was a write, the watchdog is responsible for syncing it







|







393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
	 (duration       (- (current-milliseconds) start)))
    (if (and read-only qry-is-write)
        (debug:print 0 *default-log-port* "ERROR: attempt to write to read-only database ignored. cmd=" cmd))
    (if (not success)
	(if (> remretries 0)
	    (begin
	      (debug:print-error 0 *default-log-port* "local query failed. Trying again.")
	      (thread-sleep! (/ (pseudo-random-integer 5000) 1000)) ;; some random delay 
	      (rmt:open-qry-close-locally cmd run-id params remretries: (- remretries 1)))
	    (begin
	      (debug:print-error 0 *default-log-port* "too many retries in rmt:open-qry-close-locally, giving up")
	      #f))
	(begin
	  ;; (rmt:update-db-stats run-id cmd params duration)
	  ;; mark this run as dirty if this was a write, the watchdog is responsible for syncing it
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
					   (mutex-lock! multi-run-mutex)
					   (set! result (append result res))
					   (mutex-unlock! multi-run-mutex))
					 (debug:print-error 0 *default-log-port* "get-tests-for-run-mindata failed for run-id " hed ", testpatt " testpatt ", states " states ", status " status ", not-in " not-in))))
				 (conc "multi-run-thread for run-id " hed)))
		     (newthreads (cons newthread threads)))
		(thread-start! newthread)
		(thread-sleep! 0.05) ;; give that thread some time to start
		(if (null? tal)
		    newthreads
		    (loop (car tal)(cdr tal) newthreads))))))
    result))

;; ;; IDEA: Threadify these - they spend a lot of time waiting ...
;; ;;







|







612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
					   (mutex-lock! multi-run-mutex)
					   (set! result (append result res))
					   (mutex-unlock! multi-run-mutex))
					 (debug:print-error 0 *default-log-port* "get-tests-for-run-mindata failed for run-id " hed ", testpatt " testpatt ", states " states ", status " status ", not-in " not-in))))
				 (conc "multi-run-thread for run-id " hed)))
		     (newthreads (cons newthread threads)))
		(thread-start! newthread)
		(thread-sleep! 0.054) ;; give that thread some time to start
		(if (null? tal)
		    newthreads
		    (loop (car tal)(cdr tal) newthreads))))))
    result))

;; ;; IDEA: Threadify these - they spend a lot of time waiting ...
;; ;;
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986


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








|







972
973
974
975
976
977
978
979
980
981
982
983
984
985
986


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

Modified rmtmod.scm from [4f89f84546] to [cb38f42270].

17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33



34
35
36

37
38
39
40
41
42
43
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

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

(declare (unit rmtmod))
(declare (uses commonmod))
(declare (uses apimod))
;; (declare (uses apimod.import))
(declare (uses ulex))

;; (include "ulex/ulex.scm")

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



(import (prefix commonmod cmod:))
(import apimod)
(import (prefix ulex ulex:))


(defstruct alldat
  (areapath #f)
  (ulexdat  #f)
  )

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







<
<
<
<




|
|
>
>
>
|
|
|
>







17
18
19
20
21
22
23




24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

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

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





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

	typed-records
	srfi-18
	commonmod
	apimod

	)

(defstruct alldat
  (areapath #f)
  (ulexdat  #f)
  )

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

Modified runconfig.scm from [66b9c38588] to [f03a86116d].

16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

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

(use format directory-utils)

(declare (unit runconfig))
(declare (uses common))

(include "common_records.scm")

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

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







|
|
|
|
|
|







16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

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

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

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

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

Modified runs.scm from [2583922f1c] to [ec21108c67].

13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

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

(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) 
     posix-extras directory-utils pathname-expand typed-records format  sxml-serializer
     sxml-modifications matchable)

(declare (unit runs))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
(declare (uses server))
(declare (uses mt))
(declare (uses archive))
;; (declare (uses filedb))

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

;; (include "debugger.scm")

;; use this struct to facilitate refactoring
;;

(defstruct runs:dat
  reglen regfull







|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|







13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

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

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

;; use this struct to facilitate refactoring
;;

(defstruct runs:dat
  reglen regfull
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
	 (rtime  0)
	 (startt (current-seconds))
	 (endt   (+ startt duration)))
    ((or proc runs:parallel-runners-mgmt) rdat)
    (let loop ()
      (let* ((wstart (current-seconds)))
	(if (< wstart endt)
	    (let* ((work-time (random 10)))
	      #;(debug:print-info 0 *default-log-port* "working for " work-time
				" seconds. Total work: " rtime ", elapsed time: " (- wstart startt))
	      (thread-sleep! work-time)
	      (set! rtime (+ rtime work-time))
	      ((or proc runs:parallel-runners-mgmt) rdat)
	      (loop)))))
    (let* ((done-time (current-seconds)))







|







126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
	 (rtime  0)
	 (startt (current-seconds))
	 (endt   (+ startt duration)))
    ((or proc runs:parallel-runners-mgmt) rdat)
    (let loop ()
      (let* ((wstart (current-seconds)))
	(if (< wstart endt)
	    (let* ((work-time (pseudo-random-integer 10)))
	      #;(debug:print-info 0 *default-log-port* "working for " work-time
				" seconds. Total work: " rtime ", elapsed time: " (- wstart startt))
	      (thread-sleep! work-time)
	      (set! rtime (+ rtime work-time))
	      ((or proc runs:parallel-runners-mgmt) rdat)
	      (loop)))))
    (let* ((done-time (current-seconds)))
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
(define (runs:run-tests target runname test-patts user flags #!key (run-count 1)) ;; test-names
  (let* ((keys               (keys:config-get-fields *configdat*))
	 (keyvals            (keys:target->keyval keys target))
	 (run-id             (rmt:register-run keyvals runname "new" "n/a" user (args:get-arg "-contour")))  ;;  test-name)))
	 ;; (deferred          '()) ;; delay running these since they have a waiton clause
	 (runconfigf         (conc  *toppath* "/runconfigs.config"))
         (dbfile             (conc  *toppath* "/megatest.db"))
         (readonly-mode      (not (file-write-access? dbfile)))
	 (test-records       (make-hash-table))
	 ;; need to process runconfigs before generating these lists
	 (all-tests-registry #f)  ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names
	 (all-test-names     #f)  ;; (hash-table-keys all-tests-registry))
	 (test-names         #f)  ;; Generated by a call to (tests:filter-test-names all-test-names test-patts))
	 (required-tests     #f)  ;; Put fully qualified test/testpath names in this list to be done
         (waitors-upon       (make-hash-table)) ;; given a test, return list of tests waiting upon this test.







|







506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
(define (runs:run-tests target runname test-patts user flags #!key (run-count 1)) ;; test-names
  (let* ((keys               (keys:config-get-fields *configdat*))
	 (keyvals            (keys:target->keyval keys target))
	 (run-id             (rmt:register-run keyvals runname "new" "n/a" user (args:get-arg "-contour")))  ;;  test-name)))
	 ;; (deferred          '()) ;; delay running these since they have a waiton clause
	 (runconfigf         (conc  *toppath* "/runconfigs.config"))
         (dbfile             (conc  *toppath* "/megatest.db"))
         (readonly-mode      (not (file-writable? dbfile)))
	 (test-records       (make-hash-table))
	 ;; need to process runconfigs before generating these lists
	 (all-tests-registry #f)  ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names
	 (all-test-names     #f)  ;; (hash-table-keys all-tests-registry))
	 (test-names         #f)  ;; Generated by a call to (tests:filter-test-names all-test-names test-patts))
	 (required-tests     #f)  ;; Put fully qualified test/testpath names in this list to be done
         (waitors-upon       (make-hash-table)) ;; given a test, return list of tests waiting upon this test.
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
     ;; If no resources are available just kill time and loop again
     ;;
     ((not have-resources) ;; simply try again after waiting a second
      (if (runs:lownoise "no resources" 60)
	  (debug:print-info 1 *default-log-port* "no resources to run new tests, waiting ..."))
      ;; Have gone back and forth on this but db starvation is an issue.
      ;; wait one second before looking again to run jobs.
      (thread-sleep! 0.25)
      ;; could have done hed tal here but doing car/cdr of newtal to rotate tests
      (list (car newtal)(cdr newtal) reg reruns))
     
     ;; This is the final stage, everything is in place so launch the test
     ;;
     ((and have-resources
	   (or (null? prereqs-not-met)







|







1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
     ;; If no resources are available just kill time and loop again
     ;;
     ((not have-resources) ;; simply try again after waiting a second
      (if (runs:lownoise "no resources" 60)
	  (debug:print-info 1 *default-log-port* "no resources to run new tests, waiting ..."))
      ;; Have gone back and forth on this but db starvation is an issue.
      ;; wait one second before looking again to run jobs.
      (thread-sleep! 0.253)
      ;; could have done hed tal here but doing car/cdr of newtal to rotate tests
      (list (car newtal)(cdr newtal) reg reruns))
     
     ;; This is the final stage, everything is in place so launch the test
     ;;
     ((and have-resources
	   (or (null? prereqs-not-met)
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
	 (rp-mutex     (make-mutex))
	 (bup-mutex    (make-mutex))
         (keep-records (args:get-arg "-keep-records")) ;; used in conjunction with -remove-runs to keep the records, TODO: consolidate this with "mode".
	 (test-records '())) ;; for tasks that we wish to operate on all tests in one fell swoop

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







|







2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
	 (rp-mutex     (make-mutex))
	 (bup-mutex    (make-mutex))
         (keep-records (args:get-arg "-keep-records")) ;; used in conjunction with -remove-runs to keep the records, TODO: consolidate this with "mode".
	 (test-records '())) ;; for tasks that we wish to operate on all tests in one fell swoop

    (let* ((write-access-actions '(remove-runs set-state-status archive run-wait kill-runs))
           (dbfile             (conc  *toppath* "/megatest.db"))
           (readonly-mode      (not (file-writable? dbfile))))
      (when (and readonly-mode
                 (member action write-access-actions))
        (debug:print-error 0 *default-log-port* "megatest.db is readonly.  Cannot proceed with action ["action"] in which write-access isrequired .")
        (exit 1)))
    
    (debug:print-info 4 *default-log-port* "runs:operate-on => Header: " header " action: " action " new-state-status: " new-state-status)
    (if (> 2 (length state-status))
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
                                        (if (and (not (string=  rundir "/tmp/badname")) 
                                             (file-exists? rundir)
                                             (substring-index run-name rundir)
                                             (tests:glob-like-match (conc "%/" target "/%") rundir)
                                             )
                                          (begin
                                            (set! lasttpath (db:test-get-rundir new-test-dat)) ;; remember this path for run removal
                                            (set! lastrealpath (remove-last-path-directory (resolve-pathname lasttpath)))
                                            (hash-table-set! run-paths-hash lastrealpath 1)
                                            (runs:remove-test-directory new-test-dat mode) ;; 'remove-all)
                                          )
                                          (begin
                                            (debug:print 2 *default-log-port* "Not removing directory " rundir " because either it doesn't exist or has a bad name")
                                            (debug:print 2 *default-log-port* "Is /tmp/badname: " (string=  rundir "/tmp/badname"))
                                            (debug:print 2 *default-log-port* "Exists: " (file-exists? rundir))







|







2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
                                        (if (and (not (string=  rundir "/tmp/badname")) 
                                             (file-exists? rundir)
                                             (substring-index run-name rundir)
                                             (tests:glob-like-match (conc "%/" target "/%") rundir)
                                             )
                                          (begin
                                            (set! lasttpath (db:test-get-rundir new-test-dat)) ;; remember this path for run removal
                                            (set! lastrealpath (remove-last-path-directory (realpath lasttpath)))
                                            (hash-table-set! run-paths-hash lastrealpath 1)
                                            (runs:remove-test-directory new-test-dat mode) ;; 'remove-all)
                                          )
                                          (begin
                                            (debug:print 2 *default-log-port* "Not removing directory " rundir " because either it doesn't exist or has a bad name")
                                            (debug:print 2 *default-log-port* "Is /tmp/badname: " (string=  rundir "/tmp/badname"))
                                            (debug:print 2 *default-log-port* "Exists: " (file-exists? rundir))
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
      ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "CLEANING" "LOCKED" #f))
      ((remove-all)      (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "REMOVING" "LOCKED" #f))
      ((archive-remove)  (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVE_REMOVING" #f #f)))
    (debug:print-info 1 *default-log-port* "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir)
    (if (and real-dir 
	     (> (string-length real-dir) 5)
	     (common:file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc.
	(let* ((realpath (resolve-pathname run-dir)))
	  (debug:print-info 1 *default-log-port* "Recursively removing " realpath)
	  (if (common:file-exists? realpath)
	      (runs:safe-delete-test-dir realpath)
	      (debug:print 0 *default-log-port* "WARNING: test dir " realpath " appears to not exist or is not readable")))
	(if real-dir 
	    (debug:print 0 *default-log-port* "WARNING: directory " real-dir " does not exist")
	    (debug:print 0 *default-log-port* "WARNING: no real directory corrosponding to link " run-dir ", nothing done")))







|







2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
      ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "CLEANING" "LOCKED" #f))
      ((remove-all)      (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "REMOVING" "LOCKED" #f))
      ((archive-remove)  (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVE_REMOVING" #f #f)))
    (debug:print-info 1 *default-log-port* "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir)
    (if (and real-dir 
	     (> (string-length real-dir) 5)
	     (common:file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc.
	(let* ((realpath (realpath run-dir)))
	  (debug:print-info 1 *default-log-port* "Recursively removing " realpath)
	  (if (common:file-exists? realpath)
	      (runs:safe-delete-test-dir realpath)
	      (debug:print 0 *default-log-port* "WARNING: test dir " realpath " appears to not exist or is not readable")))
	(if real-dir 
	    (debug:print 0 *default-log-port* "WARNING: directory " real-dir " does not exist")
	    (debug:print 0 *default-log-port* "WARNING: no real directory corrosponding to link " run-dir ", nothing done")))
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972

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

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







<
|







2957
2958
2959
2960
2961
2962
2963

2964
2965
2966
2967
2968
2969
2970
2971

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

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

  (let*	((junit-test-reporter	(configf:lookup *configdat* "runs" "junit-test-reporter-xml"))
	 (junit-test-report-dir  (configf:lookup *configdat* "runs" "junit-test-report-dir"))
	 (xml-dir		(if (and junit-test-reporter (equal? junit-test-reporter "yes" ))
				    (if junit-test-report-dir
					junit-test-report-dir
					(conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME")))
				    #f))
	 (xml-ts-name		(if xml-dir
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
			 (test-itempath	(vector-ref test 11))
			 (tc-name	(conc test-name (if (and test-itempath (not (equal? test-itempath ""))) (conc "." (string-translate test-itempath "/" "." )) "")))
			 (test-state	(vector-ref test 3))
			 (comment	(vector-ref test 14))   
			 (test-status	(vector-ref test 4))
			 (exc-msg	(conc "No bucket for State " test-state " Status " test-status))
			 (new-doc	(cond 
						((member test-state (list "RUNNING" ))
							((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inProgress)))) doc))
						((member test-state (list "LAUNCHED" "REMOTEHOSTSTART"  "NOT_STARTED"))
							((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inQueue)))) doc))
						((member test-status (list "PASS" "WARN" "WAIVED"))
							((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name))))) doc))
						((member test-status (list "FAIL" "CHECK"))
							((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "failure")))))) doc)) 
						((member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED"))
							((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "error")))))) doc))
						((member test-status (list "SKIP"))
							((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (skipped (@ (type "skipped")))))) doc))
						(else 
							(debug:print 0 *default-log-port* (conc "What do I do with State " test-state " Status " test-status))
							((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,exc-msg) (type "error")))))) doc))))
			(new-error-cnt	(if (member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED"))
						(+ error-cnt 1) 
						error-cnt))
			(new-fail-cnt	(if (member test-status (list "FAIL" "CHECK"))
						(+ fail-cnt 1)
						  fail-cnt)))
 	      (if (null? tail)
		    (let* ((final-doc ((sxml-modify `("testsuite" insert-into (@ (name ,xml-ts-name) (tests ,tests-count) (errors ,error-cnt) (failures ,fail-cnt)))) new-doc)))
		    (debug:print 0 *default-log-port* "modify attrib error=" error-cnt " fail= " fail-cnt)
		    (handle-exceptions
		     exn
		     (let*	((msg	((condition-property-accessor 'exn 'message) exn)))
		       (debug:print 0 *default-log-port* (conc "WARNING: Failed to update file" xml-path". Message:" msg ", exn=" exn)))







|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|







3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
			 (test-itempath	(vector-ref test 11))
			 (tc-name	(conc test-name (if (and test-itempath (not (equal? test-itempath ""))) (conc "." (string-translate test-itempath "/" "." )) "")))
			 (test-state	(vector-ref test 3))
			 (comment	(vector-ref test 14))   
			 (test-status	(vector-ref test 4))
			 (exc-msg	(conc "No bucket for State " test-state " Status " test-status))
			 (new-doc	(cond 
					 ((member test-state (list "RUNNING" ))
					  ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inProgress)))) doc))
					 ((member test-state (list "LAUNCHED" "REMOTEHOSTSTART"  "NOT_STARTED"))
					  ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inQueue)))) doc))
					 ((member test-status (list "PASS" "WARN" "WAIVED"))
					  ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name))))) doc))
					 ((member test-status (list "FAIL" "CHECK"))
					  ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "failure")))))) doc)) 
					 ((member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED"))
					  ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "error")))))) doc))
					 ((member test-status (list "SKIP"))
					  ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (skipped (@ (type "skipped")))))) doc))
					 (else 
					  (debug:print 0 *default-log-port* (conc "What do I do with State " test-state " Status " test-status))
					  ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,exc-msg) (type "error")))))) doc))))
			 (new-error-cnt	(if (member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED"))
					    (+ error-cnt 1) 
					    error-cnt))
			 (new-fail-cnt	(if (member test-status (list "FAIL" "CHECK"))
					    (+ fail-cnt 1)
					    fail-cnt)))
 	      (if (null? tail)
		    (let* ((final-doc ((sxml-modify `("testsuite" insert-into (@ (name ,xml-ts-name) (tests ,tests-count) (errors ,error-cnt) (failures ,fail-cnt)))) new-doc)))
		    (debug:print 0 *default-log-port* "modify attrib error=" error-cnt " fail= " fail-cnt)
		    (handle-exceptions
		     exn
		     (let*	((msg	((condition-property-accessor 'exn 'message) exn)))
		       (debug:print 0 *default-log-port* (conc "WARNING: Failed to update file" xml-path". Message:" msg ", exn=" exn)))

Modified server.scm from [5b645d5dff] to [ec8310146f].

12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;

(require-extension (srfi 18) extras tcp s11n)

(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest
     directory-utils posix-extras matchable)

(use spiffy uri-common intarweb http-client spiffy-request-vars)

(declare (unit server))

(declare (uses common))
(declare (uses db))
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
;; (declare (uses synchash))
(declare (uses http-transport))
;;(declare (uses rpc-transport))
(declare (uses launch))
;; (declare (uses daemon))

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

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

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

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

;; ???








|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
<
<
<
<
<







12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38







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

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








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

;; ???

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







|







145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
	     (not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host))
	     (not (equal? curr-ip target-host)))
	(begin
	  (debug:print-info 0 *default-log-port* "Starting server on " target-host ", logfile is " logfile)
	  (setenv "TARGETHOST" target-host)))
      
    (setenv "TARGETHOST_LOGF" logfile)
    (thread-sleep! (/ (pseudo-random-integer 5000) 1000)) ;; add about a random (up to 5 seconds) initial delay. It seems pretty common that many running tests request a server at the same time
    ;; (common:wait-for-normalized-load load-limit " delaying server start due to load" target-host) ;; do not try starting servers on an already overloaded machine, just wait forever
    #;(common:wait-for-homehost-load load-limit (conc " delaying server start due to load on homehost. limit is " load-limit))
    (system (conc "nbfake " cmdln))
    (unsetenv "TARGETHOST_LOGF")
    (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST"))
    (thread-join! log-rotate)
    (pop-directory)))
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
                   (if dbprep-found
                      (begin
                         (debug:print-info 0 *default-log-port* "Server is in dbprep at " (current-seconds))
                         (thread-sleep! 25)
                      )
                      (debug:print-info 0 *default-log-port* "Unable to get server info from " logf " at " (current-seconds))
                   )
		    (list #f #f #f #f)))))))))

;; get a list of servers with all relevant data
;; ( mod-time host port start-time pid )
;;
(define (server:get-list areapath #!key (limit #f))
  (let ((fname-rx    (regexp "^(|.*/)server-(\\d+)-(\\S+).log$"))
	(day-seconds (* 24 60 60)))
    ;; if the directory exists continue to get the list
    ;; otherwise attempt to create the logs dir and then
    ;; continue
    (if (if (directory-exists? (conc areapath "/logs"))
	    '()
	    (if (file-write-access? areapath)
		(begin
		  (condition-case
		   (create-directory (conc areapath "/logs") #t)
		   (exn (i/o file)(debug:print 0 *default-log-port* "ERROR: Cannot create directory at " (conc areapath "/logs")))
		   (exn ()(debug:print 0 *default-log-port* "ERROR: Unknown error attemtping to get server list. exn=" exn)))
		  (directory-exists? (conc areapath "/logs")))
		'()))

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







|












|









|
<







197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227

228
229
230
231
232
233
234
                   (if dbprep-found
                      (begin
                         (debug:print-info 0 *default-log-port* "Server is in dbprep at " (current-seconds))
                         (thread-sleep! 25)
                      )
                      (debug:print-info 0 *default-log-port* "Unable to get server info from " logf " at " (current-seconds))
                   )
		   (list #f #f #f #f)))))))))

;; get a list of servers with all relevant data
;; ( mod-time host port start-time pid )
;;
(define (server:get-list areapath #!key (limit #f))
  (let ((fname-rx    (regexp "^(|.*/)server-(\\d+)-(\\S+).log$"))
	(day-seconds (* 24 60 60)))
    ;; if the directory exists continue to get the list
    ;; otherwise attempt to create the logs dir and then
    ;; continue
    (if (if (directory-exists? (conc areapath "/logs"))
	    '()
	    (if (file-writable? areapath)
		(begin
		  (condition-case
		   (create-directory (conc areapath "/logs") #t)
		   (exn (i/o file)(debug:print 0 *default-log-port* "ERROR: Cannot create directory at " (conc areapath "/logs")))
		   (exn ()(debug:print 0 *default-log-port* "ERROR: Unknown error attemtping to get server list. exn=" exn)))
		  (directory-exists? (conc areapath "/logs")))
		'()))

        ;; Get the list of server logs that do not contain "exiting". Ignore logs for servers that have exited.
	(let* ((server-logs   (server:get-logs-list areapath))

	       (num-serv-logs (length server-logs)))
	  (if (or (null? server-logs) (= num-serv-logs 0))
              (let ()
                 (debug:print 1  *default-log-port* "There are no servers running")
	         '()
              )
	      (let loop ((hed  (string-chomp (car server-logs)))
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
				(and start-time mod-time
				     (> (- now start-time) 0)    ;; been running at least 0 seconds
				     (< (- now mod-time)   16)   ;; still alive - file touched in last 16 seconds
				     (or (not (configf:lookup *configdat* "server" "runtime")) ;; skip if not set
					 (< (- now start-time)       
					    (+ (- (string->number (configf:lookup *configdat* "server" "runtime"))
					       180)
					    (random 360)))) ;; under one hour running time +/- 180
				     ))
			      #f))
			srvlst)
		(lambda (a b)
		  (< (list-ref a 3)
		     (list-ref b 3))))))
    (if (> (length slst) nums)







|







298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
				(and start-time mod-time
				     (> (- now start-time) 0)    ;; been running at least 0 seconds
				     (< (- now mod-time)   16)   ;; still alive - file touched in last 16 seconds
				     (or (not (configf:lookup *configdat* "server" "runtime")) ;; skip if not set
					 (< (- now start-time)       
					    (+ (- (string->number (configf:lookup *configdat* "server" "runtime"))
					       180)
					    (pseudo-random-integer 360)))) ;; under one hour running time +/- 180
				     ))
			      #f))
			srvlst)
		(lambda (a b)
		  (< (list-ref a 3)
		     (list-ref b 3))))))
    (if (> (length slst) nums)
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
	#f)))

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

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







|







321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
	#f)))

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

(define (server:record->id servr)
  (handle-exceptions
   exn
   (begin 
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
	       (all-go   (> delta reftime)))
	  (if (and all-go
		   (begin
                     (debug:print-info 0 *default-log-port* "Writing " start-flag)
		     (with-output-to-file start-flag
		       (lambda ()
			 (print server-key)))
		     (thread-sleep! 0.25)
		     (let ((res (with-input-from-file start-flag
				  (lambda ()
				    (read-line)))))
		       (equal? server-key res))))
	      #t ;; (system (conc "touch " start-flag)) ;; lazy but safe
	      (begin
		(debug:print-info 0 *default-log-port* "Gating server start, last start: "







|







372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
	       (all-go   (> delta reftime)))
	  (if (and all-go
		   (begin
                     (debug:print-info 0 *default-log-port* "Writing " start-flag)
		     (with-output-to-file start-flag
		       (lambda ()
			 (print server-key)))
		     (thread-sleep! 0.254)
		     (let ((res (with-input-from-file start-flag
				  (lambda ()
				    (read-line)))))
		       (equal? server-key res))))
	      #t ;; (system (conc "touch " start-flag)) ;; lazy but safe
	      (begin
		(debug:print-info 0 *default-log-port* "Gating server start, last start: "
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
	     (call-num     (car last-run-dat))
	     (when-run     (cadr last-run-dat))
	     (run-delay    (+ (case call-num
				((0)    0)
				((1)   20)
				((2)  300)
				(else 600))
			      (random 5)))   ;; add a small random number just in case a lot of jobs hit the work hosts simultaneously
	     (lock-file    (conc areapath "/logs/server-start.lock")))
	(if	(> (- (current-seconds) when-run) run-delay)
		(let* ((start-flag (conc areapath "/logs/server-start-last")))
		  (common:simple-file-lock-and-wait lock-file expire-time: 15)
                  (debug:print-info  0 *default-log-port* "server:kind-run: touching " start-flag)
		  (system (conc "touch " start-flag)) ;; lazy but safe
		  (server:run areapath)







|







400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
	     (call-num     (car last-run-dat))
	     (when-run     (cadr last-run-dat))
	     (run-delay    (+ (case call-num
				((0)    0)
				((1)   20)
				((2)  300)
				(else 600))
			      (pseudo-random-integer 5)))   ;; add a small random number just in case a lot of jobs hit the work hosts simultaneously
	     (lock-file    (conc areapath "/logs/server-start.lock")))
	(if	(> (- (current-seconds) when-run) run-delay)
		(let* ((start-flag (conc areapath "/logs/server-start-last")))
		  (common:simple-file-lock-and-wait lock-file expire-time: 15)
                  (debug:print-info  0 *default-log-port* "server:kind-run: touching " start-flag)
		  (system (conc "touch " start-flag)) ;; lazy but safe
		  (server:run areapath)
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
(define (server:check-if-running areapath) ;;  #!key (numservers "2"))
  (let* ((ns            (server:get-num-servers))
	 (servers       (server:get-best (server:get-list areapath))))
    (if (or (and servers
		 (null? servers))
	    (not servers)
	    (and (list? servers)
		 (< (length servers) (random ns)))) ;; somewhere between 0 and numservers
        #f
        (let loop ((hed (car servers))
                   (tal (cdr servers)))
          (let ((res (server:check-server hed)))
            (if res
                hed
                (if (null? tal)







|







445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
(define (server:check-if-running areapath) ;;  #!key (numservers "2"))
  (let* ((ns            (server:get-num-servers))
	 (servers       (server:get-best (server:get-list areapath))))
    (if (or (and servers
		 (null? servers))
	    (not servers)
	    (and (list? servers)
		 (< (length servers) (pseudo-random-integer ns)))) ;; somewhere between 0 and numservers
        #f
        (let loop ((hed (car servers))
                   (tal (cdr servers)))
          (let ((res (server:check-server hed)))
            (if res
                hed
                (if (null? tal)
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
      (final-sync)

      (if (common:low-noise-print 30)
	  (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)
			    )))))

(define (server:writable-watchdog-deltasync dbstruct)
  (thread-sleep! 0.05) ;; delay for startup
  (let ((legacy-sync  (common:run-sync?))
        (sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300))
	(debug-mode   (debug:debug-mode 1))
	(last-time    (current-seconds))
	(no-sync-db   (db:open-no-sync-db))
	(stmt-cache   (dbr:dbstruct-stmt-cache dbstruct))
        (sync-duration 0) ;; run time of the sync in milliseconds







|







705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
      (final-sync)

      (if (common:low-noise-print 30)
	  (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)
			    )))))

(define (server:writable-watchdog-deltasync dbstruct)
  (thread-sleep! 0.054) ;; delay for startup
  (let ((legacy-sync  (common:run-sync?))
        (sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300))
	(debug-mode   (debug:debug-mode 1))
	(last-time    (current-seconds))
	(no-sync-db   (db:open-no-sync-db))
	(stmt-cache   (dbr:dbstruct-stmt-cache dbstruct))
        (sync-duration 0) ;; run time of the sync in milliseconds

Added servermod.scm version [348a7a1225].











































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
;;======================================================================
;; 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 servermod))

(module servermod
	*
	
(import scheme
	chicken.base
	chicken.string
	chicken.process
	chicken.io
	chicken.time
	
	(prefix sqlite3 sqlite3:)

	typed-records
	srfi-18
	srfi-69
	)

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

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

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

)

Modified stml2.scm from [63b057818a] to [47f316ad28].

17
18
19
20
21
22
23




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

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

(declare (unit stml2))

(include "stml2/stml2.scm")











>
>
>
>
17
18
19
20
21
22
23
24
25
26
27
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

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

(declare (unit stml2))

(include "stml2/stml2.scm")

(import stml2)

(write "true")

Modified stml2/cookie.scm from [d78a525a3a] to [fba413a4c8].

43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
;;   <http://www.netscape.com/newsref/std/cookie_spec.html>

;; (declare (unit cookie))

(module cookie
    *

(import chicken scheme data-structures extras srfi-13 ports posix)
  
(require-extension srfi-1 srfi-13 srfi-14 regex)
;; (use  srfi-1 srfi-13 srfi-14 regex)
;; (declare (export parse-cookie-string construct-cookie-string))

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







|







43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
;;   <http://www.netscape.com/newsref/std/cookie_spec.html>

;; (declare (unit cookie))

(module cookie
    *

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

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

Modified stml2/stml2.scm from [ee4c13898d] to [ccb26a2824].

10
11
12
13
14
15
16
17
18

















19






20
21
22
23

24
25
26
27
28
29
30
;; stml is a list of html strings

;; (declare (unit stml))

(module stml2
    *

(import chicken scheme data-structures extras srfi-13 ports posix srfi-69 files srfi-1) 


















(import cookie)






(use (prefix dbi dbi:) (prefix crypt c:) typed-records)

;; (declare (uses misc-stml))
(use regex)


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







|

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
|

<
<
>







10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44


45
46
47
48
49
50
51
52
;; stml is a list of html strings

;; (declare (unit stml))

(module stml2
    *

  (import

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



    )

;; The (usually global) sdat contains everything about the session
;;
(defstruct sdat
  ;; database
  (dbtype 'pg)
  (dbinit #f)
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
;; to obscure and indirect database ids use one time keys
;;
;;  (s:get-key 'n 1)     => "n99e1882" n=number 99e is the week number since 1970, remainder is random
;;  (s:key->val "n1882") => 1
;;
;;  first letter is a type: n=number, s=string, b=boolean
(define (s:get-key key-type val)
  (let ((mkrandstr (lambda (innum)(number->string (random innum) 16)))
	(week      (number->string (quotient (current-seconds) (* 7 24 60 60)) 16)))
    (let loop ((siz 1000)
	       (key (conc key-type week (mkrandstr 100)))
	       (num 0))
      (if (s:session-var-get key) ;; have a collision
	  (loop (cond                 ;; in the unlikey event we have trouble getting a new var, keep increasing the size of the number
		 ((< num 50)  100)







|







441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
;; to obscure and indirect database ids use one time keys
;;
;;  (s:get-key 'n 1)     => "n99e1882" n=number 99e is the week number since 1970, remainder is random
;;  (s:key->val "n1882") => 1
;;
;;  first letter is a type: n=number, s=string, b=boolean
(define (s:get-key key-type val)
  (let ((mkrandstr (lambda (innum)(number->string (pseudo-random-integer innum) 16)))
	(week      (number->string (quotient (current-seconds) (* 7 24 60 60)) 16)))
    (let loop ((siz 1000)
	       (key (conc key-type week (mkrandstr 100)))
	       (num 0))
      (if (s:session-var-get key) ;; have a collision
	  (loop (cond                 ;; in the unlikey event we have trouble getting a new var, keep increasing the size of the number
		 ((< num 50)  100)
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
#;(define session:valid-chars "abcdefghijklmnopqrstuvwxyz0123456789") ;; cookies are case insensitive.
#;(define session:num-valid-chars (string-length session:valid-chars))

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

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

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

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

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







|














|







669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
#;(define session:valid-chars "abcdefghijklmnopqrstuvwxyz0123456789") ;; cookies are case insensitive.
#;(define session:num-valid-chars (string-length session:valid-chars))

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

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

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

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

;; Rely on crypt egg's default settings being secure enough, accept
;; backwards-compatible OpenSSL crypt passwords too.
;;
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
   ((string? val)  (string->number val))
   ((symbol? val)  (string->number (symbol->string val)))
   (else     #f)))

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

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







|
|







752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
   ((string? val)  (string->number val))
   ((symbol? val)  (string->number (symbol->string val)))
   (else     #f)))

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

(define (s:any->pgint val)
  (let ((n (s:any->number val)))
    (if n
	(if (s:illegal-pgint n)
	    #f
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
	(formdat:load-all-port (current-input-port))
	(make-formdat:formdat))))

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

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







|


|

|







1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
	(formdat:load-all-port (current-input-port))
	(make-formdat:formdat))))

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

      (let ((firstitem   (car alldats))
	    (multipass #f)) 
	(if (and (not (null? firstitem))
		 (not (null? (car firstitem))))
	    (if (string-match formdat:delim-patt-rex (caar firstitem))
		(set! multipass #t)))
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
	    ;; 		       (munged (s:process-cgi-input datstr)))
	    ;; 		  (print "datstr: " datstr " munged: " munged)
	    (if (and (not (null? alldats))
		     (not (null? (car alldats)))
		     (not (null? (caar alldats))))
		(formdat:load formdat  (s:process-cgi-input (caaar alldats))))) ;; munged))
	;;		    (format debugp "formdat : name: ~A content: ~A\n" name content)
	(if debugp (close-output-port debugp))
	;; (sdat-formdat-set! s:session formdat)
	formdat))))
		
#|
(define inp (open-input-file "tests/example.post.in"))
(define dat (read-string #f inp))
(define datstr (open-input-string dat))







|







1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
	    ;; 		       (munged (s:process-cgi-input datstr)))
	    ;; 		  (print "datstr: " datstr " munged: " munged)
	    (if (and (not (null? alldats))
		     (not (null? (car alldats)))
		     (not (null? (caar alldats))))
		(formdat:load formdat  (s:process-cgi-input (caaar alldats))))) ;; munged))
	;;		    (format debugp "formdat : name: ~A content: ~A\n" name content)
	#;(if debugp (close-output-port debugp))
	;; (sdat-formdat-set! s:session formdat)
	formdat))))
		
#|
(define inp (open-input-file "tests/example.post.in"))
(define dat (read-string #f inp))
(define datstr (open-input-string dat))
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
(define session:valid-chars "abcdefghijklmnopqrstuvwxyz0123456789") ;; cookies are case insensitive.
(define session:num-valid-chars (string-length session:valid-chars))

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

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

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

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


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







|














|







1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
(define session:valid-chars "abcdefghijklmnopqrstuvwxyz0123456789") ;; cookies are case insensitive.
(define session:num-valid-chars (string-length session:valid-chars))

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

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

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

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


;;======================================================================
;; P A R A M S
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
      (if debugmode (session:log self "session:setup dbfname=" dbfname ", dbtype=" dbtype ", dbinit=" dbinit))
      (if (eq? dbtype 'sqlite3)
	  ;; The 'auto method will distribute dbs across the disk using hash
	  ;; of user host and user. TODO
	  ;; (if (eq? dbfname 'auto) ;; This is the auto assignment of a db based on hash of IP
	  (let ((dbpath (pathname-directory dbfname)))  ;; do a couple sanity checks here to make setting up easier
	    (if debugmode (session:log self "INFO: setting up for sqlite3 db access to " dbfname))
	    (if (not (file-write-access? dbpath))
		(session:log self "WARNING: Cannot write to " dbpath)
		(if debugmode (session:log self "INFO: " dbpath " is writeable")))
	    (if (file-exists? dbfname)
		(begin
		  ;; (session:log self "setting dbexists to #t")
		  (set! dbexists #t))))
	  (if debugmode (session:log self "INFO: setting up for pg db access to account info " dbinit)))







|







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

Modified subrun.scm from [bd1952a98c] to [e0be46add8].

14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

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

(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) 
     posix-extras directory-utils pathname-expand typed-records format
     call-with-environment-variables)
(declare (unit subrun))
;;(declare (uses runs))
(declare (uses db))
(declare (uses common))
;;(declare (uses items))
;;(declare (uses runconfig))
;;(declare (uses tests))
;;(declare (uses server))
(declare (uses mt))
;;(declare (uses archive))
;; (declare (uses filedb))

;(include "common_records.scm")
;;(include "key_records.scm")
(include "db_records.scm") ;; provides db:test-get-id
;;(include "run_records.scm")
;;(include "test_records.scm")

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








|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|







14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

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

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

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

Modified tasks.scm from [a73c5b318e] to [a6c2485239].

14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;

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

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

(declare (unit tasks))
(declare (uses db))
(declare (uses rmt))
(declare (uses common))
(declare (uses pgdb))

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

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

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







|
|
|
|
|
|
|
|







14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;

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

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

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

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

;;======================================================================
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
	     (print-call-chain (current-error-port))
	     (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
	     (debug:print 5 *default-log-port* " exn=" (condition->list exn))))
       (let* ((dbpath        (db:dbfile-path )) ;; (tasks:get-task-db-path))
	      (dbfile       (conc dbpath "/monitor.db"))
	      (avail        (tasks:wait-on-journal dbpath 10)) ;; wait up to about 10 seconds for the journal to go away
	      (exists       (common:file-exists? dbpath))
	      (write-access (file-write-access? dbpath))
	      (mdb          (cond ;; what the hek is *toppath* doing here?
			     ((and (string? *toppath*)(file-write-access? *toppath*))
			      (sqlite3:open-database dbfile))
			     ((file-read-access? dbpath)    (sqlite3:open-database dbfile))
			     (else (sqlite3:open-database ":memory:")))) ;; (never-give-up-open-db dbpath))
	      (handler      (sqlite3:make-busy-timeout 36000)))
	 (if (and exists
		  (not write-access))
	     (set! *db-write-access* write-access)) ;; only unset so other db's also can use this control
	 (sqlite3:set-busy-handler! mdb handler)
	 (db:set-sync mdb) ;; (sqlite3:execute mdb (conc "PRAGMA synchronous = 0;"))
	 ;;  (if (or (and (not exists)
	 ;; 	      (file-write-access? *toppath*))
	 ;; 	 (not (file-read-access? dbpath)))
	 ;;      (begin
	 ;; 
	 ;; TASKS QUEUE MOVED TO main.db
	 ;;
	 ;; (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY,
         ;;                        action TEXT DEFAULT '',
         ;;                        owner TEXT,







|

|

|








|
|







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

Modified tdb.scm from [6edff6262d] to [c7832c1d4c].

18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
;;
;;======================================================================

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

(require-extension (srfi 18) extras tcp)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))

(declare (unit tdb))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
(declare (uses client))
(declare (uses mt))
(declare (uses db))

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

;;======================================================================
;;
;; T E S T   D A T A B A S E S
;;
;;======================================================================

;;======================================================================
;; T E S T   S P E C I F I C   D B 
;;======================================================================

;; Create the sqlite db for the individual test(s)
;;
;; Moved these tables into <runid>.db
;; THIS CODE TO BE REMOVED
;;
(define (open-test-db work-area) 
  (debug:print-info 11 *default-log-port* "open-test-db " work-area)
  (if (and work-area 
	   (directory? work-area)
	   (file-read-access? work-area))
      (let* ((dbpath              (conc work-area "/testdat.db"))
	     (dbexists            (common:file-exists? dbpath))
	     (work-area-writeable (file-write-access? work-area))
	     (db                  (handle-exceptions  ;; open the db if area writeable or db pre-existing. open in-mem otherwise. if exception, open in-mem
				   exn
				   (begin
				     (print-call-chain (current-error-port))
				     (debug:print 2 *default-log-port* "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test"
						  ((condition-property-accessor 'exn 'message) exn))
				     (set! dbexists #f) ;; must force re-creation of tables, more tom-foolery
				     (sqlite3:open-database ":memory:")) ;; open an in-memory db to allow readonly access 
				   (if (or work-area-writeable
					   dbexists)
				       (sqlite3:open-database dbpath)
				       (sqlite3:open-database ":memory:"))))
	     (tdb-writeable       (and (file-write-access? work-area)
				       (file-write-access? dbpath)))
	     (handler   (sqlite3:make-busy-timeout (if (args:get-arg "-override-timeout")
						       (string->number (args:get-arg "-override-timeout"))
						       136000))))
	
	(if (and tdb-writeable
		 *db-write-access*)
	    (sqlite3:set-busy-handler! db handler))







|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|




















|


|












|
|







18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
;;
;;======================================================================

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

;; (require-extension (srfi 18) extras tcp)
;; (use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64)
;; (import (prefix sqlite3 sqlite3:))
;; (import (prefix base64 base64:))
;; 
;; (declare (unit tdb))
;; (declare (uses common))
;; (declare (uses keys))
;; (declare (uses ods))
;; (declare (uses client))
;; (declare (uses mt))
;; (declare (uses db))
;; 
;; (include "common_records.scm")
;; (include "db_records.scm")
;; (include "key_records.scm")
;; (include "run_records.scm")

;;======================================================================
;;
;; T E S T   D A T A B A S E S
;;
;;======================================================================

;;======================================================================
;; T E S T   S P E C I F I C   D B 
;;======================================================================

;; Create the sqlite db for the individual test(s)
;;
;; Moved these tables into <runid>.db
;; THIS CODE TO BE REMOVED
;;
(define (open-test-db work-area) 
  (debug:print-info 11 *default-log-port* "open-test-db " work-area)
  (if (and work-area 
	   (directory? work-area)
	   (file-readable? work-area))
      (let* ((dbpath              (conc work-area "/testdat.db"))
	     (dbexists            (common:file-exists? dbpath))
	     (work-area-writeable (file-writable? work-area))
	     (db                  (handle-exceptions  ;; open the db if area writeable or db pre-existing. open in-mem otherwise. if exception, open in-mem
				   exn
				   (begin
				     (print-call-chain (current-error-port))
				     (debug:print 2 *default-log-port* "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test"
						  ((condition-property-accessor 'exn 'message) exn))
				     (set! dbexists #f) ;; must force re-creation of tables, more tom-foolery
				     (sqlite3:open-database ":memory:")) ;; open an in-memory db to allow readonly access 
				   (if (or work-area-writeable
					   dbexists)
				       (sqlite3:open-database dbpath)
				       (sqlite3:open-database ":memory:"))))
	     (tdb-writeable       (and (file-writable? work-area)
				       (file-writable? dbpath)))
	     (handler   (sqlite3:make-busy-timeout (if (args:get-arg "-override-timeout")
						       (string->number (args:get-arg "-override-timeout"))
						       136000))))
	
	(if (and tdb-writeable
		 *db-write-access*)
	    (sqlite3:set-busy-handler! db handler))

Modified tests.scm from [58a365a2ab] to [ef56b9a810].

18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
;;
;;======================================================================

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

(declare (unit tests))
(declare (uses lock-queue))
(declare (uses db))
(declare (uses tdb))
(declare (uses common))
;; (declare (uses dcommon)) ;; needed for the steps processing
(declare (uses items))
(declare (uses runconfig))
;; (declare (uses sdb))
(declare (uses server))
;;(declare (uses stml2))

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

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
(include "js-path.scm")

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

;; Call this one to do all the work and get a standardized list of tests







|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|







18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
;;
;;======================================================================

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

;; (declare (unit tests))
;; (declare (uses lock-queue))
;; (declare (uses db))
;; (declare (uses tdb))
;; (declare (uses common))
;; ;; (declare (uses dcommon)) ;; needed for the steps processing
;; (declare (uses items))
;; (declare (uses runconfig))
;; ;; (declare (uses sdb))
;; (declare (uses server))
;; ;;(declare (uses stml2))
;; 
;; (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils)
;; (import (prefix sqlite3 sqlite3:))
;; (require-library stml)
;; 
;; (include "common_records.scm")
;; (include "key_records.scm")
;; (include "db_records.scm")
;; (include "run_records.scm")
;; (include "test_records.scm")
(include "js-path.scm")

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

;; Call this one to do all the work and get a standardized list of tests
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
				       (begin
					 (print "failed to get mod time on " lockf ", exn=" exn)
					 0)
				       (file-modification-time lockf)))
		    ;; we started since current re-gen in flight, delay a little and try again
		    (begin
		      (debug:print-info 1 *default-log-port* "Waiting to update " outputfilename ", another test currently updating it")
		      (thread-sleep! (+ 5 (random 5))) ;; delay between 5 and 10 seconds
		      (loop (common:simple-file-lock lockf))))))))))

(define (tests:generate-html-summary-for-iterated-test run-id test-id test-name outputfilename)
  (let ((counts              (make-hash-table))
	(statecounts         (make-hash-table))
	(outtxt              "")
	(tot                 0)







|







557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
				       (begin
					 (print "failed to get mod time on " lockf ", exn=" exn)
					 0)
				       (file-modification-time lockf)))
		    ;; we started since current re-gen in flight, delay a little and try again
		    (begin
		      (debug:print-info 1 *default-log-port* "Waiting to update " outputfilename ", another test currently updating it")
		      (thread-sleep! (+ 5 (pseudo-random-integer 5))) ;; delay between 5 and 10 seconds
		      (loop (common:simple-file-lock lockf))))))))))

(define (tests:generate-html-summary-for-iterated-test run-id test-id test-name outputfilename)
  (let ((counts              (make-hash-table))
	(statecounts         (make-hash-table))
	(outtxt              "")
	(tot                 0)
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
	       (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links #f run-patt target-patt)) ;; update this function
	      (close-output-port oup)
					; (set! page (+ 1 page))
	      (if (> total-runs (* (+ 1 page) pg-size))
		  (loop (+ 1  page)))))
	  (common:simple-file-release-lock lockfile))
	(begin
	  (debug-print 0 *default-log-port* "Failed to get lock on file outf, lockfile: " lockfile) #f))))


(define (tests:readlines filename)
  (call-with-input-file filename
    (lambda (p)
      (let loop ((line (read-line p))
                 (result '()))







|







907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
	       (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links #f run-patt target-patt)) ;; update this function
	      (close-output-port oup)
					; (set! page (+ 1 page))
	      (if (> total-runs (* (+ 1 page) pg-size))
		  (loop (+ 1  page)))))
	  (common:simple-file-release-lock lockfile))
	(begin
	  (debug:print 0 *default-log-port* "Failed to get lock on file outf, lockfile: " lockfile) #f))))


(define (tests:readlines filename)
  (call-with-input-file filename
    (lambda (p)
      (let loop ((line (read-line p))
                 (result '()))
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
						      '()
						      (lambda (x p)
							(let* ((targ-path (string-intersperse p "/"))
                                                               (full-path (conc linktree "/" targ-path))
                                                               (run-name  (car (reverse p))))
                                                          (if (and (common:file-exists? full-path)
                                                                   (directory?   full-path)
                                                                   (file-write-access? full-path))
                                                              (s:a run-name 'href (conc targ-path "/run-summary.html"))
                                                              (begin
                                                                (debug:print 0 *default-log-port* "INFO: Can't create " targ-path "/run-summary.html")
                                                                (conc run-name " (Not able to create summary at " targ-path ")")))))))))))
          (close-output-port oup)
	  (common:simple-file-release-lock lockfile)
               







|







1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
						      '()
						      (lambda (x p)
							(let* ((targ-path (string-intersperse p "/"))
                                                               (full-path (conc linktree "/" targ-path))
                                                               (run-name  (car (reverse p))))
                                                          (if (and (common:file-exists? full-path)
                                                                   (directory?   full-path)
                                                                   (file-writable? full-path))
                                                              (s:a run-name 'href (conc targ-path "/run-summary.html"))
                                                              (begin
                                                                (debug:print 0 *default-log-port* "INFO: Can't create " targ-path "/run-summary.html")
                                                                (conc run-name " (Not able to create summary at " targ-path ")")))))))))))
          (close-output-port oup)
	  (common:simple-file-release-lock lockfile)
               
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
                                           path-parts))
                                       test-dats))
                    (tests-htree (common:list->htree tests-tree-dat))
                    (html-dir    (conc linktree "/" (string-intersperse run-dir "/")))
                    (html-path   (conc html-dir "/run-summary.html"))
                    (oup         (if (and (common:file-exists? html-dir)
                                          (directory?   html-dir)
                                          (file-write-access? html-dir))
                                     (open-output-file  html-path)
                                     #f)))
               ;; (print "run-dir: " run-dir ", tests-tree-dat: " tests-tree-dat)
               (if oup
                   (begin
                     (s:output-new
                      oup







|







1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
                                           path-parts))
                                       test-dats))
                    (tests-htree (common:list->htree tests-tree-dat))
                    (html-dir    (conc linktree "/" (string-intersperse run-dir "/")))
                    (html-path   (conc html-dir "/run-summary.html"))
                    (oup         (if (and (common:file-exists? html-dir)
                                          (directory?   html-dir)
                                          (file-writable? html-dir))
                                     (open-output-file  html-path)
                                     #f)))
               ;; (print "run-dir: " run-dir ", tests-tree-dat: " tests-tree-dat)
               (if oup
                   (begin
                     (s:output-new
                      oup
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
                                                                          (alt-file  (conc full-targ "/megatest-rollup-" test-name ".html"))
                                                                          (html-file (if (common:file-exists? alt-file)
                                                                                         alt-file
                                                                                         std-file))
                                                                          (run-name  (car (reverse p))))
                                                                     (if (and (not (common:file-exists? full-targ))
                                                                              (directory? full-targ)
                                                                              (file-write-access? full-targ))
                                                                         (tests:summarize-test 
                                                                          run-id 
                                                                          (rmt:get-test-id run-id test-name item-path)))
                                                                     (if (common:file-exists? full-targ)
                                                                         (s:a run-name 'href html-file)
                                                                         (begin
                                                                           (debug:print 0 *default-log-port* "ERROR: can't access " full-targ)







|







1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
                                                                          (alt-file  (conc full-targ "/megatest-rollup-" test-name ".html"))
                                                                          (html-file (if (common:file-exists? alt-file)
                                                                                         alt-file
                                                                                         std-file))
                                                                          (run-name  (car (reverse p))))
                                                                     (if (and (not (common:file-exists? full-targ))
                                                                              (directory? full-targ)
                                                                              (file-writable? full-targ))
                                                                         (tests:summarize-test 
                                                                          run-id 
                                                                          (rmt:get-test-id run-id test-name item-path)))
                                                                     (if (common:file-exists? full-targ)
                                                                         (s:a run-name 'href html-file)
                                                                         (begin
                                                                           (debug:print 0 *default-log-port* "ERROR: can't access " full-targ)
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
;;
(define (tests:save-final-status run-id test-id)
  (let* ((test-dat  (rmt:get-test-info-by-id run-id test-id))
	 (out-dir   (db:test-get-rundir test-dat))
	 (status-file  (conc out-dir "/.final-status"))
   )
    ;; first verify we are able to write the output file
    (if (not (file-write-access? out-dir))
	    (debug:print 0 *default-log-port* "ERROR: cannot write .final-status to " out-dir)
	    (let* 
         ((outp      (open-output-file status-file))
	       (status    (db:test-get-status   test-dat))
         (state     (db:test-get-state    test-dat)))
        (fprintf outp "~S\n" state) 
        (fprintf outp "~S\n" status) 
        (close-output-port outp)))))


;; summarize test in to a file test-summary.html in the test directory
;;
(define (tests:summarize-test run-id test-id)
  (let* ((test-dat  (rmt:get-test-info-by-id run-id test-id))
	 (out-dir   (db:test-get-rundir test-dat))
	 (out-file  (conc out-dir "/test-summary.html")))
    ;; first verify we are able to write the output file
    (if (not (file-write-access? out-dir))
	(debug:print 0 *default-log-port* "ERROR: cannot write test-summary.html to " out-dir)
	(let* (;; (steps-dat (rmt:get-steps-for-test run-id test-id))
	       (test-name (db:test-get-testname test-dat))
	       (item-path (db:test-get-item-path test-dat))
	       (full-name (db:test-make-full-name test-name item-path))
	       (oup       (open-output-file out-file))
	       (status    (db:test-get-status   test-dat))







|

















|







1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
;;
(define (tests:save-final-status run-id test-id)
  (let* ((test-dat  (rmt:get-test-info-by-id run-id test-id))
	 (out-dir   (db:test-get-rundir test-dat))
	 (status-file  (conc out-dir "/.final-status"))
   )
    ;; first verify we are able to write the output file
    (if (not (file-writable? out-dir))
	    (debug:print 0 *default-log-port* "ERROR: cannot write .final-status to " out-dir)
	    (let* 
         ((outp      (open-output-file status-file))
	       (status    (db:test-get-status   test-dat))
         (state     (db:test-get-state    test-dat)))
        (fprintf outp "~S\n" state) 
        (fprintf outp "~S\n" status) 
        (close-output-port outp)))))


;; summarize test in to a file test-summary.html in the test directory
;;
(define (tests:summarize-test run-id test-id)
  (let* ((test-dat  (rmt:get-test-info-by-id run-id test-id))
	 (out-dir   (db:test-get-rundir test-dat))
	 (out-file  (conc out-dir "/test-summary.html")))
    ;; first verify we are able to write the output file
    (if (not (file-writable? out-dir))
	(debug:print 0 *default-log-port* "ERROR: cannot write test-summary.html to " out-dir)
	(let* (;; (steps-dat (rmt:get-steps-for-test run-id test-id))
	       (test-name (db:test-get-testname test-dat))
	       (item-path (db:test-get-item-path test-dat))
	       (full-name (db:test-make-full-name test-name item-path))
	       (oup       (open-output-file out-file))
	       (status    (db:test-get-status   test-dat))
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
                                             local-tcdir
                                             #f))
				       (conc *toppath* "/tests/" test-name)))
		     (test-configf (conc test-path "/testconfig"))
		     (testexists   (let loopa ((tries-left 30))
                                     (cond
                                      (
                                       (and (common:file-exists? test-configf)(file-read-access? test-configf))
                                       #t)
                                      (
                                       (common:file-exists? test-configf)
                                       (debug:print 0 *default-log-port* "WARNING: Cannot read testconfig file: "test-configf)
                                       #f)
                                      (
                                       (and wait-a-minute (> tries-left 0))







|







1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
                                             local-tcdir
                                             #f))
				       (conc *toppath* "/tests/" test-name)))
		     (test-configf (conc test-path "/testconfig"))
		     (testexists   (let loopa ((tries-left 30))
                                     (cond
                                      (
                                       (and (common:file-exists? test-configf)(file-readable? test-configf))
                                       #t)
                                      (
                                       (common:file-exists? test-configf)
                                       (debug:print 0 *default-log-port* "WARNING: Cannot read testconfig file: "test-configf)
                                       #f)
                                      (
                                       (and wait-a-minute (> tries-left 0))
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
								      "pre-launch-env-vars"
								      #f))
				       #f)))
		(if (and tcfg cache-file) (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data
		(if tcfg (hash-table-set! *testconfigs* test-full-name tcfg))
		(if (and testexists
			 cache-file
			 (file-write-access? cache-path)
			 allow-write-cache)
		    (let ((tpath (conc cache-path "/.testconfig")))
		      (debug:print-info 1 *default-log-port* "Caching testconfig for " test-name " in " tpath)
                      (if (and tcfg (not (common:in-running-test?)))
                          (configf:write-alist tcfg tpath))))
		tcfg))))))
  







|







1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
								      "pre-launch-env-vars"
								      #f))
				       #f)))
		(if (and tcfg cache-file) (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data
		(if tcfg (hash-table-set! *testconfigs* test-full-name tcfg))
		(if (and testexists
			 cache-file
			 (file-writable? cache-path)
			 allow-write-cache)
		    (let ((tpath (conc cache-path "/.testconfig")))
		      (debug:print-info 1 *default-log-port* "Caching testconfig for " test-name " in " tpath)
                      (if (and tcfg (not (common:in-running-test?)))
                          (configf:write-alist tcfg tpath))))
		tcfg))))))
  
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
       (conc "env -i PATH=$PATH dot -T" outtype " < " temp-path)
       (lambda ()
	 (let ((res (read-lines)))
	   ;; (delete-file temp-path)
	   res))))))

(define (tests:write-dot-file test-records fname sizex sizey)
  (if (file-write-access? (pathname-directory fname))
      (with-output-to-file fname
	(lambda ()
	  (map print (tests:tests->dot test-records sizex sizey))))))

(define (tests:tests->dot test-records sizex sizey)
  (let ((all-testnames (hash-table-keys test-records)))
    (if (null? all-testnames)







|







1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
       (conc "env -i PATH=$PATH dot -T" outtype " < " temp-path)
       (lambda ()
	 (let ((res (read-lines)))
	   ;; (delete-file temp-path)
	   res))))))

(define (tests:write-dot-file test-records fname sizex sizey)
  (if (file-writable? (pathname-directory fname))
      (with-output-to-file fname
	(lambda ()
	  (map print (tests:tests->dot test-records sizex sizey))))))

(define (tests:tests->dot test-records sizex sizey)
  (let ((all-testnames (hash-table-keys test-records)))
    (if (null? all-testnames)

Modified vg.scm from [48b3b2908c] to [d31bf89ee1].

377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
    (arithmetic-shift r 16)
    (arithmetic-shift g 8)
    b))

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

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

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

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







|
|
|




|
|
|







377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
    (arithmetic-shift r 16)
    (arithmetic-shift g 8)
    b))

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

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

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

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

Added vgmod.scm version [2e376f7175].

































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
;;
;; Copyright 2016  Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

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

(declare (unit vgmod))

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

(include "vg_records.scm")

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

;; register lib with drawing

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

)

Deleted widgets.scm version [3a32b6256a].

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
;;  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)
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<