Megatest

Changes On Branch 73734120c5a2aea9
Login

Changes In Branch v1.60 Through [73734120c5] Excluding Merge-Ins

This is equivalent to a diff from b541c8f3a1 to 73734120c5

2015-03-27
11:22
Cleaned up batchsim check-in: 47f6163e4c user: mrwellan tags: v1.60
10:16
Added batchsim check-in: 73734120c5 user: mrwellan tags: v1.60
2015-03-25
10:06
Merged in bash4 fix check-in: 7cf45fd3fa user: mrwellan tags: v1.60
2015-03-23
23:56
nada check-in: 810dd1492f user: matt tags: v1.60
2015-03-13
00:38
Basic dump to json from list-runs check-in: 1753b52784 user: matt tags: v1.55
2015-02-03
22:14
Cherrypicked test path reordering per Tal's request. check-in: b541c8f3a1 user: matt tags: v1.55, v1.5525
2014-11-18
15:41
Tweaked installall.sh for a RedHat install check-in: cbcc0afda3 user: mrwellan tags: v1.55

Modified Makefile from [660e49132a] to [a4b4fe5222].

1
2
3
4
5
6
7
8
9
10
11


12
13
14
15
16
17
18
# make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)'
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 megatest-version.scm \
           process.scm runs.scm tasks.scm tests.scm genexample.scm \
	   fs-transport.scm http-transport.scm \
           client.scm gutils.scm synchash.scm daemon.scm mt.scm dcommon.scm \
	   tree.scm ezsteps.scm lock-queue.scm sdb.scm



# Eggs to install (straightforward ones)
EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \
     dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \
     json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \
     spiffy-directory-listing ssax sxml-serializer sxml-modifications iup canvas-draw sqlite3









|

|
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)'
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 megatest-version.scm \
           process.scm runs.scm tasks.scm tests.scm genexample.scm \
	   http-transport.scm nmsg-transport.scm filedb.scm \
           client.scm gutils.scm synchash.scm daemon.scm mt.scm dcommon.scm \
	   tree.scm ezsteps.scm lock-queue.scm sdb.scm \
	   rmt.scm api.scm tdb.scm rpc-transport.scm \
	   portlogger.scm archive.scm

# Eggs to install (straightforward ones)
EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \
     dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \
     json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \
     spiffy-directory-listing ssax sxml-serializer sxml-modifications iup canvas-draw sqlite3

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
CKPATH=$(shell dirname $(shell dirname $(CSIPATH)))
# ARCHSTR=$(shell uname -m)_$(shell uname -r)
# BASH_MACHTYPE=$(shell bash -c "echo \$$MACHTYPE")
# ARCHSTR=$(BASH_MACHTYPE)_$(shell lsb_release -sr)
ARCHSTR=$(shell lsb_release -sr)
# ARCHSTR=$(shell bash -c "echo \$$MACHTYPE")

all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard txtdb

refdb : txtdb/txtdb.scm
	csc -I txtdb txtdb/txtdb.scm -o refdb

mtest: $(OFILES) megatest.o
	csc $(CSCOPTS) $(OFILES) megatest.o -o mtest

dboard : $(OFILES) $(GOFILES) dashboard.scm
	csc $(OFILES) dashboard.scm $(GOFILES) -o dboard

# newdboard : newdashboard.scm $(OFILES) $(GOFILES)
# 	csc $(OFILES) $(GOFILES) newdashboard.scm -o newdboard

# 
# $(PREFIX)/bin/revtagfsl : utils/revtagfsl.scm
#	csc utils/revtagfsl.scm -o $(PREFIX)/bin/revtagfsl

# Special dependencies for the includes
tests.o db.o launch.o runs.o dashboard-tests.o dashboard-guimonitor.o dashboard-main.o monitor.o dashboard.o megatest.o : db_records.scm

tests.o runs.o dashboard.o dashboard-tests.o dashboard-main.o  : run_records.scm
db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm
tests.o tasks.o dashboard-tasks.o : task_records.scm
runs.o : test_records.scm
megatest.o : megatest-fossil-hash.scm


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

megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm
	echo "(define megatest-fossil-hash \"$(MTESTHASH)\")" > megatest-fossil-hash.new
	if ! diff -q megatest-fossil-hash.new megatest-fossil-hash.scm ; then echo copying .new to .scm;cp -f megatest-fossil-hash.new megatest-fossil-hash.scm;fi

$(OFILES) $(GOFILES) : common_records.scm 

%.o : %.scm
	csc $(CSCOPTS) -c $<

$(PREFIX)/bin/.$(ARCHSTR)/mtest : mtest
	@echo Installing to PREFIX=$(PREFIX)
	$(INSTALL) mtest $(PREFIX)/bin/.$(ARCHSTR)/mtest
	utils/mk_wrapper $(PREFIX) mtest $(PREFIX)/bin/megatest
	chmod a+x $(PREFIX)/bin/megatest

# $(PREFIX)/bin/newdboard : newdboard
# 	$(INSTALL) newdboard $(PREFIX)/bin/newdboard


# 	utils/mk_wrapper $(PREFIX) newdboard $(PREFIX)/bin/newdashboard
#	chmod a+x $(PREFIX)/bin/newdashboard

$(HELPERS) : utils/mt_* 












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

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

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

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

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

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

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

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


# install dashboard as dboard so wrapper script can be called dashboard
$(PREFIX)/bin/.$(ARCHSTR)/dboard : dboard $(FILES)
	utils/mk_wrapper $(PREFIX) dboard $(PREFIX)/bin/dashboard
	chmod a+x $(PREFIX)/bin/dashboard
	$(INSTALL) dboard $(PREFIX)/bin/.$(ARCHSTR)/dboard

install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \

          $(PREFIX)/bin/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/refdb $(PREFIX)/bin/mt_xterm


$(PREFIX)/bin/.$(ARCHSTR) : 
	mkdir -p $(PREFIX)/bin/.$(ARCHSTR)

test: tests/tests.scm
	cd tests;csi -I .. -b -n tests.scm








|
<
<
<







|
|
>





|
>





>



















|
|
>
>
|
|

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



















|
|
|
















|
>
|
>







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
CKPATH=$(shell dirname $(shell dirname $(CSIPATH)))
# ARCHSTR=$(shell uname -m)_$(shell uname -r)
# BASH_MACHTYPE=$(shell bash -c "echo \$$MACHTYPE")
# ARCHSTR=$(BASH_MACHTYPE)_$(shell lsb_release -sr)
ARCHSTR=$(shell lsb_release -sr)
# ARCHSTR=$(shell bash -c "echo \$$MACHTYPE")

all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard 




mtest: $(OFILES) megatest.o
	csc $(CSCOPTS) $(OFILES) megatest.o -o mtest

dboard : $(OFILES) $(GOFILES) dashboard.scm
	csc $(OFILES) dashboard.scm $(GOFILES) -o dboard

ndboard : newdashboard.scm $(OFILES) $(GOFILES)
	csc $(OFILES) $(GOFILES) newdashboard.scm -o ndboard

# 
# $(PREFIX)/bin/revtagfsl : utils/revtagfsl.scm
#	csc utils/revtagfsl.scm -o $(PREFIX)/bin/revtagfsl

# Special dependencies for the includes
tests.o db.o launch.o runs.o dashboard-tests.o dashboard-guimonitor.o dashboard-main.o monitor.o dashboard.o  \
  archive.o megatest.o : db_records.scm
tests.o runs.o dashboard.o dashboard-tests.o dashboard-main.o  : run_records.scm
db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm
tests.o tasks.o dashboard-tasks.o : task_records.scm
runs.o : test_records.scm
megatest.o : megatest-fossil-hash.scm
client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm zmq-transport.scm : common_records.scm rpc-transport.scm

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

megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm
	echo "(define megatest-fossil-hash \"$(MTESTHASH)\")" > megatest-fossil-hash.new
	if ! diff -q megatest-fossil-hash.new megatest-fossil-hash.scm ; then echo copying .new to .scm;cp -f megatest-fossil-hash.new megatest-fossil-hash.scm;fi

$(OFILES) $(GOFILES) : common_records.scm 

%.o : %.scm
	csc $(CSCOPTS) -c $<

$(PREFIX)/bin/.$(ARCHSTR)/mtest : mtest
	@echo Installing to PREFIX=$(PREFIX)
	$(INSTALL) mtest $(PREFIX)/bin/.$(ARCHSTR)/mtest
	utils/mk_wrapper $(PREFIX) mtest $(PREFIX)/bin/megatest
	chmod a+x $(PREFIX)/bin/megatest

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

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

# $(HELPERS) : utils/%
# 	$(INSTALL) $< $@
# 	chmod a+x $@

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

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

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

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

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

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

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

# $(PREFIX)/bin/refdb : refdb
# 	$(INSTALL) $< $@
# 	chmod a+x $@

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

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


# install dashboard as dboard so wrapper script can be called dashboard
$(PREFIX)/bin/.$(ARCHSTR)/dboard : dboard $(FILES)
	utils/mk_wrapper $(PREFIX) dboard $(PREFIX)/bin/dashboard
	chmod a+x $(PREFIX)/bin/dashboard
	$(INSTALL) dboard $(PREFIX)/bin/.$(ARCHSTR)/dboard

install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \
          $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \
	  $(PREFIX)/bin/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/mt_xterm \
          $(PREFIX)/bin/newdashboard

$(PREFIX)/bin/.$(ARCHSTR) : 
	mkdir -p $(PREFIX)/bin/.$(ARCHSTR)

test: tests/tests.scm
	cd tests;csi -I .. -b -n tests.scm

161
162
163
164
165
166
167
168

169
170
171
172

173



	csc -deploy $(CSCOPTS) $(OFILES) megatest.scm -o deploytarg
	mv deploytarg/deploytarg deploytarg/mtest

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

DATASHAREO=configf.o common.o process.o

datashare-testing/datashare : datashare.scm $(DATASHAREO)
	csc datashare.scm $(DATASHAREO) -o datashare-testing/datashare

datashare : datashare-testing/datashare

	./datashare-testing/datashare










|
>
|
|

|
>
|
>
>
>
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
	csc -deploy $(CSCOPTS) $(OFILES) megatest.scm -o deploytarg
	mv deploytarg/deploytarg deploytarg/mtest

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

# DATASHAREO=configf.o common.o process.o tree.o dcommon.o margs.o launch.o gutils.o db.o synchash.o server.o \
#            megatest-version.o tdb.o ods.o mt.o keys.o
datashare-testing/sd : datashare.scm $(OFILES)
	csc datashare.scm $(OFILES) -o datashare-testing/sd

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

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

Modified NOTES from [f5959ca38f] to [8d1d854887].







































































1
2
3
4
5
6
7







































































[87cbe68f31] 
[be405e8e2e]

# FROM andyjpg on #chicken

(let ((original-exit (exit-handler)))
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







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
======================================================================
Try writing to in-memory db and every 2-5 seconds syncing to megatest.db
======================================================================

First, how much time will it take to write back the changes:

1. Get the run table

(define (get-all db)(let ((res '()))(for-each-row (lambda (a . b)(set! res (cons (apply vector a b) res))) db "SELECT * FROM tests;") res))
(define tdata (let ((start (current-milliseconds))(res (get-all *db*)))(print (- (current-milliseconds) start))res))

Result ranges from 34ms to 89ms but mostly around 40ms for 623 records on moosefs

Projecting to 15000 records:

  Slow   2 seconds to read all
  Median 1 second to read all

This seems like it would work with an update period of 2-5 seconds

TODO
----

1. open-db opens in-memory db and megatest.db, put handles in *memdb* and *db*, *memdb* is < run-id dbh >
2. Server is part of runtests 
   a. server start cycle - adapt to per run-id
      i. states; starting, started, stopping, stopped
   b. turn off write coalesing
3. Calls to -runtests, -remove-runs etc. 
   a. Might talk to running server if run specific
   b. Can talk to megatest.db but not a generally good idea
   c. Can start a runserver 
4. Dashboard is fine except for writes?

======================================================================
Routines to convert for runs.scm

cdb:remote-run db:register-run

cdb:delete-tests-in-state *runremote*
cdb:get-test-info-by-id *runremote*
cdb:remote-run db:delete-old-deleted-test-records
cdb:remote-run db:delete-run
cdb:remote-run db:delete-test-records
cdb:remote-run db:delete-tests-for-run
cdb:remote-run db:find-and-mark-incomplete
cdb:remote-run db:get-count-tests-running
cdb:remote-run db:get-count-tests-running-in-jobgroup
cdb:remote-run db:get-keys
cdb:remote-run db:get-run-info
cdb:remote-run db:get-run-key-val
cdb:remote-run db:get-run-name-from-id
cdb:remote-run db:get-steps-for-test
cdb:remote-run db:get-test-id-cached
cdb:remote-run db:get-tests-for-runs-mindata
cdb:remote-run db:lock/unlock-run
cdb:remote-run db:set-sync
cdb:remote-run db:set-tests-state-status
cdb:remote-run db:set-var
cdb:remote-run db:testmeta-add-record
cdb:remote-run db:testmeta-get-record
cdb:remote-run db:testmeta-update-field
cdb:remote-run db:update-run-event_time
cdb:remote-run instead
cdb:remote-run server:start
cdb:remote-run test:get-matching-previous-test-run-records
cdb:tests-register-test *runremote*
(define (runs:shrink-can-run-more-tests-count) ;; the db is a dummy var so we can use cdb:remote-run

======================================================================

[87cbe68f31] 
[be405e8e2e]

# FROM andyjpg on #chicken

(let ((original-exit (exit-handler)))

Modified TODO from [61ddd55e7d] to [249cc9a526].

1


2
3

4








1. Confirm that branch transaction-for-sequential-writes content was added to trunk/development
2. Add a host chooser for ssh to launch-tests

3. Try making static executable






>
>
|
|
>
|
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12

TODO
====

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

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

Added api.scm version [8963db51e7].











































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
;;======================================================================
;; Copyright 2006-2013, 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.
;;======================================================================

(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-keys
    test-toplevel-num-items
    get-test-info-by-id
    test-get-rundir-from-test-id
    get-count-tests-running-for-testname
    get-count-tests-running
    get-count-tests-running-in-jobgroup
    get-previous-test-run-record
    get-matching-previous-test-run-records
    test-get-logfile-info
    test-get-records-for-index-file
    get-testinfo-state-status
    test-get-top-process-pid
    test-get-paths-matching-keynames-target-new
    get-prereqs-not-met
    get-count-tests-running-for-run-id
    get-run-info
    get-run-status
    register-run
    get-tests-for-run
    get-test-id
    get-tests-for-runs-mindata
    get-run-name-from-id
    get-runs
    get-all-run-ids
    get-prev-run-ids
    get-run-ids-matching-target
    get-runs-by-patt
    get-steps-data
    get-steps-for-test
    login
    testmeta-get-record
    have-incompletes?
    synchash-get
    ))

(define api:write-queries
  '(
    ;; SERVERS
    start-server
    kill-server

    ;; TESTS
    test-set-state-status-by-id
    delete-test-records
    delete-old-deleted-test-records
    test-set-status-state
    test-set-top-process-pid
    roll-up-pass-fail-counts
    update-fail-pass-counts

    ;; RUNS
    register-run
    set-tests-state-status
    delete-run
    lock/unlock-run
    update-run-event_time
    mark-incomplete

    ;; STEPS
    teststep-set-status!

    ;; TEST DATA
    test-data-rollup
    csv->test-data

    ;; MISC
    sync-inmem->db

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

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

;; These are called by the server on recipt of /api calls
;;    - keep it simple, only return the actual result of the call, i.e. no meta info here
;;
;;    - returns #( flag result )
;;
(define (api:execute-requests dbstruct dat)
  (handle-exceptions
   exn
   (let ((call-chain (get-call-chain)))
     (print-call-chain (current-error-port))
     (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))       
     (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens
   (if (not (vector? dat))                    ;; it is an error to not receive a vector
       (vector #f #f "remote must be called with a vector")       
       (vector                                   ;; return a vector + the returned data structure
	#t 
	(let ((cmd    (vector-ref dat 0))
	      (params (vector-ref dat 1)))
	  (case (if (symbol? cmd)
		    cmd
		    (string->symbol cmd))

	    ;;===============================================
	    ;; READ/WRITE QUERIES
	    ;;===============================================

	    ;; SERVERS
	    ((start-server)                    (apply server:kind-run params))
	    ((kill-server)                     (set! *server-run* #f))

	    ;; TESTS
	    ((test-set-state-status-by-id)     (apply db:test-set-state-status-by-id dbstruct params))
	    ((delete-test-records)             (apply db:delete-test-records dbstruct params))
	    ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params))
	    ((test-set-status-state)           (apply db:test-set-status-state dbstruct params))
	    ((test-set-top-process-pid)        (apply db:test-set-top-process-pid dbstruct params))
	    ((roll-up-pass-fail-counts)        (apply db:roll-up-pass-fail-counts dbstruct params))
	    ((update-fail-pass-counts)         (apply db:general-call dbstruct 'update-pass-fail-counts params))
	    ((test-set-archive-block-id)       (apply db:test-set-archive-block-id dbstruct params))

	    ;; RUNS
	    ((register-run)                 (apply db:register-run dbstruct params))
	    ((set-tests-state-status)       (apply db:set-tests-state-status dbstruct params))
	    ((delete-run)                   (apply db:delete-run dbstruct params))
	    ((lock/unlock-run)              (apply db:lock/unlock-run dbstruct params))
	    ((update-run-event_time)        (apply db:update-run-event_time dbstruct params))

	    ;; STEPS
	    ((teststep-set-status!)         (apply db:teststep-set-status! dbstruct params))

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

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

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

	    ;; TASKS
	    ((tasks-add)                 (apply tasks:add dbstruct params))   
	    ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params))

	    ;; ARCHIVES
	    ;; ((archive-get-allocations)   
	    ((archive-register-disk)     (apply db:archive-register-disk dbstruct params))
	    ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params))
	    ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey))

	    ;;======================================================================
	    ;; READ ONLY QUERIES
	    ;;======================================================================

	    ;; KEYS
	    ((get-key-val-pairs)               (apply db:get-key-val-pairs dbstruct params))
	    ((get-keys)                        (db:get-keys dbstruct))

	    ;; ARCHIVES
	    ((test-get-archive-block-info)     (apply db:test-get-archive-block-info dbstruct params))
	    
	    ;; TESTS
	    ((test-toplevel-num-items)         (apply db:test-toplevel-num-items dbstruct params))
	    ((get-test-info-by-id)	       (apply db:get-test-info-by-id dbstruct params))
	    ((test-get-rundir-from-test-id)    (apply db:test-get-rundir-from-test-id dbstruct params))
	    ((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname dbstruct params))
	    ((get-count-tests-running)         (apply db:get-count-tests-running dbstruct params))
	    ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params))
	    ;; ((delete-test-step-records)        (apply db:delete-test-step-records dbstruct params))
	    ((get-previous-test-run-record)    (apply db:get-previous-test-run-record dbstruct params))
	    ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params))
	    ((test-get-logfile-info)           (apply db:test-get-logfile-info dbstruct params))
	    ((test-get-records-for-index-file)  (apply db:test-get-records-for-index-file dbstruct params))
	    ((get-testinfo-state-status)       (apply db:get-testinfo-state-status dbstruct params))
	    ((test-get-top-process-pid)        (apply db:test-get-top-process-pid dbstruct params))
	    ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params))
	    ((get-prereqs-not-met)             (apply db:get-prereqs-not-met dbstruct params))
	    ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params))
	    ((synchash-get)                    (apply synchash:server-get dbstruct params))

	    ;; RUNS
	    ((get-run-info)                 (apply db:get-run-info dbstruct params))
	    ((get-run-status)               (apply db:get-run-status dbstruct params))
	    ((set-run-status)               (apply db:set-run-status dbstruct params))
	    ((get-tests-for-run)            (apply db:get-tests-for-run dbstruct params))
	    ((get-test-id)                  (apply db:get-test-id dbstruct params))
	    ((get-tests-for-run-mindata)    (apply db:get-tests-for-run-mindata dbstruct params))
	    ((get-runs)                     (apply db:get-runs dbstruct params))
	    ((get-all-run-ids)              (db:get-all-run-ids dbstruct))
	    ((get-prev-run-ids)             (apply db:get-prev-run-ids dbstruct params))
	    ((get-run-ids-matching-target)  (apply db:get-run-ids-matching-target dbstruct params))
	    ((get-runs-by-patt)             (apply db:get-runs-by-patt dbstruct params))
	    ((get-run-name-from-id)         (apply db:get-run-name-from-id dbstruct params))

	    ;; STEPS
	    ((get-steps-data)               (apply db:get-steps-data dbstruct params))
	    ((get-steps-for-test)           (apply db:get-steps-for-test dbstruct params))

	    ;; MISC
	    ((have-incompletes?)            (apply db:have-incompletes? dbstruct params))
	    ((login)                        (apply db:login dbstruct params))
	    ((general-call)                 (let ((stmtname   (car params))
						  (run-id     (cadr params))
						  (realparams (cddr params)))
					      (db:with-db dbstruct run-id #t ;; these are all for modifying the db
							  (lambda (db)
							    (db:general-call db stmtname realparams)))))
	    ((sdb-qry)                      (apply sdb:qry params))
	    ((ping)                         (current-process-id))

	    ;; TESTMETA
	    ((testmeta-get-record)       (apply db:testmeta-get-record dbstruct params))

	    ;; TASKS 
	    ((find-task-queue-records)   (apply tasks:find-task-queue-records dbstruct params))))))))


;; http-server  send-response
;;                 api:process-request
;;                    db:*
;;
;; NB// Runs on the server as part of the server loop
;;
(define (api:process-request dbstruct $) ;; the $ is the request vars proc
  (let* ((cmd     ($ 'cmd))
	 (paramsj ($ 'params))
	 (params  (db:string->obj paramsj transport: 'http)) ;; (rmt:json-str->dat paramsj))
	 (resdat  (api:execute-requests dbstruct (vector cmd params))) ;; #( flag result )
	 (res     (vector-ref resdat 1)))

    ;; This can be here but needs controls to ensure it doesn't run more than every 4 seconds
    ;; (rmt:dat->json-str
    ;;  (if (or (string? res)
    ;;          (list?   res)
    ;;          (number? res)
    ;;          (boolean? res))
    ;;      res 
    ;;      (list "ERROR, not string, list, number or boolean" 1 cmd params res)))))
    (db:obj->string res transport: 'http)))

Modified archive.scm from [653c86c4f2] to [dea3fe5e91].

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17


























































































































































































































































;; Copyright 2006-2012, 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.

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


























































































































































































































































|










|





>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
;; Copyright 2006-2014, 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.

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

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

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

;; look for the best candidate archive area, else create new 
;; area
;;
(define (archive:get-archive testname itempath dused)
  ;; look up in archive_allocations if there is a pre-used archive
  ;; with adequate diskspace
  ;;
  (let* ((existing-blocks (rmt:archive-get-allocations testname itempath dused))
	 (candidate-disks (map (lambda (block)
				 (list
				  (vector-ref block 1)   ;; archive-area-name
				  (vector-ref block 2))) ;; disk-path
			       existing-blocks)))
    (or (common:get-disk-with-most-free-space candidate-disks dused)
	(archive:allocate-new-archive-block testname itempath))))

;; allocate a new archive area
;;
(define (archive:allocate-new-archive-block run-area-home testsuite-name dneeded)
  (let* ((adisks    (archive:get-archive-disks))
	 (best-disk (common:get-disk-with-most-free-space adisks dneeded)))
    (if best-disk
	(let* ((bdisk-name    (car best-disk))
	       (bdisk-path    (cdr best-disk))
	       (area-key      (substring (message-digest-string (md5-primitive) run-area-home) 0 5))
	       (bdisk-id      (rmt:archive-register-disk bdisk-name bdisk-path (get-df bdisk-path)))
	       (archive-name  (let ((sec (current-seconds)))
				(conc (time->string (seconds->local-time sec) "%Y")
				      "_q" (seconds->quarter sec) "/"
				      testsuite-name "_" area-key)))
	       (archive-path  (conc bdisk-path "/" archive-name))
	       (block-id      (rmt:archive-register-block-name bdisk-id archive-path)))
	  ;;   (allocation-id (rmt:archive-allocate-testsuite/area-to-block block-id testsuite-name area-key)))
	  (if block-id ;; (and block-id allocation-id)
	      (cons block-id archive-path)
	      #f))
	#f)))

;; archive - run bup
;;
;; 1. create the bup dir if not exists
;; 2. start the du of each directory
;; 3. gen index
;; 4. save
;;
(define (archive:run-bup archive-command run-id run-name tests)
  ;; move the getting of archive space down into the below block so that a single run can 
  ;; allocate as needed should a disk fill up
  ;;
  (let* ((min-space    (string->number (or (configf:lookup *configdat* "archive" "minspace") "1000")))
	 (archive-info (archive:allocate-new-archive-block *toppath* (common:get-testsuite-name) min-space))
	 (archive-dir  (if archive-info (cdr archive-info) #f))
	 (archive-id   (if archive-info (car archive-info) -1))
	 (disk-groups  (make-hash-table))
	 (test-groups  (make-hash-table)) ;; these two (disk and test groups) could be combined nicely
	 (bup-exe      (or (configf:lookup *configdat* "archive" "bup") "bup"))
	 (compress     (or (configf:lookup *configdat* "archive" "compress") "9"))
	 (linktree     (configf:lookup *configdat* "setup" "linktree")))

    (if (not archive-dir) ;; no archive disk found, this is fatal
	(begin
	  (debug:print 0 "FATAL: No archive disks found. Please add disks with at least " min-space " MB space to the [archive-disks] section of megatest.config")
	  (debug:print 0 "       use [archive] minspace to specify minimum available space")
	  (debug:print 0 "   disks: " (string-intersperse (map cadr (archive:get-archive-disks)) "\n         "))
	  (exit 1))
	(debug:print-info 0 "Using path " archive-dir " for archiving"))

    ;; from the test info bin the path to the test by stem
    ;;
    (for-each
     (lambda (test-dat)
       (let* ((item-path         (db:test-get-item-path test-dat))
	      (test-name         (db:test-get-testname  test-dat))
	      (test-id           (db:test-get-id        test-dat))
	      (run-id            (db:test-get-run_id    test-dat))
	      (target            (string-intersperse (map cadr (rmt:get-key-val-pairs run-id)) "/"))
	      
	      (toplevel/children (and (db:test-get-is-toplevel test-dat)
				      (> (rmt:test-toplevel-num-items run-id test-name) 0)))
	      (test-partial-path (conc target "/" run-name "/" (runs:make-full-test-name test-name item-path)))
	      ;; note the trailing slash to get the dir inspite of it being a link
	      (test-path         (conc linktree "/" test-partial-path))
	      (test-physical-path (if (file-exists? test-path) (read-symbolic-link test-path #t) #f))
	      (partial-path-index (if test-physical-path (substring-index test-partial-path test-physical-path) #f))
	      (test-base         (if (and partial-path-index 
					  test-physical-path )
				     (substring test-physical-path
						0
						partial-path-index)
				     #f)))
	 
 	 (if (or toplevel/children
		 (not (file-exists? test-path)))
	     #f
	     (begin
	       (debug:print 0
			    "From test-dat=" test-dat " derived the following:\n"
			    "test-partial-path  = " test-partial-path "\n"
			    "test-path          = " test-path "\n"
			    "test-physical-path = " test-physical-path "\n"
			    "partial-path-index = " partial-path-index "\n"
			    "test-base          = " test-base)
	       (hash-table-set! disk-groups test-base (cons test-physical-path (hash-table-ref/default disk-groups test-base '())))
	       (hash-table-set! test-groups test-base (cons test-dat (hash-table-ref/default test-groups test-base '())))
	       test-path))))
     tests)
    ;; for each disk-group
    (for-each 
     (lambda (disk-group)
       (debug:print 0 "Processing disk-group " disk-group)
       (let* ((test-paths (hash-table-ref disk-groups disk-group))
	      ;; ((string-intersperse (map cadr (rmt:get-key-val-pairs 1)) "-")
	      (bup-init-params  (list "-d" archive-dir "init"))
	      (bup-index-params (append (list "-d" archive-dir "index") test-paths))
	      (bup-save-params  (append (list "-d" archive-dir "save" ;; (conc "--strip-path=" linktree)
					      (conc "-" compress) ;; or (conc "--compress=" compress)
					      "-n" (conc (common:get-testsuite-name) "-" run-id)
					      (conc "--strip-path=" disk-group))
					test-paths))
	      (print-prefix      #f)) ;; "Running: ")) ;; change to #f to turn off printing
	 (if (not (file-exists? archive-dir))
	     (create-directory archive-dir #t))
	 (if (not (file-exists? (conc archive-dir "/HEAD")))
	     (begin
	       ;; replace this with jobrunner stuff enventually
	       (debug:print-info 0 "Init bup in " archive-dir)
	       (run-n-wait bup-exe params: bup-init-params print-cmd: print-prefix)))
	 (debug:print-info 0 "Indexing data to be archived")
	 (run-n-wait bup-exe params: bup-index-params print-cmd: print-prefix)
	 (debug:print-info 0 "Archiving data with bup")
	 (run-n-wait bup-exe params: bup-save-params print-cmd: print-prefix)
	 (for-each
	  (lambda (test-dat)
	    (let ((test-id           (db:test-get-id        test-dat))
		  (run-id            (db:test-get-run_id    test-dat)))
	      (rmt:test-set-archive-block-id run-id test-id archive-id)
	      (if (member archive-command '("save-remove"))
		  (runs:remove-test-directory test-dat 'archive-remove))))
	  (hash-table-ref test-groups disk-group))))
     (hash-table-keys disk-groups))
    #t))

(define (archive:bup-restore archive-command run-id run-name tests)  ;; move the getting of archive space down into the below block so that a single run can 
  ;; allocate as needed should a disk fill up
  ;;
  (let* ((bup-exe      (or (configf:lookup *configdat* "archive" "bup") "bup"))
	 (linktree     (configf:lookup *configdat* "setup" "linktree")))

    ;; from the test info bin the path to the test by stem
    ;;
    (for-each
     (lambda (test-dat)
       ;; When restoring test-dat will initially contain an old and invalid path to the test
       (let* ((best-disk         (get-best-disk *configdat*))
	      (item-path         (db:test-get-item-path test-dat))
	      (test-name         (db:test-get-testname  test-dat))
	      (test-id           (db:test-get-id        test-dat))
	      (run-id            (db:test-get-run_id    test-dat))
	      (keyvals           (rmt:get-key-val-pairs run-id))
	      (target            (string-intersperse (map cadr keyvals) "/"))
	      
	      (toplevel/children (and (db:test-get-is-toplevel test-dat)
				      (> (rmt:test-toplevel-num-items run-id test-name) 0)))
	      (test-partial-path (conc target "/" run-name "/" (runs:make-full-test-name test-name item-path)))
	      ;; note the trailing slash to get the dir inspite of it being a link
	      (test-path         (conc linktree "/" test-partial-path))
	      ;; if the old path was not deleted then prev-test-physical-path will end up pointing to a real directory
	      (prev-test-physical-path (if (file-exists? test-path) (read-symbolic-link test-path #t) #f))

	      (new-test-physical-path  (conc best-disk "/" test-partial-path))
	      (archive-block-id        (db:test-get-archived test-dat))
	      (archive-block-info      (rmt:test-get-archive-block-info archive-block-id))
	      (archive-path            (if (vector? archive-block-info)
					   (vector-ref archive-block-info 2) ;; look in db.scm for test-get-archive-block-info for the vector record info
					   #f)) ;; no archive found?
	      (archive-internal-path   (conc (common:get-testsuite-name) "-" run-id "/latest/" test-partial-path)))
	 
	 ;; some sanity checks 
	 (if (and prev-test-physical-path
		  (file-exists? prev-test-physical-path)) ;; what to do? abort or clean up or link it in?
	     (debug:print 0 "ERROR: the old directory " prev-test-physical-path ", still exists! This should not be."))

	 (if archive-path ;; no point in proceeding if there is no actual archive
	     (begin
	       ;; CREATE WORK AREA
	       ;; test-src-path == #f     ==> don't copy in data from tests directory
	       ;; itemdat       == string ==> use directly
	       (create-work-area run-id run-name keyvals test-id #f best-disk test-name item-path) ;; #!key (remtries 2))

	       ;; 1. Get the block id from the test info
	       ;; 2. Get the block data given the block id
	       ;; 3. Construct the paths etc. for the following command:
	       ;; 
	       ;; bup -d /tmp/matt/adisk1/2015_q1/fullrun_e1a40/ restore -C /tmp/seeme fullrun-30/latest/ubuntu/nfs/none/w02.1.20.54_b/

	       ;; DO BUP RESTORE
	       (let* ((new-test-dat        (rmt:get-test-info-by-id run-id test-id))
		      (new-test-path       (if (vector? new-test-dat )
					       (db:test-get-rundir new-test-dat)
					       (begin
						 (debug:print 0 "ERROR: unable to get data for run-id=" run-id ", test-id=" test-id)
						 (exit 1))))
		      ;; new-test-path won't work - must use best-disk instead? Nope, new-test-path but tack on /..
		      (bup-restore-params  (list "-d" archive-path "restore" "-C" (conc new-test-path "/..") archive-internal-path)))
		 (debug:print-info 0 "Restoring archived data to " new-test-physical-path " from archive in " archive-path " ... " archive-internal-path)
		 (run-n-wait bup-exe params: bup-restore-params print-cmd: #f)))
	     (debug:print 0 "ERROR: No archive path in the record for run-id=" run-id " test-id=" test-id))))
     (filter vector? tests))))
	 

Added batchsim/batchsim.scm version [4fb71c3537].









































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
(use ezxdisp srfi-18)

(define *ezx* (ezx-init 650 650 "Test Critter"))
(require-library ezxgui)
(define *green*  (make-ezx-color 0 1 0)) 
(define *black*  (make-ezx-color 0 0 0))
(define *grey*   (make-ezx-color 0.1 0.1 0.1))
(define *blue*   (make-ezx-color 0 0 1)) 
(define *cyan*   (make-ezx-color 0 1 1))
(define *green*  (make-ezx-color 0 1 0))
(define *purple* (make-ezx-color 1 0 1))
(define *red*    (make-ezx-color 1 0 0))
(define *white*  (make-ezx-color 1 1 1))
(define *yellow* (make-ezx-color 1 1 0))

(define *user-colors-palette*
  (list 
   *green*
   *blue*
   *cyan*
   *purple*
   *red*
   *yellow*
   *black*))

(define *dark-green* (get-color "dark-green"))
(define *brown*      (get-color "brown"))

(ezx-select-layer *ezx* 1)
(ezx-wipe-layer *ezx* 1)

;; (ezx-str-2d *ezx* 30 30 "Hello" *white*)
;; (ezx-fillrect-2d *ezx* 100 100 120 120 *brown*)
(ezx-redraw *ezx*)

(define *last-draw* (current-milliseconds))
(define *draw-delta* 40) ;; milliseconds between drawing

(define (wait-for-next-draw-time)
  (let* ((cm    (current-milliseconds))
	 (delta (- *draw-delta* (- cm *last-draw*))))
    (if (> delta 0)
	(thread-sleep! (/ delta 1000)))
    (set! *last-draw* (current-milliseconds))))

(include "events.scm")

;; System spec (to be moved into loaded file)
;;
;;                           x  y  w gap  x-min x-max
(define *cpu-grid* (vector  500 50 15  2  500   645))
(define (make-cpu:grid)(make-vector 6))
(define *queues* (make-hash-table)) ;; name -> (list (list user duration num-cpus num-gigs) ... )
(define *cpus* (make-hash-table)) ;; cpu-name => (vector user job-len num-cpu mem x-loc y-loc)
(define *obj-locations* (make-hash-table)) ;; name -> (x y layer)
(define *queue-spec*
  (vector
   80  ;; start-x
   300 ;; start-y
   300 ;; delta-y how far to next queue
   15  ;; height
   400 ;; length
   ))
(define *use-log* #f)
(define *job-log-scale* 10)

;;======================================================================
;; Users
;;======================================================================

(define *user-colors* (make-hash-table))

(define (get-user-color user)
  (let ((color (hash-table-ref/default *user-colors* user #f)))
    (if color
	color
	(let* ((color-num (+ (length (hash-table-keys *user-colors*)) 1))
	       (color     (list-ref *user-colors-palette* color-num)))
	  (hash-table-set! *user-colors* user color)
	  color))))

;;======================================================================
;; Job Queues
;;======================================================================

;; jobs

(define (make-queue:job)(make-vector 4))
(define-inline (queue:job-get-user       vec)    (vector-ref  vec 0))
(define-inline (queue:job-get-duration   vec)    (vector-ref  vec 1))
(define-inline (queue:job-get-num-cpu    vec)    (vector-ref  vec 2))
(define-inline (queue:job-get-num-gigs   vec)    (vector-ref  vec 3))
(define-inline (queue:job-set-user!      vec val)(vector-set! vec 0 val))
(define-inline (queue:job-set-duration!  vec val)(vector-set! vec 1 val))
(define-inline (queue:job-set-num-cpu!   vec val)(vector-set! vec 2 val))
(define-inline (queue:job-set-num-gigs!  vec val)(vector-set! vec 3 val))

;; add a job to the queue
;;
(define (add-job queue-name user duration num-cpu num-gigs)
  (let* ((queue-dat (hash-table-ref/default *queues* queue-name '()))
	 (new-queue (append 
		     queue-dat
		     (list (vector user duration num-cpu num-gigs)))))
  (hash-table-set! *queues* queue-name new-queue)
  (draw-queue-jobs queue-name)))

;; peek for jobs to do in queue
;;
(define (peek-job queue-name)
  (let ((queue (hash-table-ref/default *queues* queue-name '())))
    (if (null? queue)
	#f
	(car queue))))

;; take job from queue
;;
(define (take-job queue-name)
  (let ((queue (hash-table-ref/default *queues* queue-name '())))
    (if (null? queue)
	#f
	(begin
	  (hash-table-set! *queues* queue-name (cdr queue))
	  (draw-queue-jobs queue-name)
	  (car queue)))))

;;======================================================================
;; CPUs
;;======================================================================

(define (make-cpu:dat)(make-vector 6 #f))
(define-inline (cpu:dat-get-user      vec)    (vector-ref  vec 0))
(define-inline (cpu:dat-get-job-len   vec)    (vector-ref  vec 1))
(define-inline (cpu:dat-get-num-cpu   vec)    (vector-ref  vec 2))
(define-inline (cpu:dat-get-mem       vec)    (vector-ref  vec 3))
(define-inline (cpu:dat-get-x         vec)    (vector-ref  vec 4))
(define-inline (cpu:dat-get-y         vec)    (vector-ref  vec 5))
(define-inline (cpu:dat-set-user!     vec val)(vector-set! vec 0 val))
(define-inline (cpu:dat-set-job-len!  vec val)(vector-set! vec 1 val))
(define-inline (cpu:dat-set-num-cpu!  vec val)(vector-set! vec 2 val))
(define-inline (cpu:dat-set-mem!      vec val)(vector-set! vec 3 val))
(define-inline (cpu:dat-set-x!        vec val)(vector-set! vec 4 val))
(define-inline (cpu:dat-set-y!        vec val)(vector-set! vec 5 val))

(define-inline (cpu:grid-get-x        vec)    (vector-ref  vec 0))
(define-inline (cpu:grid-get-y        vec)    (vector-ref  vec 1))
(define-inline (cpu:grid-get-w        vec)    (vector-ref  vec 2))
(define-inline (cpu:grid-get-gap      vec)    (vector-ref  vec 3))
(define-inline (cpu:grid-get-x-min    vec)    (vector-ref  vec 4))
(define-inline (cpu:grid-get-x-max    vec)    (vector-ref  vec 5))
(define-inline (cpu:grid-set-x!       vec val)(vector-set! vec 0 val))
(define-inline (cpu:grid-set-y!       vec val)(vector-set! vec 1 val))
(define-inline (cpu:grid-set-w!       vec val)(vector-set! vec 2 val))
(define-inline (cpu:grid-set-gap!     vec val)(vector-set! vec 3 val))
(define-inline (cpu:grid-set-x-min!   vec val)(vector-set! vec 4 val))
(define-inline (cpu:grid-set-x-max!   vec val)(vector-set! vec 5 val))

(define (add-cpu name num-cores mem)
  (let ((x     (cpu:grid-get-x     *cpu-grid*))
	(y     (cpu:grid-get-y     *cpu-grid*))
	(delta (+ (cpu:grid-get-w  *cpu-grid*)(cpu:grid-get-gap *cpu-grid*)))
	(x-max (cpu:grid-get-x-max *cpu-grid*)))
    (hash-table-set! *cpus* name (vector #f #f num-cores mem x y))
    (if (> x x-max)
	(begin
	  (cpu:grid-set-x! *cpu-grid* (cpu:grid-get-x-min *cpu-grid*))
	  (cpu:grid-set-y! *cpu-grid* (+ y delta)))
	(cpu:grid-set-x! *cpu-grid* (+ x delta)))))

;; draw grey box for each cpu on layer 2
;; jobs are drawn on layer 1
;;
(define (draw-cpus) ;; call once after init'ing all cpus
  (ezx-select-layer *ezx* 1)
  (ezx-wipe-layer   *ezx* 1)
  ;; draw time at upper right
  (ezx-str-2d *ezx* 20 20 (seconds->h:m:s *now*) *black*)
  (for-each
   (lambda (cpu)
     (let ((x (cpu:dat-get-x cpu))
	   (y (cpu:dat-get-y cpu))
	   (w (cpu:grid-get-w *cpu-grid*)))
       (ezx-rect-2d *ezx* x y (+ x w) (+ y w) *grey* 1)))
   (hash-table-values *cpus*))
  (ezx-redraw *ezx*))

(define (draw-jobs)
  ;; (draw-cpus)
  (ezx-select-layer *ezx* 2)
  (ezx-wipe-layer   *ezx* 2)
  (for-each
   (lambda (cpu)
     (let* ((x (cpu:dat-get-x cpu))
	    (y (cpu:dat-get-y cpu))
	    (w (cpu:grid-get-w *cpu-grid*))
	    (u (cpu:dat-get-user cpu)))
       (if u ;; job running if not #f
	   (let ((color (get-user-color u)))
	     (ezx-fillrect-2d *ezx* (+ x 2)(+ 2 y)(+ x 9) (+ y 9) color)))))
   (hash-table-values *cpus*))
  (ezx-redraw *ezx*))

(define (end-job cpu-name user)
  (let ((cpu (hash-table-ref/default *cpus* cpu-name #f)))
    (if cpu
	(let ((curr-user (cpu:dat-get-user cpu))) ;; if it is a user name then job is not done - error
	  (if (or (not curr-user)
		  (not (equal? curr-user user)))
	      (print "ERROR: cpu " cpu-name " not running job for " user "!")
	      (begin
		(cpu:dat-set-user!    cpu #f)
		(cpu:dat-set-job-len! cpu #f)
		(draw-jobs)))) ;; hash-table-set! *cpus* cpu-name (make-cpu:dat))))
	(print "ERROR: no cpu " cpu-name " found. Ensure it is registered before addressing it."))))

(define (run-job cpu-name job)
  (let* ((user    (queue:job-get-user     job))
	 (job-len (queue:job-get-duration job))
	 (cpu     (hash-table-ref/default *cpus* cpu-name #f)))
    (if cpu
	(let ((curr-user (cpu:dat-get-user cpu))) ;; if it is a user name then job is not done - error
	  (if curr-user
	      (begin
		(print "ERROR: cpu already busy! Adding more jobs not supported yet. " cpu-name)
		#f)
	      (begin
		(cpu:dat-set-user!    cpu user)
		(cpu:dat-set-job-len! cpu job-len)
		(draw-jobs)
		(hash-table-set! *cpus* cpu-name cpu)
		(event (+ *now* job-len) (lambda ()(end-job cpu-name user)))
		#t)))
	#f)))
    
(define (get-cpu)
  (let ((all-cpus (hash-table-keys *cpus*)))
    (if (null? all-cpus) 
	#f
	(let loop ((hed (car all-cpus))
		   (tal (cdr all-cpus)))
	  (if (cpu:dat-get-user (hash-table-ref/default *cpus* hed '(#f #f))) ;; if user is #f then cpu is available
	      (if (null? tal)
		  #f
		  (loop (car tal)(cdr tal)))
	      hed)))))
  
;;======================================================================
;; Animation
;;======================================================================

;; make-vector-record  queue spec x y delta-y height length
(define (make-queue:spec)(make-vector 5))
(define-inline (queue:spec-get-x         vec)    (vector-ref  vec 0))
(define-inline (queue:spec-get-y         vec)    (vector-ref  vec 1))
(define-inline (queue:spec-get-delta-y   vec)    (vector-ref  vec 2))
(define-inline (queue:spec-get-height    vec)    (vector-ref  vec 3))
(define-inline (queue:spec-get-length    vec)    (vector-ref  vec 4))
(define-inline (queue:spec-set-x!        vec val)(vector-set! vec 0 val))
(define-inline (queue:spec-set-y!        vec val)(vector-set! vec 1 val))
(define-inline (queue:spec-set-delta-y!  vec val)(vector-set! vec 2 val))
(define-inline (queue:spec-set-height!   vec val)(vector-set! vec 3 val))
(define-inline (queue:spec-set-length!   vec val)(vector-set! vec 4 val))

;; queues are drawn on layer 3 but boxes (jobs) are drawn on the numbered layer
;;
(define (draw-queues)
  (let* ((text-offset 3)
	 (queue-names (sort (hash-table-keys *queues*) string>=?))
	 (start-x (vector-ref *queue-spec* 0))
	 (text-x  (+ start-x text-offset))
	 (delta-y (vector-ref *queue-spec* 1))
	 (delta-x (vector-ref *queue-spec* 2))
	 (height  (vector-ref *queue-spec* 3))
	 (length  (vector-ref *queue-spec* 4))
	 (end-x   (+ start-x length)))
    (ezx-select-layer *ezx* 3)
    (ezx-wipe-layer   *ezx* 3)
    (let loop ((y       (vector-ref *queue-spec* 1))
	       (qname   (car queue-names))
	       (tail    (cdr queue-names))
	       (layer   4))
      (print "Drawing queue at x=" start-x ", y=" y)
      (ezx-fillrect-2d  *ezx* start-x y end-x (+ y height) *brown*)
      (ezx-str-2d       *ezx* text-x (- (+ y height) text-offset) qname *white*)
      (hash-table-set! *obj-locations* qname (list start-x y layer))
      (if (not (null? tail))
	  (loop (+ y height delta-y)
		(car tail)
		(cdr tail)
		(+  layer 1))))
    (ezx-redraw *ezx*)))

;; compress queue data to (vector user count) list
;;
(define (draw-queue-compress-queue-data queue-dat)
  (let loop ((hed  (car queue-dat))
	     (tal  (cdr queue-dat))
	     (curr #f) ;; (vector name count)
	     (res  '()))
    (let ((user (queue:job-get-user hed)))
      (cond
       ((not curr) ;; first time through only?
	(if (null? tal)
	    (append res (list (vector user 1)))
	    (loop (car tal)(cdr tal)(vector user 1) res)))
       ((equal? (vector-ref curr 0) user) 
	(vector-set! curr 1 (+ (vector-ref curr 1) 1))
	(if (null? tal)
	    (append res (list curr))
	    (loop (car tal)(cdr tal) curr res)))
       (else ;; names are different, add curr to queue and create new curr
	(let ((newcurr (vector user 1)))
	  (if (null? tal)
	      (append res (list newcurr))
	      (loop (car tal)(cdr tal) newcurr (append res (list curr))))))))))

;; draw jobs for a given queue
;;
(define (draw-queue-jobs queue-name)
  (let* ((queue-dat (hash-table-ref/default *queues*        queue-name #f))  ;; list of jobs in the queue
	 (obj-spec  (hash-table-ref/default *obj-locations* queue-name #f)))  ;; x, y etc. of the drawn queue
    (if obj-spec
	(let ((origin-x  (list-ref obj-spec 0))
	      (origin-y  (list-ref obj-spec 1))
	      (bar-width 10)
	      (queue-len (queue:spec-get-length *queue-spec*))
	      (layer     (list-ref obj-spec 2)))
	  (ezx-select-layer *ezx* layer)
	  (ezx-wipe-layer   *ezx* layer)
	  (if (not (null? queue-dat))
	      (let ((res (draw-queue-compress-queue-data queue-dat)))
		(if (not (null? res))
		    (let loop ((hed (car res))
			       (tal (cdr res))
			       (x2   (+ origin-x queue-len)))
		      (let* ((user (vector-ref hed 0))
			     (h    (let ((numjobs (vector-ref hed 1)))
				     (if *use-log*
					 (inexact->exact (round (log (+ 1 (* *job-log-scale* numjobs)))))
					 numjobs)))
			     (x1   (- x2  bar-width))
			     (y2   (- origin-y h)))
			(print "x1 " x1 ", origin-y " origin-y ", x2 " x2 ", y2 " y2)
			(ezx-fillrect-2d *ezx* x1 y2 x2 origin-y (get-user-color user))
			(if (not (null? tal))
			    (loop (car tal)(cdr tal) x1)))))
		(ezx-redraw *ezx*)))))))
	  


;; (let* ((args  (argv))
;;        (fname (if (> (length args) 1)
;; 		  (cadr args)
;; 		  "default.scm")))

(load "default.scm")

Added batchsim/default.scm version [a22e50f138].























































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
;; run sim for four hours
;;
(define *end-time* (* 60 40))

;; create the cpus
;;
(let loop ((count 200))
  (add-cpu (conc "cpu_" count) 1 1)
  (if (>= count 0)(loop (- count 1))))

(draw-cpus)

;; init the queues
;;
(hash-table-set! *queues* "normal" '())
(hash-table-set! *queues* "quick"  '())
(draw-queues)

;; user k adds 200 jobs at time zero
;;
(event *start-time*
       (lambda ()
	 (let loop ((count 300)) ;; add 500 jobs
	   (add-job "normal" "k" 600 1 1)
	   (if (>= count 0)(loop (- count 1))))))

;; one minute in user m runs ten jobs
;;
(event (+ 600 *start-time*)
       (lambda ()
	 (let loop ((count 300)) ;; add 100 jobs
	   (add-job "normal" "m" 600 1 1)
	   (if (> count 0)(loop (- count 1))))))

;; every minute user j runs ten jobs
;;
(define *user-j-jobs* 500)
(event (+ 600 *start-time*)
       (lambda ()
	 (let f ()
	   (schedule 60)
	   (if (> *user-j-jobs* 0)
	       (begin
		 (let loop ((count 10)) ;; add 100 jobs
		   (add-job "quick" "j" 600 1 1)
		   (if (> count 0)(loop (- count 1))))
		 (set! *user-j-jobs* (- *user-j-jobs* 10))))
	   (if (and (not *done*)
		    (> *user-j-jobs* 0))
	       (f))))) ;; Megatest user running 200 jobs
;; ;;
;; (event *start-time*
;;        (lambda ()
;; 	 (let f ((count 200))
;; 	   (schedule 10)
;; 	   (add-job "normal" "t" 60 1 1)
;; 	   (if (and (not *done*)
;; 		    (>= count 0))
;; 	       (f (- count 1))))))

;; every 3 seconds check for available machines and launch a job
;;
(event *start-time*
       (lambda ()
	 (let f ()
	   (schedule 3)
	   (let ((queue-names (hash-table-keys *queues*)))
	     (let loop ((cpu   (get-cpu))
			(count (+ (length queue-names) 4))
			(qname (car queue-names))
			(remq  (cdr queue-names)))
	       (if (and cpu
			(> count 0))
		   (begin
		     (if (peek-job qname) ;; any jobs to do in normal queue
			 (let ((job (take-job qname)))
			   (run-job cpu job)))
		     (loop (get-cpu)
			   (- count 1)
			   (if (null? remq)
			       (car queue-names)
			       (car remq))
			   (if (null? remq)
			       (cdr queue-names)
			       (cdr remq)))))))
	   (if (not *done*)(f)))))

;; screen updates
;;
(event *start-time* (lambda ()
		      (let f ()
			(schedule 60) ;; update the screen every 60 seconds of sim time
			(draw-cpus) ;; (print "Now: " *now* " queue: " (hash-table->alist *queues*))
			(wait-for-next-draw-time)
			(if (not *done*) (f)))))


;; end the simulation
;;
(event *end-time*
       (lambda () 
	 (set! *event-list* '())
	 (set! *done* #t)))

(start)
;; (exit 0)

Added batchsim/events.scm version [37c26a4330].





















































































































































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

;;======================================================================
;; Event Processing and Simulator
;;======================================================================

;; The global event list
(define *event-list* '())
(define *start-time* 0)
(define *end-time*   (* 60 60 4)) ;; four hours
(define *now*        *start-time*)
(define *done*       #f)

;; Each item in the event list is a list of a scheduled time and the thunk
;; (time thunk). Sort the list so that the next event is the earliest.
;;
(define event-sort
  (lambda (@a @b)
    (< (car @a)(car @b))))

(define event
  (lambda ($time $thunk)  ;; add a sort based on scheduled time here -- improve later
                          ;; to use an insert algorythm.
    (set! *event-list* (sort (cons (list $time $thunk) *event-list*) event-sort))))

(define start
  (lambda ()
    (let ((next (car *event-list*)))
      (set! *event-list* (cdr *event-list*))
      (set! *now* (car next))      
      (if (not *done*) ;; note that the second item in the list is the thunk
	  ((car (cdr next)))))))

(define pause
  (lambda ()
    (call/cc 
     (lambda (k)
       (event (lambda () (k #f)))
       (start)))))

(define schedule
  (lambda ($time)
    (call/cc 
     (lambda (k)
       (event (+ *now* $time) (lambda () (k #f)))
       (start)))))

;; (event (lambda () (let f () (pause) (display "h") (f))))

(define years->seconds
  (lambda ($yrs)
    (* $yrs 365 24 3600)))

(define weeks->seconds
  (lambda ($wks)
    (* $wks 7 24 3600)))

(define days->seconds
  (lambda ($days)
    (* $days 24 3600)))

(define months->seconds
  (lambda ($months)
    (* $months (/ 365 12) 24 3600)))

(define seconds->date
  (lambda ($seconds)
    (posix-strftime "%D" (posix-localtime (inexact->exact $seconds)))))

(define (seconds->h:m:s seconds)
  (let* ((hours   (quotient seconds 3600))
	 (rem1    (- seconds (* hours 3600)))
	 (minutes (quotient rem1 60))
	 (rem-sec (- rem1 (* minutes 60))))
    (conc hours "h " minutes "m " rem-sec "s")))

Modified client.scm from [2d4047b824] to [c1867a27a6].

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

;; client:login serverdat
(define (client:login serverdat)
  (cdb:login serverdat *toppath* (client:get-signature)))

;; Not currently used! But, I think it *should* be used!!!
(define (client:logout serverdat)
  (let ((ok (and (socket? serverdat)
		 (cdb:logout serverdat *toppath* (client:get-signature)))))
    ok))




































































































;; Do all the connection work, look up the transport type and set up the
;; connection if required.
;;
;; There are two scenarios. 
;;   1. We are a test manager and we received *transport-type* and *runremote* via cmdline
;;   2. We are a run tests, list runs or other interactive process and we must figure out
;;      *transport-type* and *runremote* from the monitor.db
;;
;; client:setup



(define (client:setup #!key (numtries 3))


  (if (not *toppath*)
      (if (not (launch:setup-for-run))
	  (begin
	    (debug:print 0 "ERROR: failed to find megatest.config, exiting")
	    (exit))))
  (push-directory *toppath*) ;; This is probably NOT needed 

  (debug:print-info 11 "*transport-type* is " *transport-type* ", *runremote* is " *runremote*)
  (let* ((hostinfo  (open-run-close tasks:get-best-server tasks:open-db)))

    (debug:print-info 11 "CLIENT SETUP, hostinfo=" hostinfo)

    (set! *transport-type* (if hostinfo 


    			       (string->symbol (tasks:hostinfo-get-transport hostinfo))










			       'fs))

    (debug:print-info 11 "Using transport type of " *transport-type* (if hostinfo (conc " to connect to " hostinfo) ""))
    (case *transport-type* 
      ((fs)(if (not *megatest-db*)(set! *megatest-db* (open-db))))
      ((http)




       (http-transport:client-connect (tasks:hostinfo-get-interface hostinfo)
				      (tasks:hostinfo-get-port hostinfo)))















      ((zmq)


       (zmq-transport:client-connect (tasks:hostinfo-get-interface hostinfo)
				     (tasks:hostinfo-get-port      hostinfo)
				     (tasks:hostinfo-get-pubport   hostinfo)))
      (else  ;; default to fs
       (debug:print 0 "ERROR: unrecognised transport type " *transport-type* " attempting to continue with fs")
       (set! *transport-type* 'fs)
       (set! *megatest-db*    (open-db))))
    (pop-directory)))

;; client:signal-handler
(define (client:signal-handler signum)

  (handle-exceptions
   exn
   (debug:print " ... exiting ...")
   (let ((th1 (make-thread (lambda ()
			     "") ;; do nothing for now (was flush out last call if applicable)
			   "eat response"))
	 (th2 (make-thread (lambda ()
			     (debug:print 0 "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.")
			     (thread-sleep! 1) ;; give the flush one second to do it's stuff
			     (debug:print 0 "       Done.")
			     (exit 4))
			   "exit on ^C timer")))
     (thread-start! th2)
     (thread-start! th1)
     (thread-join! th2))))

;; client:launch



(define (client:launch)
  (set-signal-handler! signal/int client:signal-handler)
   (if (client:setup)
       (debug:print-info 2 "connected as client")
       (begin
	 (debug:print 0 "ERROR: Failed to connect as client")
	 (exit))))








<
<
<
<






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









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



>

















>
>
>
|

|
|
|
|
|

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





;; Not currently used! But, I think it *should* be used!!!
(define (client:logout serverdat)
  (let ((ok (and (socket? serverdat)
		 (cdb:logout serverdat *toppath* (client:get-signature)))))
    ok))

(define (client:connect iface port)
  (case (server:get-transport)
    ((rpc)  (rpc:client-connect  iface port))
    ((http) (http:client-connect iface port))
    ((zmq)  (zmq:client-connect  iface port))
    (else   (rpc:client-connect  iface port))))

(define (client:setup  run-id #!key (remaining-tries 10) (failed-connects 0))
  (case (server:get-transport)
    ((rpc) (rpc-transport:client-setup run-id)) ;;(client:setup-rpc run-id))
    ((http)(client:setup-http run-id))
    (else  (rpc-transport:client-setup run-id)))) ;; (client:setup-rpc run-id))))

;; (define (client:login-no-auto-setup server-info run-id)
;;   (case (server:get-transport)
;;     ((rpc)  (rpc:login-no-auto-client-setup server-info run-id))
;;     ((http) (rmt:login-no-auto-client-setup server-info run-id))
;;     (else   (rpc:login-no-auto-client-setup server-info run-id))))
;; 
;; (define (client:setup-rpc run-id)
;;   (debug:print 0 "INFO: client:setup remaining-tries=" remaining-tries)
;;   (if (<= remaining-tries 0)
;;       (begin
;; 	(debug:print 0 "ERROR: failed to start or connect to server for run-id " run-id)
;; 	(exit 1))
;;       (let ((host-info (hash-table-ref/default *runremote* run-id #f)))
;; 	(debug:print-info 0 "client:setup host-info=" host-info ", remaining-tries=" remaining-tries)
;; 	(if host-info
;; 	    (let* ((iface     (car  host-info))
;; 		   (port      (cadr host-info))
;; 		   (start-res (client:connect iface port))
;; 		   ;; (ping-res  (server:ping-server run-id iface port))
;; 		   (ping-res  (client:login-no-auto-setup start-res run-id)))
;; 	      (if ping-res   ;; sucessful login?
;; 		  (begin
;; 		    (hash-table-set! *runremote* run-id start-res)
;; 		    start-res)  ;; return the server info
;; 		  (if (member remaining-tries '(3 4 6))
;; 		      (begin    ;; login failed
;; 			(debug:print 25 "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" host-info)
;; 			(hash-table-delete! *runremote* run-id)
;; 			(open-run-close tasks:server-force-clean-run-record
;; 			 		tasks:open-db
;; 			 		run-id 
;; 			 		(car  host-info)
;; 			 		(cadr host-info)
;; 					" client:setup (host-info=#t)")
;; 			(thread-sleep! 5)
;; 			(client:setup run-id remaining-tries: 10)) ;; (- remaining-tries 1)))
;; 		      (begin
;; 			(debug:print 25 "INFO: client:setup failed to connect, start-res=" start-res ", run-id=" run-id ", host-info=" host-info)
;; 			(thread-sleep! 5)
;; 			(client:setup run-id remaining-tries: (- remaining-tries 1))))))
;; 	    ;; YUK: rename server-dat here
;; 	    (let* ((server-dat (open-run-close tasks:get-server tasks:open-db run-id)))
;; 	      (debug:print-info 0 "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries)
;; 	      (if server-dat
;; 		  (let* ((iface     (tasks:hostinfo-get-interface server-dat))
;; 			 (port      (tasks:hostinfo-get-port      server-dat))
;; 			 (start-res (http-transport:client-connect iface port))
;; 			 ;; (ping-res  (server:ping-server run-id iface port))
;; 			 (ping-res  (rmt:login-no-auto-client-setup start-res run-id)))
;; 		    (if start-res
;; 			(begin
;; 			  (hash-table-set! *runremote* run-id start-res)
;; 			  start-res)
;; 			(if (member remaining-tries '(2 5))
;; 			    (begin    ;; login failed
;; 			      (debug:print 25 "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat)
;; 			      (hash-table-delete! *runremote* run-id)
;; 			      (open-run-close tasks:server-force-clean-run-record
;; 					      tasks:open-db
;; 					      run-id 
;; 					      (tasks:hostinfo-get-interface server-dat)
;; 					      (tasks:hostinfo-get-port      server-dat)
;; 					      " client:setup (server-dat = #t)")
;; 			      (thread-sleep! 2)
;; 			      (server:try-running run-id)
;; 			      (thread-sleep! 10) ;; give server a little time to start up
;; 			      (client:setup run-id remaining-tries: 10)) ;; (- remaining-tries 1)))
;; 			    (begin
;; 			      (debug:print 25 "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat)
;; 			      (thread-sleep! 5)
;; 			      (client:setup run-id remaining-tries: (- remaining-tries 1))))))
;; 		  (begin    ;; no server registered
;; 		    (if (eq? remaining-tries 2)
;; 			(begin
;; 			  ;; (open-run-close tasks:server-clean-out-old-records-for-run-id tasks:open-db run-id " client:setup (server-dat=#f)")
;; 			  (client:setup run-id remaining-tries: 10))
;; 			(begin
;; 			  (thread-sleep! 2) 
;; 			  (debug:print 25 "INFO: client:setup start-res (not defined here), run-id=" run-id ", server-dat=" server-dat)
;; 			  (if (< (open-run-close tasks:num-in-available-state tasks:open-db run-id) 3)
;; 			      (begin
;; 				;; (open-run-close tasks:server-clean-out-old-records-for-run-id tasks:open-db run-id " client:setup (server-dat=#f)")
;; 				(server:try-running run-id)))
;; 			  (thread-sleep! 10) ;; give server a little time to start up
;; 			  (client:setup run-id remaining-tries: (- remaining-tries 1)))))))))))

;; Do all the connection work, look up the transport type and set up the
;; connection if required.
;;
;; There are two scenarios. 
;;   1. We are a test manager and we received *transport-type* and *runremote* via cmdline
;;   2. We are a run tests, list runs or other interactive process and we must figure out
;;      *transport-type* and *runremote* from the monitor.db
;;
;; client:setup
;;
;; lookup_server, need to remove *runremote* stuff
;;
(define (client:setup-http run-id #!key (remaining-tries 10) (failed-connects 0))
  (debug:print-info 2 "client:setup remaining-tries=" remaining-tries)
  (let* ((tdbdat (tasks:open-db)))
    (if (<= remaining-tries 0)

	(begin
	  (debug:print 0 "ERROR: failed to start or connect to server for run-id " run-id)
	  (exit 1))

	(let* ((server-dat (tasks:get-server (db:delay-if-busy tdbdat) run-id)))
	  (debug:print-info 4 "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries)
	  (if server-dat
	      (let* ((iface     (tasks:hostinfo-get-interface server-dat))
		     (hostname  (tasks:hostinfo-get-hostname  server-dat))
		     (port      (tasks:hostinfo-get-port      server-dat))
		     (start-res (case *transport-type*
				  ((http)(http-transport:client-connect iface port))
				  ((nmsg)(nmsg-transport:client-connect hostname port))))
		     (ping-res  (case *transport-type* 
				  ((http)(rmt:login-no-auto-client-setup start-res run-id))
				  ((nmsg)(let ((logininfo (rmt:login-no-auto-client-setup start-res run-id)))
 					   (if logininfo
 					       (car (vector-ref logininfo 1))
 					       #f))))))
		(if (and start-res
			 ping-res)
		    (begin
		      (hash-table-set! *runremote* run-id start-res)
		      (debug:print-info 2 "connected to " (http-transport:server-dat-make-url start-res))
		      start-res)
		    (begin    ;; login failed but have a server record, clean out the record and try again
		      (debug:print-info 0 "client:setup, login failed, will attempt to start server ... start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat)
		      (case *transport-type* 

			((http)(http-transport:close-connections run-id)))
		      (hash-table-delete! *runremote* run-id)
		      (tasks:kill-server-run-id run-id)
		      (tasks:server-force-clean-run-record (db:delay-if-busy tdbdat)
							   run-id 
							   (tasks:hostinfo-get-interface server-dat)
							   (tasks:hostinfo-get-port      server-dat)
							   " client:setup (server-dat = #t)")
		      (if (> remaining-tries 8)
			  (thread-sleep! (+ 1 (random 5))) ;; spread out the starts a little
			  (thread-sleep! (+ 15 (random 20)))) ;; it isn't going well. give it plenty of time
		      (server:try-running run-id)
		      (thread-sleep! 5)   ;; give server a little time to start up
		      (client:setup run-id remaining-tries: (- remaining-tries 1))
		      )))
	      (begin    ;; no server registered
		(let ((num-available (tasks:num-in-available-state (db:dbdat-get-db tdbdat) run-id)))
		  (debug:print-info 0 "client:setup, no server registered, remaining-tries=" remaining-tries " num-available=" num-available)
		  (if (< num-available 2)
		      (server:try-running run-id))
		  (thread-sleep! (+ 5 (random (- 20 remaining-tries))))  ;; give server a little time to start up, randomize a little to avoid start storms.
		  (client:setup run-id remaining-tries: (- remaining-tries 1)))))))))

;; keep this as a function to ease future 
(define (client:start run-id server-info)
  (http-transport:client-connect (tasks:hostinfo-get-interface server-info)
				 (tasks:hostinfo-get-port server-info)))







;; client:signal-handler
(define (client:signal-handler signum)
  (signal-mask! signum)
  (handle-exceptions
   exn
   (debug:print " ... exiting ...")
   (let ((th1 (make-thread (lambda ()
			     "") ;; do nothing for now (was flush out last call if applicable)
			   "eat response"))
	 (th2 (make-thread (lambda ()
			     (debug:print 0 "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.")
			     (thread-sleep! 1) ;; give the flush one second to do it's stuff
			     (debug:print 0 "       Done.")
			     (exit 4))
			   "exit on ^C timer")))
     (thread-start! th2)
     (thread-start! th1)
     (thread-join! th2))))

;; client:launch
;; Need to set the signal handler somewhere other than here as this
;; routine will go away.
;;
(define (client:launch run-id)
  (set-signal-handler! signal/int client:signal-handler)
  (if (client:setup run-id)
      (debug:print-info 2 "connected as client")
      (begin
	(debug:print 0 "ERROR: Failed to connect as client")
	(exit))))

Modified common.scm from [b4d7faf92c] to [163b8623d2].

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
;;======================================================================
;; Copyright 2006-2012, 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.
;;======================================================================

(use sqlite3 srfi-1 posix regex-case base64 format dot-locking csv-xml)
(require-extension sqlite3 regex posix)

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

(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))

(declare (unit common))

(include "common_records.scm")

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

(define getenv get-environment-variable)








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

;; global gletches
(define *db-keys* #f)
(define *configinfo* #f)
(define *configdat*  #f)
(define *toppath*    #f)
(define *already-seen-runconfig-info* #f)
(define *waiting-queue*     (make-hash-table))
(define *test-meta-updated* (make-hash-table))
(define *globalexitstatus*  0) ;; attempt to work around possible thread issues
(define *passnum*           0) ;; when running track calls to run-tests or similar



















;; SERVER
(define *my-client-signature* #f)
(define *transport-type*    'fs)
(define *megatest-db*       #f)
(define *rpc:listener*      #f) ;; if set up for server communication this will hold the tcp port
(define *runremote*         #f) ;; if set up for server communication this will hold <host port>
(define *last-db-access*    (current-seconds))  ;; update when db is accessed via server
(define *max-cache-size*    0)
(define *logged-in-clients* (make-hash-table))
(define *client-non-blocking-mode* #f)
(define *server-id*         #f)
(define *server-info*       #f)
(define *time-to-exit*      #f)
(define *received-response* #f)
(define *default-numtries*  10)
(define *server-run*        #t)
(define *db-write-access*   #t)


(define *target*            (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN
(define *keys*              (make-hash-table)) ;; cache the keys here
(define *keyvals*           (make-hash-table))
(define *toptest-paths*     (make-hash-table)) ;; cache toptest path settings here
(define *test-paths*        (make-hash-table)) ;; cache test-id to test run paths here
(define *test-ids*          (make-hash-table)) ;; cache run-id, testname, and item-path => test-id











|















>
>
>
>
>
>
>




|









>
>
>

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


|
|
<
|
<









|
|







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
;;======================================================================
;; Copyright 2006-2012, 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.
;;======================================================================

(use sqlite3 srfi-1 posix regex-case base64 format dot-locking csv-xml z3)
(require-extension sqlite3 regex posix)

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

(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))

(declare (unit common))

(include "common_records.scm")

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

(define getenv get-environment-variable)
(define (safe-setenv key val)
  (if (and (string? val)(string? key))
      (handle-exceptions
       exn
       (debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" val)
       (setenv key val))
      (debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" val)))

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

;; GLOBAL GLETCHES
(define *db-keys* #f)
(define *configinfo* #f)
(define *configdat*  #f)
(define *toppath*    #f)
(define *already-seen-runconfig-info* #f)
(define *waiting-queue*     (make-hash-table))
(define *test-meta-updated* (make-hash-table))
(define *globalexitstatus*  0) ;; attempt to work around possible thread issues
(define *passnum*           0) ;; when running track calls to run-tests or similar
(define *write-frequency*   (make-hash-table)) ;; run-id => (vector (current-seconds) 0))
(define *alt-log-file* #f)  ;; used by -log
(define *common:denoise*    (make-hash-table)) ;; for low noise printing

;; DATABASE
(define *dbstruct-db*  #f)
(define *db-stats*            (make-hash-table)) ;; hash of vectors < count duration-total >
(define *db-stats-mutex*      (make-mutex))
(define *db-sync-mutex*       (make-mutex))
(define *db-multi-sync-mutex* (make-mutex))
(define *db-local-sync*       (make-hash-table)) ;; used to record last touch of db
(define *megatest-db*         #f)
(define *last-db-access*      (current-seconds))  ;; update when db is accessed via server
(define *db-write-access*     #t)
(define *inmemdb*             #f)
(define *task-db*             #f) ;; (vector db path-to-db)
(define *db-access-allowed*   #t) ;; flag to allow access
(define *db-access-mutex*     (make-mutex))

;; SERVER
(define *my-client-signature* #f)
(define *transport-type*    'http)
(define *transport-type*    'http)             ;; override with [server] transport http|rpc|nmsg

(define *runremote*         (make-hash-table)) ;; if set up for server communication this will hold <host port>

(define *max-cache-size*    0)
(define *logged-in-clients* (make-hash-table))
(define *client-non-blocking-mode* #f)
(define *server-id*         #f)
(define *server-info*       #f)
(define *time-to-exit*      #f)
(define *received-response* #f)
(define *default-numtries*  10)
(define *server-run*        #t)
(define *run-id*            #f)
(define *server-kind-run*   (make-hash-table))

(define *target*            (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN
(define *keys*              (make-hash-table)) ;; cache the keys here
(define *keyvals*           (make-hash-table))
(define *toptest-paths*     (make-hash-table)) ;; cache toptest path settings here
(define *test-paths*        (make-hash-table)) ;; cache test-id to test run paths here
(define *test-ids*          (make-hash-table)) ;; cache run-id, testname, and item-path => test-id
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
  (set! *toptest-paths*      (make-hash-table))
  (set! *test-paths*         (make-hash-table))
  (set! *test-ids*           (make-hash-table))
  (set! *test-info*          (make-hash-table))
  (set! *run-info-cache*     (make-hash-table))
  (set! *env-vars-by-run-id* (make-hash-table))
  (set! *test-id-cache*      (make-hash-table)))






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





































































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

(define *common:std-states*   



  (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ" "STUCK"))






(define *common:std-statuses*








  (list  "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD"))


;; These are stopping conditions that prevent a test from being run
(define *common:cant-run-states-sym* 
  '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE))

;;======================================================================
;; D E B U G G I N G   S T U F F 
;;======================================================================

(define *verbosity*         1)
(define *logging*           #f)

(define (get-with-default val default)
  (let ((val (args:get-arg val)))
    (if val val default)))

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








































;;======================================================================
;; Misc utils
;;======================================================================

;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5
(define (common:hms-string->seconds tstr)
  (let ((parts     (string-split tstr))








>
>
>
>
>

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




>
>
>
|
>
>
>
>
>


>
>
>
>
>
>
>
>
|
>



|
















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







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
  (set! *toptest-paths*      (make-hash-table))
  (set! *test-paths*         (make-hash-table))
  (set! *test-ids*           (make-hash-table))
  (set! *test-info*          (make-hash-table))
  (set! *run-info-cache*     (make-hash-table))
  (set! *env-vars-by-run-id* (make-hash-table))
  (set! *test-id-cache*      (make-hash-table)))

;; Generic string database
(define sdb:qry #f) ;; (make-sdb:qry)) ;;  'init #f)
;; Generic path database
(define *fdb* #f)

;;======================================================================
;; L O C K E R S   A N D   B L O C K E R S 
;;======================================================================

;; block further accesses to databases. Call this before shutting db down
(define (common:db-block-further-queries)
  (mutex-lock! *db-access-mutex*)
  (set! *db-access-allowed* #f)
  (mutex-unlock! *db-access-mutex*))

(define (common:db-access-allowed?)
  (let ((val (begin
	       (mutex-lock! *db-access-mutex*)
	       *db-access-allowed*
	       (mutex-unlock! *db-access-mutex*))))
    val))

;;======================================================================
;; U S E F U L   S T U F F
;;======================================================================

(define (common:low-noise-print waitval . keys)
  (let* ((key      (string-intersperse (map conc keys) "-" ))
	 (lasttime (hash-table-ref/default *common:denoise* key 0))
	 (currtime (current-seconds)))
    (if (> (- currtime lasttime) waitval)
	(begin
	  (hash-table-set! *common:denoise* key currtime)
	  #t)
	#f)))

(define (common:get-megatest-exe)
  (if (getenv "MT_MEGATEST") (getenv "MT_MEGATEST") "megatest"))

(define (common:read-encoded-string instr)
  (handle-exceptions
   exn
   (handle-exceptions
    exn
    (begin
      (debug:print 0 "ERROR: received bad encoded string \"" instr "\", message: " ((condition-property-accessor 'exn 'message) 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))
  (if (file-exists? fname)
      (if (> (- (current-seconds)(file-modification-time fname)) expire-time)
	  (begin
	    (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)
	(with-input-from-file fname
	  (lambda ()
	    (equal? key-string (read-line)))))))
	
(define (common:simple-file-release-lock fname)
  (delete-file* fname))

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

(define *common:std-states*   
  '((0 "COMPLETED")
    (1 "NOT_STARTED")
    (2 "RUNNING")
    (3 "REMOTEHOSTSTART")
    (4 "LAUNCHED")
    (5 "KILLED")
    (6 "KILLREQ")
    (7 "STUCK")
    (8 "ARCHIVED")))

(define *common:std-statuses*
  '((0 "PASS")
    (1 "WARN")
    (2 "FAIL")
    (3 "CHECK")
    (4 "n/a")
    (5 "WAIVED")
    (6 "SKIP")
    (7 "DELETED")
    (8 "STUCK/DEAD")
    (9 "ABORT")))

;; These are stopping conditions that prevent a test from being run
(define *common:cant-run-states-sym* 
  '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE ABORT ARCHIVED))

;;======================================================================
;; D E B U G G I N G   S T U F F 
;;======================================================================

(define *verbosity*         1)
(define *logging*           #f)

(define (get-with-default val default)
  (let ((val (args:get-arg val)))
    (if val val default)))

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

(define (common:get-testsuite-name)
  (or (configf:lookup *configdat* "setup" "testsuite" )
       (pathname-file *toppath*)))

;;======================================================================
;; E X I T   H A N D L I N G
;;======================================================================

(define (std-exit-procedure)
  (debug:print-info 2 "starting exit process, finalizing databases.")
  (rmt:print-db-stats)
  (let ((run-ids (hash-table-keys *db-local-sync*)))
    (if (and (not (null? run-ids))
	     (configf:lookup *configdat* "setup" "megatest-db"))
	(db:multi-db-sync run-ids 'new2old)))
  (if *dbstruct-db* (db:close-all *dbstruct-db*))
  (if *inmemdb*     (db:close-all *inmemdb*))
  (if (and *megatest-db*
	   (sqlite3:database? *megatest-db*))
      (begin
	(sqlite3:interrupt! *megatest-db*)
	(sqlite3:finalize! *megatest-db* #t)
	(set! *megatest-db* #f)))
  (if *task-db*     (let ((db (cdr *task-db*)))
		      (if (sqlite3:database? db)
			  (begin
			    (sqlite3:interrupt! db)
			    (sqlite3:finalize! db #t)
			    (vector-set! *task-db* 0 #f))))))

(define (std-signal-handler signum)
  (signal-mask! signum)
  (debug:print 0 "ERROR: Received signal " signum " exiting promptly")
  ;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway
  (exit))

(set-signal-handler! signal/int std-signal-handler)
(set-signal-handler! signal/term std-signal-handler)

;;======================================================================
;; Misc utils
;;======================================================================

;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5
(define (common:hms-string->seconds tstr)
  (let ((parts     (string-split tstr))
183
184
185
186
187
188
189
190
191

192
193

194
195
196
197
198
199
200
201
202
203
204
205
	     (if (string-match (regexp modpatt) item)
		 (set! res #t))))
	 (string-split patts ","))
	res)
      #t))

;; (map print (map car (hash-table->alist (read-config "runconfigs.config" #f #t))))
(define (common:get-runconfig-targets)
  (sort (map car (hash-table->alist

		  (read-config "runconfigs.config"
			       #f #t))) string<?))


;; '(print (string-intersperse (map cadr (hash-table-ref/default (read-config "megatest.config" \#f \#t) "disks" '"'"'("none" ""))) "\n"))'
(define (common:get-disks)
  (hash-table-ref/default 
   (read-config "megatest.config" #f #t)
   "disks" '("none" "")))

;;======================================================================
;; T A R G E T S
;;======================================================================

(define (common:args-get-target #!key (split #f))







|

>
|
|
>


|

|







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
	     (if (string-match (regexp modpatt) item)
		 (set! res #t))))
	 (string-split patts ","))
	res)
      #t))

;; (map print (map car (hash-table->alist (read-config "runconfigs.config" #f #t))))
(define (common:get-runconfig-targets #!key (configf #f))
  (sort (map car (hash-table->alist
		  (or configf
		      (read-config "runconfigs.config"
			       #f #t))))
	string<?))

;; '(print (string-intersperse (map cadr (hash-table-ref/default (read-config "megatest.config" \#f \#t) "disks" '"'"'("none" ""))) "\n"))'
(define (common:get-disks #!key (configf #f))
  (hash-table-ref/default 
   (or configf (read-config "megatest.config" #f #t))
   "disks" '("none" "")))

;;======================================================================
;; T A R G E T S
;;======================================================================

(define (common:args-get-target #!key (split #f))
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

;; return a nice clean pathname made absolute
(define (nice-path dir)
  (normalize-pathname (if (absolute-pathname? dir)
			  dir
			  (conc (current-directory) "/" dir))))

(define (get-df path)
  (let* ((df-results (cmd-run->list (conc "df " path)))
	 (space-rx   (regexp "([0-9]+)\\s+([0-9]+)%"))
	 (freespc    #f))
    ;; (write df-results)
    (for-each (lambda (l)
		(let ((match (string-search space-rx l)))
		  (if match 
		      (let ((newval (string->number (cadr match))))
			(if (number? newval)
			    (set! freespc newval))))))
	      (car df-results))
    freespc))
  
(define (get-cpu-load)
  (car (common:get-cpu-load)))
;;   (let* ((load-res (cmd-run->list "uptime"))
;; 	 (load-rx  (regexp "load average:\\s+(\\d+)"))
;; 	 (cpu-load #f))
;;     (for-each (lambda (l)
;; 		(let ((match (string-search load-rx l)))







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







465
466
467
468
469
470
471














472
473
474
475
476
477
478

;; return a nice clean pathname made absolute
(define (nice-path dir)
  (normalize-pathname (if (absolute-pathname? dir)
			  dir
			  (conc (current-directory) "/" dir))))















(define (get-cpu-load)
  (car (common:get-cpu-load)))
;;   (let* ((load-res (cmd-run->list "uptime"))
;; 	 (load-rx  (regexp "load average:\\s+(\\d+)"))
;; 	 (cpu-load #f))
;;     (for-each (lambda (l)
;; 		(let ((match (string-search load-rx l)))
380
381
382
383
384
385
386
387

























































388
389
390
391
392
393
394
395

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

























































(define (save-environment-as-files fname #!key (ignorevars (list "USER" "HOME" "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR")))
  (let ((envvars (get-environment-variables))
        (whitesp (regexp "[^a-zA-Z0-9_\\-:,.\\/%$]")))
     (with-output-to-file (conc fname ".csh")
       (lambda ()
          (for-each (lambda (keyval)
		      (let* ((key   (car keyval))
			     (val   (cdr keyval))







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







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

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

;;======================================================================
;; D I S K   S P A C E 
;;======================================================================

(define (common:get-disk-space-used fpath)
  (with-input-from-pipe (conc "/usr/bin/du -s " fpath) read))

(define (get-df path)
  (let* ((df-results (cmd-run->list (conc "df " path)))
	 (space-rx   (regexp "([0-9]+)\\s+([0-9]+)%"))
	 (freespc    #f))
    ;; (write df-results)
    (for-each (lambda (l)
		(let ((match (string-search space-rx l)))
		  (if match 
		      (let ((newval (string->number (cadr match))))
			(if (number? newval)
			    (set! freespc newval))))))
	      (car df-results))
    freespc))
  
;; paths is list of lists ((name path) ... )
;;
(define (common:get-disk-with-most-free-space disks minsize)
  (let ((best     #f)
	(bestsize 0))
    (for-each 
     (lambda (disk-num)
       (let* ((dirpath    (cadr (assoc disk-num disks)))
	      (freespc    (cond
			   ((not (directory? dirpath))
			    (if (common:low-noise-print 50 "disks not a dir " disk-num)
				(debug:print 0 "WARNING: disk " disk-num " at path " dirpath " is not a directory - ignoring it."))
			    -1)
			   ((not (file-write-access? dirpath))
			    (if (common:low-noise-print 50 "disks not writeable " disk-num)
				(debug:print 0 "WARNING: disk " disk-num " at path " dirpath " is not writeable - ignoring it."))
			    -1)
			   ((not (eq? (string-ref dirpath 0) #\/))
			    (if (common:low-noise-print 50 "disks not a proper path " disk-num)
				(debug:print 0 "WARNING: disk " disk-num " at path " dirpath " is not a fully qualified path - ignoring it."))
			    -1)
			   (else
			    (get-df dirpath)))))
	 (if (> freespc bestsize)
	     (begin
	       (set! best     (cons disk-num dirpath))
	       (set! bestsize freespc)))))
     (map car disks))
    (if (and best (> bestsize minsize))
	best
	#f))) ;; #f means no disk candidate found

;;======================================================================
;; E N V I R O N M E N T   V A R S
;;======================================================================
	      
(define (save-environment-as-files fname #!key (ignorevars (list "USER" "HOME" "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR" "MAKEFLAGS" "MAKEF")))
  (let ((envvars (get-environment-variables))
        (whitesp (regexp "[^a-zA-Z0-9_\\-:,.\\/%$]")))
     (with-output-to-file (conc fname ".csh")
       (lambda ()
          (for-each (lambda (keyval)
		      (let* ((key   (car keyval))
			     (val   (cdr keyval))
459
460
461
462
463
464
465











466
467
468
469
470
471
472
(define (seconds->year-work-week/day sec)
  (time->string
   (seconds->local-time sec) "%yww%V.%w"))

(define (seconds->year-work-week/day-time sec)
  (time->string
   (seconds->local-time sec) "%yww%V.%w %H:%M"))












;;======================================================================
;; Colors
;;======================================================================
      
(define (common:name->iup-color name)
  (case (string->symbol (string-downcase name))







>
>
>
>
>
>
>
>
>
>
>







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
(define (seconds->year-work-week/day sec)
  (time->string
   (seconds->local-time sec) "%yww%V.%w"))

(define (seconds->year-work-week/day-time sec)
  (time->string
   (seconds->local-time sec) "%yww%V.%w %H:%M"))

(define (seconds->quarter sec)
  (case (string->number
	 (time->string 
	  (seconds->local-time sec)
	  "%m"))
    ((1 2 3) 1)
    ((4 5 6) 2)
    ((7 8 9) 3)
    ((10 11 12) 4)
    (else #f)))

;;======================================================================
;; Colors
;;======================================================================
      
(define (common:name->iup-color name)
  (case (string->symbol (string-downcase name))
496
497
498
499
500
501
502

503
  (cond
   ((equal? status "PASS")    "green")
   ((equal? status "FAIL")    "red")
   ((equal? status "WARN")    "orange")
   ((equal? status "KILLED")  "orange")
   ((equal? status "KILLREQ") "purple")
   ((equal? status "RUNNING") "blue")

   (else "black")))







>

705
706
707
708
709
710
711
712
713
  (cond
   ((equal? status "PASS")    "green")
   ((equal? status "FAIL")    "red")
   ((equal? status "WARN")    "orange")
   ((equal? status "KILLED")  "orange")
   ((equal? status "KILLREQ") "purple")
   ((equal? status "RUNNING") "blue")
   ((equal? status "ABORT")   "brown")
   (else "black")))

Modified common_records.scm from [61ac915575] to [b04cfb11d1].

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
;;======================================================================
;; Copyright 2006-2012, 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.
;;======================================================================

;; (use trace)




















(define (debug:calc-verbosity vstr)
  (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)))

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

  (or (and (number? *verbosity*)

	   (<= n *verbosity*))
      (and (list? *verbosity*)

	   (member n *verbosity*))))







(define (debug:setup)
  (let ((debugstr (or (args:get-arg "-debug")
		      (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 (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 . params)
  (if (debug:debug-mode n)
      (with-output-to-port (current-error-port)
	(lambda ()
	  (if *logging*
	      (db:log-event (apply conc params))

	      (apply print params)
	      )))))

(define (debug:print-info n . params)
  (if (debug:debug-mode n)
      (with-output-to-port (current-error-port)
	(lambda ()
	  (let ((res (format#format #f "INFO: (~2d) ~a" n (apply conc params))))
	    (if *logging*
		(db:log-event 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 ""))














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






|



|













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




















>







|


>








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
;;======================================================================
;; Copyright 2006-2012, 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.
;;======================================================================

;; (use trace)

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

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

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

(define (debug:calc-verbosity vstr)
  (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)))

;; 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")
		      (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 (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 . params)
  (if (debug:debug-mode n)
      (with-output-to-port (current-error-port)
	(lambda ()
	  (if *logging*
	      (db:log-event (apply conc params))
	      ;; (apply print "pid:" (current-process-id) " " params)
	      (apply print params)
	      )))))

(define (debug:print-info n . params)
  (if (debug:debug-mode n)
      (with-output-to-port (current-error-port)
	(lambda ()
	  (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params))))
	    (if *logging*
		(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 configf.scm from [35104b9121] to [04a7bf6224].

59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
(define configf:key-no-val (regexp "^(\\S+)(\\s*)$"))
(define configf:comment-rx (regexp "^\\s*#.*"))
(define configf:cont-ln-rx (regexp "^(\\s+)(\\S+.*)$"))

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

(define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get|rget)\\s+([^\\}\\{]*)\\}(.*)"))
(define (configf:process-line l ht)
  (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))







|







59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
(define configf:key-no-val (regexp "^(\\S+)(\\s*)$"))
(define configf:comment-rx (regexp "^\\s*#.*"))
(define configf:cont-ln-rx (regexp "^(\\s+)(\\S+.*)$"))

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

(define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get|rget)\\s+([^\\}\\{]*)\\}(.*)"))
(define (configf:process-line l ht allow-system)
  (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))
83
84
85
86
87
88
89


90
91
92
93
94
95
96
97
98
99
100
					(sect  (car parts))
					(var   (cadr parts)))
				   (conc "(lambda (ht)(config-lookup ht \"" sect "\" \"" var "\"))")))
				((runconfigs-get) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
				((rget)           (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
				(else "(lambda (ht)(print \"ERROR\") \"ERROR\")"))))
		;; (print "fullcmd=" fullcmd)


		(with-input-from-string fullcmd
		  (lambda ()
		    (set! result ((eval (read)) ht))))
		(loop (conc prestr result poststr)))
	      res))
	res)))

;; Run a shell command and return the output as a string
(define (shell cmd)
  (let* ((output (cmd-run->list cmd))
	 (res    (car output))







>
>
|
|
|
|







83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
					(sect  (car parts))
					(var   (cadr parts)))
				   (conc "(lambda (ht)(config-lookup ht \"" sect "\" \"" var "\"))")))
				((runconfigs-get) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
				((rget)           (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
				(else "(lambda (ht)(print \"ERROR\") \"ERROR\")"))))
		;; (print "fullcmd=" fullcmd)
		(if (or allow-system
			(not (member cmdtype '("system" "shell"))))
		    (with-input-from-string fullcmd
		      (lambda ()
			(set! result ((eval (read)) ht))))
		    (set! result (conc "#{(" cmdtype ") "  cmd "}")))		(loop (conc prestr result poststr)))
	      res))
	res)))

;; Run a shell command and return the output as a string
(define (shell cmd)
  (let* ((output (cmd-run->list cmd))
	 (res    (car output))
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
(define (runconfigs-get config var)
  (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET"))))
    (if targ
	(or (configf:lookup config targ var)
	    (configf:lookup config "default" var))
	(configf:lookup config "default" var))))



(define-inline (configf:read-line p ht allow-processing)
  (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))))
	  (if (and allow-processing 
		   (not (eq? allow-processing 'return-string)))

	      (configf:process-line inl ht)

	      inl)))))



;; 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)
;; 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
(define (read-config path ht allow-system #!key (environ-patt #f)(curr-section #f)(sections #f))
  (debug:print-info 5 "read-config " path " allow-system " allow-system " environ-patt " environ-patt " curr-section: " curr-section " sections: " sections " pwd: " (current-directory))

  (if (not (file-exists? path))
      (begin 
	(debug:print-info 1 "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        (open-input-file path))
	    (res        (if (not ht)(make-hash-table) ht)))
	(let loop ((inl               (configf:read-line inp res allow-system)) ;; (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 "curr-section-name: " curr-section-name " var-flag: " var-flag "\n   inl: \"" inl "\"")
	  (if (eof-object? inl) 
	      (begin
		(close-input-port inp)
		(hash-table-delete! res "") ;; we are using "" as a dumping ground and must remove it before returning the ht

		res)
	      (regex-case 
	       inl 
	       (configf:comment-rx _                  (loop (configf:read-line inp res allow-system) curr-section-name #f #f))
	       (configf:blank-l-rx _                  (loop (configf:read-line inp res allow-system) curr-section-name #f #f))
	       (configf:include-rx ( x include-file ) (let* ((curr-conf-dir (pathname-directory path))
							     (full-conf     (if (absolute-pathname? include-file)
										include-file
										(nice-path 
										 (conc (if curr-conf-dir
											   curr-conf-dir
											   ".")
										       "/" include-file)))))
							(if (file-exists? full-conf)
							    (begin
							      ;; (push-directory conf-dir)

							      (read-config full-conf res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections)
							      ;; (pop-directory)
							      (loop (configf:read-line inp res allow-system) curr-section-name #f #f))
							    (begin
							      (debug:print 2 "INFO: include file " include-file " not found (called from " path ")")
							      (debug:print 2 "        " full-conf)
							      (loop (configf:read-line inp res allow-system) curr-section-name #f #f)))))
	       (configf:section-rx ( x section-name ) (loop (configf:read-line inp res allow-system)
							    ;; 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 ""







>
>
|











|
|
>
|
>
|
>
>










>
















>
















>




|







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
(define (runconfigs-get config var)
  (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET"))))
    (if targ
	(or (configf:lookup config targ var)
	    (configf:lookup config "default" var))
	(configf:lookup config "default" var))))

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

;; 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)
;; 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
(define (read-config path ht allow-system #!key (environ-patt #f)(curr-section #f)(sections #f))
  (debug:print-info 5 "read-config " path " allow-system " allow-system " environ-patt " environ-patt " curr-section: " curr-section " sections: " sections " pwd: " (current-directory))
  (debug:print 9 "START: " path)
  (if (not (file-exists? path))
      (begin 
	(debug:print-info 1 "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        (open-input-file path))
	    (res        (if (not ht)(make-hash-table) ht)))
	(let loop ((inl               (configf:read-line inp res allow-system)) ;; (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 "curr-section-name: " curr-section-name " var-flag: " var-flag "\n   inl: \"" inl "\"")
	  (if (eof-object? inl) 
	      (begin
		(close-input-port inp)
		(hash-table-delete! res "") ;; we are using "" as a dumping ground and must remove it before returning the ht
		(debug:print 9 "END: " path)
		res)
	      (regex-case 
	       inl 
	       (configf:comment-rx _                  (loop (configf:read-line inp res allow-system) curr-section-name #f #f))
	       (configf:blank-l-rx _                  (loop (configf:read-line inp res allow-system) curr-section-name #f #f))
	       (configf:include-rx ( x include-file ) (let* ((curr-conf-dir (pathname-directory path))
							     (full-conf     (if (absolute-pathname? include-file)
										include-file
										(nice-path 
										 (conc (if curr-conf-dir
											   curr-conf-dir
											   ".")
										       "/" include-file)))))
							(if (file-exists? full-conf)
							    (begin
							      ;; (push-directory conf-dir)
							      (debug:print 9 "Including: " full-conf)
							      (read-config full-conf res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections)
							      ;; (pop-directory)
							      (loop (configf:read-line inp res allow-system) curr-section-name #f #f))
							    (begin
							      (debug:print '(2 9) "INFO: include file " include-file " not found (called from " path ")")
							      (debug:print 2 "        " full-conf)
							      (loop (configf:read-line inp res allow-system) curr-section-name #f #f)))))
	       (configf:section-rx ( x section-name ) (loop (configf:read-line inp res allow-system)
							    ;; 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 ""
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
												 " output: " cmdres)
										    (exit 1)))
									      (if (null? res)
										  ""
										  (string-intersperse res " "))))))
							    (hash-table-set! res curr-section-name 
									     (config:assoc-safe-add alist
												    key 
												    (case allow-system
												      ((return-procs) val-proc)
												      ((return-string) cmd)
												      (else (val-proc)))))
							    (loop (configf:read-line inp res allow-system) curr-section-name #f #f))
							  (loop (configf:read-line inp res allow-system) curr-section-name #f #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)))
								  (realval (if envar
									       (config:eval-string-in-environment val)
									       val)))
							     (debug:print-info 6 "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name)
							     (if envar
								 (begin
								   ;; (debug:print-info 4 "read-config key=" key ", val=" val ", realval=" realval)
								   (setenv key realval)))
							     (hash-table-set! res curr-section-name 
									      (config:assoc-safe-add alist key realval))
							     (loop (configf:read-line inp res allow-system) curr-section-name key #f)))
	       (configf:key-no-val ( x key val)             (let* ((alist   (hash-table-ref/default res curr-section-name '())))

							      (hash-table-set! res curr-section-name 
									       (config:assoc-safe-add alist key #t))
							      (loop (configf:read-line inp res allow-system) 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 







|












|
<
|
<




>







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
												 " output: " cmdres)
										    (exit 1)))
									      (if (null? res)
										  ""
										  (string-intersperse res " "))))))
							    (hash-table-set! res curr-section-name 
									     (config:assoc-safe-add alist
									   			    key 
												    (case allow-system
												      ((return-procs) val-proc)
												      ((return-string) cmd)
												      (else (val-proc)))))
							    (loop (configf:read-line inp res allow-system) curr-section-name #f #f))
							  (loop (configf:read-line inp res allow-system) curr-section-name #f #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)))
								  (realval (if envar
									       (config:eval-string-in-environment val)
									       val)))
							     (debug:print-info 6 "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 "   setting: [" curr-section-name "] " key " = " val)

							     (hash-table-set! res curr-section-name 
									      (config:assoc-safe-add alist key realval))
							     (loop (configf:read-line inp res allow-system) curr-section-name key #f)))
	       (configf:key-no-val ( x key val)             (let* ((alist   (hash-table-ref/default res curr-section-name '())))
							      (debug:print 10 "   setting: [" curr-section-name "] " key " = #t")
							      (hash-table-set! res curr-section-name 
									       (config:assoc-safe-add alist key #t))
							      (loop (configf:read-line inp res allow-system) 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 
458
459
460
461
462
463
464
465

466
467
468
469
470
471
472
	       (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))))))

	       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 







|
>







468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
	       (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 
482
483
484
485
486
487
488
489


























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

































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

(define (configf:read-alist fname)
  (configf:alist->config
   (with-input-from-file fname read)))

(define (configf:write-alist cdat fname)
  (with-output-to-file fname
    (lambda ()
      (pp (configf:config->alist cdat)))))
     

Modified dashboard-tests.scm from [a4ddccb773] to [9124f50a29].

22
23
24
25
26
27
28

29


30
31
32
33
34
35
36
37


38
39
40
41
42
43
44
(use sqlite3 srfi-1 posix regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:))

(declare (unit dashboard-tests))
(declare (uses common))
(declare (uses db))
(declare (uses gutils))

(declare (uses ezsteps))



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

;;======================================================================
;; C O M M O N
;;======================================================================



(define (dtests:get-pre-command #!key (default-override #f))
  (let ((cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command")))
    (or cfg-ovrd default-override "xterm -geometry 180x20 -e \"")))

(define (dtests:get-post-command #!key (default-override #f))
  (let ((cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command")))







>

>
>








>
>







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
(use sqlite3 srfi-1 posix regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:))

(declare (unit dashboard-tests))
(declare (uses common))
(declare (uses db))
(declare (uses gutils))
(declare (uses rmt))
(declare (uses ezsteps))
;; (declare (uses sdb))
;; (declare (uses filedb))

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

;;======================================================================
;; C O M M O N
;;======================================================================

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

(define (dtests:get-pre-command #!key (default-override #f))
  (let ((cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command")))
    (or cfg-ovrd default-override "xterm -geometry 180x20 -e \"")))

(define (dtests:get-post-command #!key (default-override #f))
  (let ((cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command")))
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
	   (append (map (lambda (val)
			  (iup:label val ; #:expand "HORIZONTAL"
				     ))
			(list "Author: "
			      "Owner: "
			      "Reviewed: "
			      "Tags: "
			      "Description: "
			      ))
		   (list (iup:label "" #:expand "VERTICAL"))))
    (apply iup:vbox  ; #:expand "YES"
	   (list 
	    (store-meta "author"
			 (iup:label (db:testmeta-get-author testmeta) #:expand "HORIZONTAL")
			 (lambda (testmeta)(db:testmeta-get-author testmeta)))
	    (store-meta "owner"







|
<







128
129
130
131
132
133
134
135

136
137
138
139
140
141
142
	   (append (map (lambda (val)
			  (iup:label val ; #:expand "HORIZONTAL"
				     ))
			(list "Author: "
			      "Owner: "
			      "Reviewed: "
			      "Tags: "
			      "Description: "))

		   (list (iup:label "" #:expand "VERTICAL"))))
    (apply iup:vbox  ; #:expand "YES"
	   (list 
	    (store-meta "author"
			 (iup:label (db:testmeta-get-author testmeta) #:expand "HORIZONTAL")
			 (lambda (testmeta)(db:testmeta-get-author testmeta)))
	    (store-meta "owner"
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
			   (test-meta-panel-get-description testmeta)))
	    )))))


;;======================================================================
;; Run info panel
;;======================================================================
(define (run-info-panel keydat testdat runname)
  (let* ((run-id     (db:test-get-run_id testdat))
	 (rundat     (cdb:remote-run db:get-run-info #f run-id))
	 (header     (db:get-header rundat))
	 (event_time (db:get-value-by-header (db:get-row rundat)
					     (db:get-header rundat)
					     "event_time")))
    (iup:frame 
     #:title "Megatest Run Info" ; #:expand "YES"
     (iup:hbox ; #:expand "YES"
      (apply iup:vbox ; #:expand "YES"
	     (append (map (lambda (keyval)







|

|

|







154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
			   (test-meta-panel-get-description testmeta)))
	    )))))


;;======================================================================
;; Run info panel
;;======================================================================
(define (run-info-panel db keydat testdat runname)
  (let* ((run-id     (db:test-get-run_id testdat))
	 (rundat     (db:get-run-info db run-id))
	 (header     (db:get-header rundat))
	 (event_time (db:get-value-by-header (db:get-rows rundat)
					     (db:get-header rundat)
					     "event_time")))
    (iup:frame 
     #:title "Megatest Run Info" ; #:expand "YES"
     (iup:hbox ; #:expand "YES"
      (apply iup:vbox ; #:expand "YES"
	     (append (map (lambda (keyval)
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
			  (iup:label val ; #:expand "HORIZONTAL"
				     ))
			(list "Hostname: "
			      "Uname -a: "
			      "Disk free: "
			      "CPU Load: "
			      "Run duration: "
			      "Logfile: "))

		   (iup:label "" #:expand "VERTICAL")))
    (apply iup:vbox ; #:expand "YES"
	   (list
	    ;; NOTE: Yes, the host can change!
	    (store-label "HostName"

			 (iup:label (db:test-get-host testdat) #:expand "HORIZONTAL")

			 (lambda (testdat)(db:test-get-host testdat)))
	    (store-label "Uname"
			 (iup:label "                                                   " #:expand "HORIZONTAL")

			 (lambda (testdat)(db:test-get-uname testdat)))
	    (store-label "DiskFree"
			 (iup:label (conc (db:test-get-diskfree testdat)) #:expand "HORIZONTAL")
			 (lambda (testdat)(conc (db:test-get-diskfree testdat))))
	    (store-label "CPULoad"
			 (iup:label (conc (db:test-get-cpuload testdat)) #:expand "HORIZONTAL")
			 (lambda (testdat)(conc (db:test-get-cpuload testdat))))
	    (store-label "RunDuration"
			 (iup:label (conc (seconds->hr-min-sec (db:test-get-run_duration testdat))) #:expand "HORIZONTAL")
			 (lambda (testdat)(conc (seconds->hr-min-sec (db:test-get-run_duration testdat)))))
	    (store-label "CPULoad"
			 (iup:label (conc (db:test-get-final_logf testdat)) #:expand "HORIZONTAL")
			 (lambda (testdat)(conc (db:test-get-final_logf testdat)))))))))





;; use a global for setting the buttons colors
;;                           state status teststeps
(define *state-status* (vector #f #f #f))
(define (update-state-status-buttons testdat)
  (let* ((state  (db:test-get-state  testdat))
	 (status (db:test-get-status testdat))
	 (color  (car (gutils:get-color-for-state-status state status))))
    ((vector-ref *state-status* 0) state color)
    ((vector-ref *state-status* 1) status color)))

(define *dashboard-test-db* #t)
(define *dashboard-comment-share-slot* #f)

;;======================================================================
;; Set fields 
;;======================================================================
(define (set-fields-panel test-id testdat #!key (db #f))
  (let ((newcomment #f)
	(newstatus  #f)
	(newstate   #f)
	(wtxtbox    #f))
    (iup:frame
     #:title "Set fields"
     (iup:vbox
      (iup:hbox (iup:label "Comment:")
		(let ((txtbox (iup:textbox #:action (lambda (val a b)

						      ;; IDEA: Just set a variable with the proc to call?
						      (open-run-close db:test-set-state-status-by-id db test-id #f #f b)
						      (set! newcomment b))
					   #:value (db:test-get-comment testdat)
					   #:expand "HORIZONTAL")))
		  (set! wtxtbox txtbox)
		  txtbox))
		  
      (apply iup:hbox
	     (iup:label "STATE:" #:size "30x")
	     (let* ((btns  (map (lambda (state)
				  (let ((btn (iup:button state
							 #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10"
							 #:action (lambda (x)
								    (open-run-close db:test-set-state-status-by-id db test-id state #f #f)
								    (db:test-set-state! testdat state)))))
				    btn))
				*common:std-states*))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ"))))
	       (vector-set! *state-status* 0
			    (lambda (state color)
			      (for-each 
			       (lambda (btn)
				 (let* ((name     (iup:attribute btn "TITLE"))
					(newcolor (if (equal? name state) color "192 192 192")))
				   (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR")))
				       (iup:attribute-set! btn "BGCOLOR" newcolor))))
			       btns)))
	       btns))
      (apply iup:hbox
	     (iup:label "STATUS:" #:size "30x")
	     (let* ((btns  (map (lambda (status)
				  (let ((btn (iup:button status
							 #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10"
							 #:action (lambda (x)
								    (let ((t (iup:attribute x "TITLE")))
								      (if (equal? t "WAIVED")
									  (iup:show (dashboard-tests:waiver testdat 
													    (if wtxtbox (iup:attribute wtxtbox "VALUE") #f)
													    (lambda (c)
													      (set! newcomment c)
													      (if wtxtbox 
														  (begin
														    (iup:attribute-set! wtxtbox "VALUE" c)
														    (if (not *dashboard-comment-share-slot*)
															(set! *dashboard-comment-share-slot* wtxtbox)))
														  ))))
									  (begin
									    (open-run-close db:test-set-state-status-by-id db test-id #f status #f)
									    (db:test-set-status! testdat status))))))))
				    btn))
				*common:std-statuses*))) ;; (list  "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP"))))
	       (vector-set! *state-status* 1
			    (lambda (status color)
			      (for-each 
			       (lambda (btn)
				 (let* ((name     (iup:attribute btn "TITLE"))
					(newcolor (if (equal? name status) color "192 192 192")))
				   (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR")))







|
>





>
|
>



>
|









|

|
>
>
>
>

















|









>

|












|


|


















|










|


|







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
			  (iup:label val ; #:expand "HORIZONTAL"
				     ))
			(list "Hostname: "
			      "Uname -a: "
			      "Disk free: "
			      "CPU Load: "
			      "Run duration: "
			      "Logfile: "
			      "Top process id: "))
		   (iup:label "" #:expand "VERTICAL")))
    (apply iup:vbox ; #:expand "YES"
	   (list
	    ;; NOTE: Yes, the host can change!
	    (store-label "HostName"
			 (iup:label ;; (sdb:qry 'getstr 
			  (db:test-get-host testdat) ;; )
			  #:expand "HORIZONTAL")
			 (lambda (testdat)(db:test-get-host testdat)))
	    (store-label "Uname"
			 (iup:label "                                                   " #:expand "HORIZONTAL")
			 (lambda (testdat) ;; (sdb:qry 'getstr 
			   (db:test-get-uname testdat))) ;; )
	    (store-label "DiskFree"
			 (iup:label (conc (db:test-get-diskfree testdat)) #:expand "HORIZONTAL")
			 (lambda (testdat)(conc (db:test-get-diskfree testdat))))
	    (store-label "CPULoad"
			 (iup:label (conc (db:test-get-cpuload testdat)) #:expand "HORIZONTAL")
			 (lambda (testdat)(conc (db:test-get-cpuload testdat))))
	    (store-label "RunDuration"
			 (iup:label (conc (seconds->hr-min-sec (db:test-get-run_duration testdat))) #:expand "HORIZONTAL")
			 (lambda (testdat)(conc (seconds->hr-min-sec (db:test-get-run_duration testdat)))))
	    (store-label "LogFile"
			 (iup:label (conc (db:test-get-final_logf testdat)) #:expand "HORIZONTAL")
			 (lambda (testdat)(conc (db:test-get-final_logf testdat))))
	    (store-label "ProcessId"
			 (iup:label (conc (db:test-get-process_id testdat)) #:expand "HORIZONTAL")
			 (lambda (testdat)(conc (db:test-get-process_id testdat))))
	    )))))

;; use a global for setting the buttons colors
;;                           state status teststeps
(define *state-status* (vector #f #f #f))
(define (update-state-status-buttons testdat)
  (let* ((state  (db:test-get-state  testdat))
	 (status (db:test-get-status testdat))
	 (color  (car (gutils:get-color-for-state-status state status))))
    ((vector-ref *state-status* 0) state color)
    ((vector-ref *state-status* 1) status color)))

(define *dashboard-test-db* #t)
(define *dashboard-comment-share-slot* #f)

;;======================================================================
;; Set fields 
;;======================================================================
(define (set-fields-panel dbstruct run-id test-id testdat #!key (db #f))
  (let ((newcomment #f)
	(newstatus  #f)
	(newstate   #f)
	(wtxtbox    #f))
    (iup:frame
     #:title "Set fields"
     (iup:vbox
      (iup:hbox (iup:label "Comment:")
		(let ((txtbox (iup:textbox #:action (lambda (val a b)
						      (rmt:test-set-state-status-by-id run-id test-id #f #f b)
						      ;; IDEA: Just set a variable with the proc to call?
						      (rmt:test-set-state-status-by-id run-id test-id #f #f b)
						      (set! newcomment b))
					   #:value (db:test-get-comment testdat)
					   #:expand "HORIZONTAL")))
		  (set! wtxtbox txtbox)
		  txtbox))
		  
      (apply iup:hbox
	     (iup:label "STATE:" #:size "30x")
	     (let* ((btns  (map (lambda (state)
				  (let ((btn (iup:button state
							 #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10"
							 #:action (lambda (x)
								    (rmt:test-set-state-status-by-id run-id test-id state #f #f)
								    (db:test-set-state! testdat state)))))
				    btn))
				(map cadr *common:std-states*)))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ"))))
	       (vector-set! *state-status* 0
			    (lambda (state color)
			      (for-each 
			       (lambda (btn)
				 (let* ((name     (iup:attribute btn "TITLE"))
					(newcolor (if (equal? name state) color "192 192 192")))
				   (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR")))
				       (iup:attribute-set! btn "BGCOLOR" newcolor))))
			       btns)))
	       btns))
      (apply iup:hbox
	     (iup:label "STATUS:" #:size "30x")
	     (let* ((btns  (map (lambda (status)
				  (let ((btn (iup:button status
							 #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10"
							 #:action (lambda (x)
								    (let ((t (iup:attribute x "TITLE")))
								      (if (equal? t "WAIVED")
									  (iup:show (dashboard-tests:waiver run-id testdat 
													    (if wtxtbox (iup:attribute wtxtbox "VALUE") #f)
													    (lambda (c)
													      (set! newcomment c)
													      (if wtxtbox 
														  (begin
														    (iup:attribute-set! wtxtbox "VALUE" c)
														    (if (not *dashboard-comment-share-slot*)
															(set! *dashboard-comment-share-slot* wtxtbox)))
														  ))))
									  (begin
									    (rmt:test-set-state-status-by-id run-id test-id #f status #f)
									    (db:test-set-status! testdat status))))))))
				    btn))
				(map cadr *common:std-statuses*)))) ;; (list  "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP"))))
	       (vector-set! *state-status* 1
			    (lambda (status color)
			      (for-each 
			       (lambda (btn)
				 (let* ((name     (iup:attribute btn "TITLE"))
					(newcolor (if (equal? name status) color "192 192 192")))
				   (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR")))
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
					 (conc "ezstep run from step " stepname)))))
    ;; (iup:button "Refresh test data"
    ;;     	#:expand "HORIZONTAL"
    ;;     	#:action (lambda (obj)
    ;;     		   (print "Refresh test data " stepname))
    )))

(define (dashboard-tests:waiver testdat ovrdval cmtcmd)
  (let* ((wpatt (configf:lookup *configdat* "setup" "waivercommentpatt"))
	 (wregx (if (string? wpatt)(regexp wpatt) #f))
	 (wmesg (iup:label (if wpatt (conc "Comment must match pattern " wpatt) "")))
	 (comnt (iup:textbox #:action (lambda (val a b)
					(if wpatt
					    (if (string-match wregx b)
						(iup:attribute-set! wmesg "TITLE" (conc "Comment matches " wpatt))







|







351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
					 (conc "ezstep run from step " stepname)))))
    ;; (iup:button "Refresh test data"
    ;;     	#:expand "HORIZONTAL"
    ;;     	#:action (lambda (obj)
    ;;     		   (print "Refresh test data " stepname))
    )))

(define (dashboard-tests:waiver run-id testdat ovrdval cmtcmd)
  (let* ((wpatt (configf:lookup *configdat* "setup" "waivercommentpatt"))
	 (wregx (if (string? wpatt)(regexp wpatt) #f))
	 (wmesg (iup:label (if wpatt (conc "Comment must match pattern " wpatt) "")))
	 (comnt (iup:textbox #:action (lambda (val a b)
					(if wpatt
					    (if (string-match wregx b)
						(iup:attribute-set! wmesg "TITLE" (conc "Comment matches " wpatt))
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
			      #:expand "HORIZONTAL"
			      #:action (lambda (obj)
					 (let ((comment (iup:attribute comnt "VALUE"))
					       (test-id (db:test-get-id testdat)))
					   (if (or (not wpatt)
						   (string-match wregx comment))
					       (begin
						 (open-run-close db:test-set-state-status-by-id #f test-id #f "WAIVED" comment)
						 (db:test-set-status! testdat "WAIVED")
						 (cmtcmd comment)
						 (iup:destroy! dlog))))))
		  (iup:button "Cancel"
			      #:expand "HORIZONTAL" 
			      #:action (lambda (obj)
					 (iup:destroy! dlog)))))))
    dlog))


;;======================================================================
;;
;;======================================================================
(define (examine-test test-id) ;; run-id run-key origtest)
  (let* ((db-path       (conc *toppath* "/megatest.db"))
	 (db            (open-db))

	 (testdat       (open-run-close db:get-test-info-by-id db test-id))
	 (db-mod-time   0) ;; (file-modification-time db-path))
	 (last-update   0) ;; (current-seconds))
	 (request-update #t))
    (if (not testdat)
	(begin
	  (debug:print 2 "ERROR: No test data found for test " test-id ", exiting")
	  (exit 1))
	(let* ((run-id        (if testdat (db:test-get-run_id testdat) #f))
	       (keydat        (if testdat (open-run-close db:get-key-val-pairs db run-id) #f))
	       (rundat        (if testdat (open-run-close db:get-run-info db run-id) #f))
	       (runname       (if testdat (db:get-value-by-header (db:get-row rundat)
								  (db:get-header rundat)
								  "runname") #f))

	       ;; These next two are intentional bad values to ensure errors if they should not
	       ;; get filled in properly.
	       (logfile       "/this/dir/better/not/exist")
	       (rundir        (if testdat 
				  (db:test-get-rundir testdat)
				  logfile))
	       (testdat-path  (conc rundir "/testdat.db")) ;; this gets recalculated until found 
	       (teststeps     (if testdat (db:get-compressed-steps test-id work-area: rundir) '()))
	       (testfullname  (if testdat (db:test-get-fullname testdat) "Gathering data ..."))
	       (testname      (if testdat (db:test-get-testname testdat) "n/a"))
	       (testmeta      (if testdat 
				  (let ((tm (open-run-close db:testmeta-get-record db testname)))
				    (if tm tm (make-db:testmeta)))
				  (make-db:testmeta)))

	       (keystring  (string-intersperse 
			    (map (lambda (keyval)
				   ;; (conc ":" (car keyval) " " (cadr keyval)))
				   (cadr keyval))







|








>




|
|
|
>
|







|
|
|
|


>







|



|







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
			      #:expand "HORIZONTAL"
			      #:action (lambda (obj)
					 (let ((comment (iup:attribute comnt "VALUE"))
					       (test-id (db:test-get-id testdat)))
					   (if (or (not wpatt)
						   (string-match wregx comment))
					       (begin
						 (rmt:test-set-state-status-by-id run-id test-id #f "WAIVED" comment)
						 (db:test-set-status! testdat "WAIVED")
						 (cmtcmd comment)
						 (iup:destroy! dlog))))))
		  (iup:button "Cancel"
			      #:expand "HORIZONTAL" 
			      #:action (lambda (obj)
					 (iup:destroy! dlog)))))))
    dlog))


;;======================================================================
;;
;;======================================================================
(define (examine-test run-id test-id) ;; run-id run-key origtest)
  (let* ((db-path       (db:dbfile-path run-id)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db"))
	 (dbstruct      (make-dbr:dbstruct path:  (db:dbfile-path #f) ;; (configf:lookup *configdat* "setup" "linktree") 
					   local: #t))
	 (testdat       (db:get-test-info-by-id dbstruct run-id test-id))
	 (db-mod-time   0) ;; (file-modification-time db-path))
	 (last-update   0) ;; (current-seconds))
	 (request-update #t))
    (if (not testdat)
	(begin
	  (debug:print 2 "ERROR: No test data found for test " test-id ", exiting")
	  (exit 1))
	(let* (;; (run-id        (if testdat (db:test-get-run_id testdat) #f))
	       (keydat        (if testdat (db:get-key-val-pairs dbstruct run-id) #f))
	       (rundat        (if testdat (db:get-run-info dbstruct run-id) #f))
	       (runname       (if testdat (db:get-value-by-header (db:get-rows rundat)
								  (db:get-header rundat)
								  "runname") #f))
	       (tdb           (tdb:open-test-db-by-test-id-local dbstruct run-id test-id))
	       ;; These next two are intentional bad values to ensure errors if they should not
	       ;; get filled in properly.
	       (logfile       "/this/dir/better/not/exist")
	       (rundir        (if testdat 
				  (db:test-get-rundir testdat)
				  logfile))
	       (testdat-path  (conc rundir "/testdat.db")) ;; this gets recalculated until found 
	       (teststeps     (if testdat (tests:get-compressed-steps dbstruct run-id test-id) '()))
	       (testfullname  (if testdat (db:test-get-fullname testdat) "Gathering data ..."))
	       (testname      (if testdat (db:test-get-testname testdat) "n/a"))
	       (testmeta      (if testdat 
				  (let ((tm (db:testmeta-get-record dbstruct testname)))
				    (if tm tm (make-db:testmeta)))
				  (make-db:testmeta)))

	       (keystring  (string-intersperse 
			    (map (lambda (keyval)
				   ;; (conc ":" (car keyval) " " (cadr keyval)))
				   (cadr keyval))
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
	       (refreshdat (lambda ()
			     (let* ((curr-mod-time (max (file-modification-time db-path)
							(if (file-exists? testdat-path)
							    (file-modification-time testdat-path)
							    (begin
							      (set! testdat-path (conc rundir "/testdat.db"))
							      0))))
				    (need-update   (or (and (> curr-mod-time db-mod-time)
							    (> (current-milliseconds)(+ last-update 250))) ;; every half seconds if db touched
						       (> (current-milliseconds)(+ last-update 10000))     ;; force update even 10 seconds
						       request-update))
				    (newtestdat (if need-update 
						    ;; NOTE: BUG HIDER, try to eliminate this exception handler
						    (handle-exceptions
						     exn 
						     (debug:print-info 0 "WARNING: test db access issue for test " test-id ": " ((condition-property-accessor 'exn 'message) exn))
						     (make-db:test)
						     (let* ((newdat (open-run-close db:get-test-info-by-id db test-id ))
							    (tstdat (if newdat
									(open-run-close tests:testdat-get-testinfo db test-id #f)
									'())))
						       (if (and newdat 
								(not (null? tstdat))) ;; (update-time cpuload diskfree run-duration)
							   (let* ((rec      (car tstdat))
								  (cpuload  (vector-ref rec 1))
								  (diskfree (vector-ref rec 2))
								  (run-dur  (vector-ref rec 3)))
							     (db:test-set-run_duration! newdat run-dur)
							     (db:test-set-diskfree!     newdat diskfree)
							     (db:test-set-cpuload!      newdat cpuload)))
						       ;; (debug:print 0 "newdat=" newdat)
						       newdat)
						     )
						    #f)))
			       ;; (debug:print 0 "newtestdat=" newtestdat)
			       (cond
				((and need-update newtestdat)
				 (set! testdat newtestdat)
				 (set! teststeps    (db:get-compressed-steps test-id work-area: rundir))
				 (set! logfile      (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat)))

				 (set! rundir       (db:test-get-rundir testdat))
				 (set! testfullname (db:test-get-fullname testdat))
				 ;; (debug:print 0 "INFO: teststeps=" (intersperse teststeps "\n    "))
				 
				 ;; I don't see why this was implemented this way. Please comment it ...
				 ;; (if (eq? curr-mod-time db-mod-time) ;; do only once if same
				 ;;     (set! db-mod-time (+ curr-mod-time 1))
				 ;;     (set! db-mod-time curr-mod-time))







|







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



|

>
|







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
	       (refreshdat (lambda ()
			     (let* ((curr-mod-time (max (file-modification-time db-path)
							(if (file-exists? testdat-path)
							    (file-modification-time testdat-path)
							    (begin
							      (set! testdat-path (conc rundir "/testdat.db"))
							      0))))
				    (need-update   (or (and (>= curr-mod-time db-mod-time)
							    (> (current-milliseconds)(+ last-update 250))) ;; every half seconds if db touched
						       (> (current-milliseconds)(+ last-update 10000))     ;; force update even 10 seconds
						       request-update))
				    (newtestdat (if need-update 
						    ;; NOTE: BUG HIDER, try to eliminate this exception handler
						    (handle-exceptions
						     exn 
						     (debug:print-info 0 "test db access issue in examine test for run-id " run-id ", test-id " test-id ": " ((condition-property-accessor 'exn 'message) exn))

						     (db:get-test-info-by-id dbstruct run-id test-id )))))












			       ;; (debug:print-info 0 "need-update= " need-update " curr-mod-time = " curr-mod-time)




			       (cond
				((and need-update newtestdat)
				 (set! testdat newtestdat)
				 (set! teststeps    (tests:get-compressed-steps dbstruct run-id test-id))
				 (set! logfile      (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat)))
				 (set! rundir       ;; (filedb:get-path *fdb* 
				       (db:test-get-rundir testdat)) ;; )
				 (set! testfullname (db:test-get-fullname testdat))
				 ;; (debug:print 0 "INFO: teststeps=" (intersperse teststeps "\n    "))
				 
				 ;; I don't see why this was implemented this way. Please comment it ...
				 ;; (if (eq? curr-mod-time db-mod-time) ;; do only once if same
				 ;;     (set! db-mod-time (+ curr-mod-time 1))
				 ;;     (set! db-mod-time curr-mod-time))
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
	    ;;  (test-set-status! db run-id test-name state status itemdat)
	    (set! self ; 
		  (iup:dialog #:close_cb (lambda (a)(exit)) ; #:expand "YES"
			      #:title testfullname
			      (iup:vbox ; #:expand "YES"
			       ;; The run and test info
			       (iup:hbox  ; #:expand "YES"
				(run-info-panel keydat testdat runname)
				(test-info-panel testdat store-label widgets)
				(test-meta-panel testmeta store-meta))
			       (host-info-panel testdat store-label)
			       ;; The controls
			       (iup:frame #:title "Actions" 
					  (iup:vbox
					   (iup:hbox 
					    (iup:button "View Log"      #:action viewlog     #:size "80x")
					    (iup:button "Start Xterm"   #:action xterm       #:size "80x")
					    (iup:button "Run Test"      #:action run-test    #:size "80x")
					    (iup:button "Clean Test"    #:action remove-test #:size "80x")
					    (iup:button "CleanRunExecute!"    #:action clean-run-execute #:size "80x")
					    (iup:button "Kill All Jobs" #:action kill-jobs   #:size "80x")
					    (iup:button "Close"         #:action (lambda (x)(exit)) #:size "80x"))
					   (apply 
					    iup:hbox
					    (list command-text-box command-launch-button))))
			       (set-fields-panel test-id testdat)
			       (let ((tabs 
				      (iup:tabs
				       ;; Replace here with matrix
				       (let ((steps-matrix (iup:matrix
							    #:font   "Courier New, -8"
							    #:expand "YES"
							    #:scrollbar "YES"







|

















|







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
	    ;;  (test-set-status! db run-id test-name state status itemdat)
	    (set! self ; 
		  (iup:dialog #:close_cb (lambda (a)(exit)) ; #:expand "YES"
			      #:title testfullname
			      (iup:vbox ; #:expand "YES"
			       ;; The run and test info
			       (iup:hbox  ; #:expand "YES"
				(run-info-panel dbstruct keydat testdat runname)
				(test-info-panel testdat store-label widgets)
				(test-meta-panel testmeta store-meta))
			       (host-info-panel testdat store-label)
			       ;; The controls
			       (iup:frame #:title "Actions" 
					  (iup:vbox
					   (iup:hbox 
					    (iup:button "View Log"      #:action viewlog     #:size "80x")
					    (iup:button "Start Xterm"   #:action xterm       #:size "80x")
					    (iup:button "Run Test"      #:action run-test    #:size "80x")
					    (iup:button "Clean Test"    #:action remove-test #:size "80x")
					    (iup:button "CleanRunExecute!"    #:action clean-run-execute #:size "80x")
					    (iup:button "Kill All Jobs" #:action kill-jobs   #:size "80x")
					    (iup:button "Close"         #:action (lambda (x)(exit)) #:size "80x"))
					   (apply 
					    iup:hbox
					    (list command-text-box command-launch-button))))
			       (set-fields-panel dbstruct run-id test-id testdat)
			       (let ((tabs 
				      (iup:tabs
				       ;; Replace here with matrix
				       (let ((steps-matrix (iup:matrix
							    #:font   "Courier New, -8"
							    #:expand "YES"
							    #:scrollbar "YES"
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
					 (iup:attribute-set! steps-matrix "0:5" "Duration")
					 (iup:attribute-set! steps-matrix "0:6" "Log File")
					 (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT")
					 ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1")
					 (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES")
					 (let ((proc
						(lambda (testdat)
						  (let ((max-row 0))
						  (if (not (null? teststeps))
						      (let loop ((hed    (car teststeps))
								 (tal    (cdr teststeps))
								 (rownum 1)
								 (colnum 1))
							  (if (> rownum max-row)(set! max-row rownum))
							(let ((val     (vector-ref hed (- colnum 1)))
							      (mtrx-rc (conc rownum ":" colnum)))
							  (iup:attribute-set! steps-matrix  mtrx-rc (if val (conc val) ""))
							  (if (< colnum 6)
							      (loop hed tal rownum (+ colnum 1))
							      (if (not (null? tal))
								    (loop (car tal)(cdr tal)(+ rownum 1) 1))))))
						    (if (> max-row 0)
							(begin
							  ;; we are going to speculatively clear rows until we find a row that is already cleared
							  (let loop ((rownum  (+ max-row 1))
								     (colnum  0)
								     (deleted #f))
							    ;; (debug:print-info 0 "cleaning " rownum ":" colnum)
							    (let* ((next-row (if (eq? colnum 6) (+ rownum 1) rownum))
								   (next-col (if (eq? colnum 6) 1 (+ colnum 1)))
								   (mtrx-rc  (conc rownum ":" colnum))
								   (curr-val (iup:attribute steps-matrix mtrx-rc)))
							      ;; (debug:print-info 0 "cleaning " rownum ":" colnum " currval= " curr-val)
							      (if (and (string? curr-val)
								       (not (equal? curr-val "")))
								  (begin
								    (iup:attribute-set! steps-matrix mtrx-rc "")
								    (loop next-row next-col #t))
								  (if (eq? colnum 6) ;; not done, didn't get a full blank row
								      (if deleted (loop next-row next-col #f)) ;; exit on this not met
								      (loop next-row next-col deleted)))))
							  (iup:attribute-set! steps-matrix "REDRAW" "ALL")))))))
					   (hash-table-set! widgets "StepsMatrix" proc)
					   (proc testdat))
					 steps-matrix)
				       ;; populate the Test Data panel
				       (iup:frame
					#:title "Test Data"
					(let ((test-data







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







658
659
660
661
662
663
664



665































666
667
668
669
670
671
672
					 (iup:attribute-set! steps-matrix "0:5" "Duration")
					 (iup:attribute-set! steps-matrix "0:6" "Log File")
					 (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT")
					 ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1")
					 (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES")
					 (let ((proc
						(lambda (testdat)



						  (dcommon:populate-steps teststeps steps-matrix))))































					   (hash-table-set! widgets "StepsMatrix" proc)
					   (proc testdat))
					 steps-matrix)
				       ;; populate the Test Data panel
				       (iup:frame
					#:title "Test Data"
					(let ((test-data
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
											      (db:test-data-get-value    x)
											      (db:test-data-get-expected x)
											      (db:test-data-get-tol      x)
											      (db:test-data-get-status   x)
											      (db:test-data-get-units    x)
											      (db:test-data-get-type     x)
											      (db:test-data-get-comment  x)))
										    (open-run-close db:read-test-data db test-id "%")))
									      "\n")))
							       (if (not (equal? currval newval))
								   (iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval)))))
					  test-data))
				       ;;(dashboard:run-controls)
				       )))
				 (iup:attribute-set! tabs "TABTITLE0" "Steps")







|







692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
											      (db:test-data-get-value    x)
											      (db:test-data-get-expected x)
											      (db:test-data-get-tol      x)
											      (db:test-data-get-status   x)
											      (db:test-data-get-units    x)
											      (db:test-data-get-type     x)
											      (db:test-data-get-comment  x)))
										    (tdb:open-run-close-db-by-test-id-local dbstruct run-id test-id #f tdb:read-test-data test-id "%")))
									      "\n")))
							       (if (not (equal? currval newval))
								   (iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval)))))
					  test-data))
				       ;;(dashboard:run-controls)
				       )))
				 (iup:attribute-set! tabs "TABTITLE0" "Steps")

Modified dashboard.scm from [0b0b326b4f] to [7571891dc8].

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
;; (declare (uses dashboard-main))
(declare (uses megatest-version))
(declare (uses mt))

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


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

Usage: dashboard [options]
  -h                : this help
  -server host:port : connect to host:port instead of db access
  -test testid      : control test identified by testid
  -guimonitor       : control panel for runs

Misc
  -rows N         : set number of rows
"))

;; process args
(define remargs (args:get-args 
		 (argv)
		 (list  "-rows"
			"-run"
			"-test"
			"-debug"
			"-host" 

			) 
		 (list  "-h"
			"-use-server"
			"-guimonitor"
			"-main"
			"-v"
			"-q"







>




|


|
|
|
|













>







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
;; (declare (uses dashboard-main))
(declare (uses megatest-version))
(declare (uses mt))

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

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

Usage: dashboard [options]
  -h                   : this help
  -server host:port    : connect to host:port instead of db access
  -test run-id,test-id : control test identified by testid
  -guimonitor          : control panel for runs

Misc
  -rows N         : set number of rows
"))

;; process args
(define remargs (args:get-args 
		 (argv)
		 (list  "-rows"
			"-run"
			"-test"
			"-debug"
			"-host" 
			"-transport"
			) 
		 (list  "-h"
			"-use-server"
			"-guimonitor"
			"-main"
			"-v"
			"-q"
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
      (exit)))

(if (not (launch:setup-for-run))
    (begin
      (print "Failed to find megatest.config, exiting") 
      (exit 1)))


(define *db* #f) ;; (open-db))

(if (args:get-arg "-host")
    (begin
      (set! *runremote* (string-split (args:get-arg "-host" ":")))
      (client:launch))
    (if (not (args:get-arg "-use-server"))
	(set! *transport-type* 'fs) ;; force fs access
	(client:launch)))

;; HACK ALERT: this is a hack, please fix.
(define *read-only* (not (file-read-access? (conc *toppath* "/megatest.db"))))
;; (client:setup *db*)

(define toplevel #f)
(define dlg      #f)
(define max-test-num 0)
;; (define *keys*   (open-run-close db:get-keys #f))
(define *keys*   (cdb:remote-run db:get-keys #f))
;; (define *keys*   (db:get-keys   *db*))

(define *dbkeys*  (append *keys* (list "runname")))

(define *header*       #f)
(define *allruns*     '())
(define *allruns-by-id* (make-hash-table)) ;; 
(define *runchangerate* (make-hash-table))

(define *buttondat*    (make-hash-table)) ;; <run-id color text test run-key>
(define *alltestnamelst* '())
(define *searchpatts*  (make-hash-table))
(define *num-runs*      8)
(define *tot-run-count* (cdb:remote-run db:get-num-runs #f "%"))
;; (define *tot-run-count* (db:get-num-runs *db* "%"))

;; Update management
;;
(define *last-update*   (current-seconds))
(define *last-db-update-time* 0)
(define *please-update-buttons* #t)
(define *delayed-update* 0)
(define *update-is-running* #f)
(define *update-mutex* (make-mutex))

(define *all-item-test-names* '())
(define *num-tests*     15)
(define *start-run-offset*  0)
(define *start-test-offset* 0)
(define *examine-test-dat* (make-hash-table))
(define *exit-started* #f)
(define *status-ignore-hash* (make-hash-table))
(define *state-ignore-hash*  (make-hash-table))

(define *db-file-path* (conc *toppath* "/megatest.db"))

(define *tests-sort-options* (vector (vector "Sort +a" 'testname   "ASC")
				     (vector "Sort -a" 'testname   "DESC")
				     (vector "Sort +t" 'event_time "ASC")
				     (vector "Sort -t" 'event_time "DESC")
				     (vector "Sort +s" 'statestatus "ASC")
				     (vector "Sort -s" 'statestatus "DESC")
				     (vector "Sort +a" 'testname   "ASC")))







>
|
|
<
|
<
<
<
<
<


|
<




<
<
|












|
|



















<
<







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

(if (not (launch:setup-for-run))
    (begin
      (print "Failed to find megatest.config, exiting") 
      (exit 1)))

(define *dbdir* (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
(define *dbstruct-local*  (make-dbr:dbstruct path:  *dbdir*
					     local: #t))

(define *db-file-path* (db:dbfile-path 0))






;; HACK ALERT: this is a hack, please fix.
(define *read-only* (not (file-read-access? *db-file-path*)))


(define toplevel #f)
(define dlg      #f)
(define max-test-num 0)


(define *keys*   (db:get-keys *dbstruct-local*))

(define *dbkeys*  (append *keys* (list "runname")))

(define *header*       #f)
(define *allruns*     '())
(define *allruns-by-id* (make-hash-table)) ;; 
(define *runchangerate* (make-hash-table))

(define *buttondat*    (make-hash-table)) ;; <run-id color text test run-key>
(define *alltestnamelst* '())
(define *searchpatts*  (make-hash-table))
(define *num-runs*      8)
(define *tot-run-count* (db:get-num-runs *dbstruct-local* "%"))
;; (define *tot-run-count* (db:get-num-runs *dbstruct-local* "%"))

;; Update management
;;
(define *last-update*   (current-seconds))
(define *last-db-update-time* 0)
(define *please-update-buttons* #t)
(define *delayed-update* 0)
(define *update-is-running* #f)
(define *update-mutex* (make-mutex))

(define *all-item-test-names* '())
(define *num-tests*     15)
(define *start-run-offset*  0)
(define *start-test-offset* 0)
(define *examine-test-dat* (make-hash-table))
(define *exit-started* #f)
(define *status-ignore-hash* (make-hash-table))
(define *state-ignore-hash*  (make-hash-table))



(define *tests-sort-options* (vector (vector "Sort +a" 'testname   "ASC")
				     (vector "Sort -a" 'testname   "DESC")
				     (vector "Sort +t" 'event_time "ASC")
				     (vector "Sort -t" 'event_time "DESC")
				     (vector "Sort +s" 'statestatus "ASC")
				     (vector "Sort -s" 'statestatus "DESC")
				     (vector "Sort +a" 'testname   "ASC")))
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
	 (c2    (map string->number (string-split color2)))
	 (delta (map (lambda (a b)(abs (- a b))) c1 c2)))
    (null? (filter (lambda (x)(> x 3)) delta))))

;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
(define (update-rundat runnamepatt numruns testnamepatt keypatts)
  (let* ((referenced-run-ids '())
	 (allruns     (cdb:remote-run db:get-runs #f runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2))
				      *start-run-offset* keypatts))
	 (header      (db:get-header allruns))
	 (runs        (db:get-rows   allruns))
	 (result      '())
	 (maxtests    0)
	 (states      (hash-table-keys *state-ignore-hash*))
	 (statuses    (hash-table-keys *status-ignore-hash*))
	 (sort-info   (get-curr-sort))
	 (sort-by     (vector-ref sort-info 1))
	 (sort-order  (vector-ref sort-info 2))
	 (bubble-type (if (member sort-order '(testname))
			  'testname
			  'itempath)))
    ;; 
    ;; trim runs to only those that are changing often here
    ;; 
    (for-each (lambda (run)
		(let* ((run-id      (db:get-value-by-header run header "id"))
		       (tests       (mt:get-tests-for-run run-id testnamepatt states statuses

							  not-in: *hide-not-hide*
							  sort-by: sort-by
							  sort-order: sort-order
							  qryvals: 'shortlist))
		       ;; NOTE: bubble-up also sets the global *all-item-test-names*
		       ;; (tests       (bubble-up tmptests priority: bubble-type))
		       (key-vals    (cdb:remote-run db:get-key-vals #f run-id)))
		  ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively.
		  ;; (debug:print 0 "Getting data for run " run-id " with key-vals=" key-vals)
		  ;; Not sure this is needed?
		  (set! referenced-run-ids (cons run-id referenced-run-ids))
		  (if (> (length tests) maxtests)
		      (set! maxtests (length tests)))
		  (if (or (not *hide-empty-runs*) ;; this reduces the data burden when set







|


















|
>
|
|
|
|


|







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
	 (c2    (map string->number (string-split color2)))
	 (delta (map (lambda (a b)(abs (- a b))) c1 c2)))
    (null? (filter (lambda (x)(> x 3)) delta))))

;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
(define (update-rundat runnamepatt numruns testnamepatt keypatts)
  (let* ((referenced-run-ids '())
	 (allruns     (db:get-runs *dbstruct-local* runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2))
				      *start-run-offset* keypatts))
	 (header      (db:get-header allruns))
	 (runs        (db:get-rows   allruns))
	 (result      '())
	 (maxtests    0)
	 (states      (hash-table-keys *state-ignore-hash*))
	 (statuses    (hash-table-keys *status-ignore-hash*))
	 (sort-info   (get-curr-sort))
	 (sort-by     (vector-ref sort-info 1))
	 (sort-order  (vector-ref sort-info 2))
	 (bubble-type (if (member sort-order '(testname))
			  'testname
			  'itempath)))
    ;; 
    ;; trim runs to only those that are changing often here
    ;; 
    (for-each (lambda (run)
		(let* ((run-id      (db:get-value-by-header run header "id"))
		       (tests       (db:get-tests-for-run *dbstruct-local* run-id testnamepatt states statuses
							  #f #f
							  *hide-not-hide*
							  sort-by
							  sort-order
							  'shortlist))
		       ;; NOTE: bubble-up also sets the global *all-item-test-names*
		       ;; (tests       (bubble-up tmptests priority: bubble-type))
		       (key-vals    (db:get-key-vals *dbstruct-local* run-id)))
		  ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively.
		  ;; (debug:print 0 "Getting data for run " run-id " with key-vals=" key-vals)
		  ;; Not sure this is needed?
		  (set! referenced-run-ids (cons run-id referenced-run-ids))
		  (if (> (length tests) maxtests)
		      (set! maxtests (length tests)))
		  (if (or (not *hide-empty-runs*) ;; this reduces the data burden when set
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
					     (car matching))))
			   (testname   (db:test-get-testname  test))
			   (itempath   (db:test-get-item-path test))
			   (testfullname (test:test-get-fullname test))
			   (teststatus (db:test-get-status   test))
			   (teststate  (db:test-get-state    test))
			   ;;(teststart  (db:test-get-event_time test))
			   (runtime    (db:test-get-run_duration test))
			   (buttontxt  (cond
					((equal? teststate "COMPLETED") teststatus)
					((and (equal? teststate "NOT_STARTED")
					      (member teststatus '("ZERO_ITEMS" "BLOCKED" "PREQ_FAIL" "PREQ_DISCARDED" "TIMED_OUT" "KEEP_TRYING" "TEN_STRIKES")))
					 teststatus)
					(else
					 teststate)))
			   (button     (vector-ref columndat rown))
			   (color      (car (gutils:get-color-for-state-status teststate teststatus)))







|

|







471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
					     (car matching))))
			   (testname   (db:test-get-testname  test))
			   (itempath   (db:test-get-item-path test))
			   (testfullname (test:test-get-fullname test))
			   (teststatus (db:test-get-status   test))
			   (teststate  (db:test-get-state    test))
			   ;;(teststart  (db:test-get-event_time test))
			   ;;(runtime    (db:test-get-run_duration test))
			   (buttontxt  (cond
					((member teststate '("COMPLETED" "ARCHIVED")) teststatus)
					((and (equal? teststate "NOT_STARTED")
					      (member teststatus '("ZERO_ITEMS" "BLOCKED" "PREQ_FAIL" "PREQ_DISCARDED" "TIMED_OUT" "KEEP_TRYING" "TEN_STRIKES")))
					 teststatus)
					(else
					 teststate)))
			   (button     (vector-ref columndat rown))
			   (color      (car (gutils:get-color-for-state-status teststate teststatus)))
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
	  (if (not (null? values))
	      (let ((newval (car values)))
		(iup:attribute-set! lb "VALUE" newval)
		newval))))))

(define (dashboard:update-target-selector key-lbs #!key (action-proc #f))
  (let* ((runconf-targs (common:get-runconfig-targets))
	 (db-target-dat (open-run-close db:get-targets #f))
	 (header        (vector-ref db-target-dat 0))
	 (db-targets    (vector-ref db-target-dat 1))
	 (all-targets   (append db-targets
				(map (lambda (x)
				       (list->vector
					(take (append (string-split x "/")
						      (make-list (length header) "na"))







|







570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
	  (if (not (null? values))
	      (let ((newval (car values)))
		(iup:attribute-set! lb "VALUE" newval)
		newval))))))

(define (dashboard:update-target-selector key-lbs #!key (action-proc #f))
  (let* ((runconf-targs (common:get-runconfig-targets))
	 (db-target-dat (db:get-targets *dbstruct-local*))
	 (header        (vector-ref db-target-dat 0))
	 (db-targets    (vector-ref db-target-dat 1))
	 (all-targets   (append db-targets
				(map (lambda (x)
				       (list->vector
					(take (append (string-split x "/")
						      (make-list (length header) "na"))
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
				 #:dropdown "YES"
				 #:action (lambda (obj val index lbstate)
					    (iup:attribute-set! tb "VALUE" val)
					    (dboard:data-set-run-name! *data* val)
					    (dashboard:update-run-command))))
		(refresh-runs-list (lambda ()
				     (let* ((target        (dboard:data-get-target-string *data*))
					    (runs-for-targ (mt:get-runs-by-patt *keys* "%" target))
					    (runs-header   (vector-ref runs-for-targ 0))
					    (runs-dat      (vector-ref runs-for-targ 1))
					    (run-names     (cons default-run-name 
								 (map (lambda (x)
									(db:get-value-by-header x runs-header "runname"))
								      runs-dat))))
				       (iup:attribute-set! lb "REMOVEITEM" "ALL")







|







802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
				 #:dropdown "YES"
				 #:action (lambda (obj val index lbstate)
					    (iup:attribute-set! tb "VALUE" val)
					    (dboard:data-set-run-name! *data* val)
					    (dashboard:update-run-command))))
		(refresh-runs-list (lambda ()
				     (let* ((target        (dboard:data-get-target-string *data*))
					    (runs-for-targ (db:get-runs-by-patt *dbstruct-local* *keys* "%" target #f #f))
					    (runs-header   (vector-ref runs-for-targ 0))
					    (runs-dat      (vector-ref runs-for-targ 1))
					    (run-names     (cons default-run-name 
								 (map (lambda (x)
									(db:get-value-by-header x runs-header "runname"))
								      runs-dat))))
				       (iup:attribute-set! lb "REMOVEITEM" "ALL")
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
		    combos)))
	  (iup:hbox
	   ;; Text box for STATES
	   (iup:frame
	    #:title "States"
	    (dashboard:text-list-toggle-box 
	     ;; Move these definitions to common and find the other useages and replace!
	     *common:std-states* ;; '("COMPLETED" "RUNNING" "STUCK" "INCOMPLETE" "LAUNCHED" "REMOTEHOSTSTART" "KILLED")
	     (lambda (all)
	       (dboard:data-set-states! *data* all)
	       (dashboard:update-run-command))))
	   ;; Text box for STATES
	   (iup:frame
	    #:title "Statuses"
	    (dashboard:text-list-toggle-box 
	     *common:std-statuses* ;; '("PASS" "FAIL" "n/a" "CHECK" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD")
	     (lambda (all)
	       (dboard:data-set-statuses! *data* all)
	       (dashboard:update-run-command))))))))
      
       (iup:frame
	#:title "Tests and Tasks"
	(let* ((updater #f)







|







|







851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
		    combos)))
	  (iup:hbox
	   ;; Text box for STATES
	   (iup:frame
	    #:title "States"
	    (dashboard:text-list-toggle-box 
	     ;; Move these definitions to common and find the other useages and replace!
	     (map cadr *common:std-states*) ;; '("COMPLETED" "RUNNING" "STUCK" "INCOMPLETE" "LAUNCHED" "REMOTEHOSTSTART" "KILLED")
	     (lambda (all)
	       (dboard:data-set-states! *data* all)
	       (dashboard:update-run-command))))
	   ;; Text box for STATES
	   (iup:frame
	    #:title "Statuses"
	    (dashboard:text-list-toggle-box 
	     (map cadr *common:std-statuses*) ;; '("PASS" "FAIL" "n/a" "CHECK" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD")
	     (lambda (all)
	       (dboard:data-set-statuses! *data* all)
	       (dashboard:update-run-command))))))))
      
       (iup:frame
	#:title "Tests and Tasks"
	(let* ((updater #f)
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
;;      )))

;;======================================================================
;; S U M M A R Y 
;;======================================================================
;;
;; General info about the run(s) and megatest area
(define (dashboard:summary)
  (let ((rawconfig        (read-config (conc *toppath* "/megatest.config") #f 'return-string)))
    (iup:vbox
     (iup:split
      ;; #:value 500
      (iup:frame 
       #:title "General Info"

       (iup:hbox 



	(dcommon:keys-matrix rawconfig)
	(dcommon:general-info)
	))
      (iup:frame
       #:title "Server"
       (dcommon:servers-table)))
     (iup:frame 
      #:title "Megatest config settings"
      (iup:hbox
       (dcommon:section-matrix rawconfig "setup" "Varname" "Value")
       (iup:vbox
	(dcommon:section-matrix rawconfig "server" "Varname" "Value")
	;; (iup:frame
	;; #:title "Disks Areas"
	(dcommon:section-matrix rawconfig "disks" "Disk area" "Path"))))
     (iup:frame
      #:title "Run statistics"
      (dcommon:run-stats)))))

;;======================================================================
;; R U N
;;======================================================================
;;
;; display and manage a single run at a time

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

(define dashboard:update-run-summary-tab #f)

;; (define (tests window-id)
(define (dashboard:one-run)
  (let* ((tb      (iup:treebox
		   #:value 0
		   #:name "Runs"
		   #:expand "YES"
		   #:addexpanded "NO"
		   #:selection-cb
		   (lambda (obj id state)







|
|


|


>
|
>
>
>
|
|
|














|















|







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

;;======================================================================
;; S U M M A R Y 
;;======================================================================
;;
;; General info about the run(s) and megatest area
(define (dashboard:summary db)
  (let ((rawconfig        (read-config (conc *toppath* "/megatest.config") #f #f))) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string)))
    (iup:vbox
     (iup:split
      #:value 500
      (iup:frame 
       #:title "General Info"
       (iup:vbox
	(iup:hbox
	 (iup:label "Area Path")
	 (iup:textbox #:value *toppath* #:expand "HORIZONTAL"))
	(iup:hbox 
	 (dcommon:keys-matrix rawconfig)
	 (dcommon:general-info)
	 )))
      (iup:frame
       #:title "Server"
       (dcommon:servers-table)))
     (iup:frame 
      #:title "Megatest config settings"
      (iup:hbox
       (dcommon:section-matrix rawconfig "setup" "Varname" "Value")
       (iup:vbox
	(dcommon:section-matrix rawconfig "server" "Varname" "Value")
	;; (iup:frame
	;; #:title "Disks Areas"
	(dcommon:section-matrix rawconfig "disks" "Disk area" "Path"))))
     (iup:frame
      #:title "Run statistics"
      (dcommon:run-stats db)))))

;;======================================================================
;; R U N
;;======================================================================
;;
;; display and manage a single run at a time

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

(define dashboard:update-run-summary-tab #f)

;; (define (tests window-id)
(define (dashboard:one-run db)
  (let* ((tb      (iup:treebox
		   #:value 0
		   #:name "Runs"
		   #:expand "YES"
		   #:addexpanded "NO"
		   #:selection-cb
		   (lambda (obj id state)
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
	 (run-matrix (iup:matrix
		      #:expand "YES"
		      #:click-cb
		      (lambda (obj lin col status)
			(let* ((toolpath (car (argv)))
			       (key      (conc lin ":" col))
			       (test-id  (hash-table-ref/default cell-lookup key -1))
			       (cmd      (conc toolpath " -test " test-id "&")))
			  (system cmd)))))
	 (updater  (lambda ()
		     (let* ((runs-dat     (mt:get-runs-by-patt *keys* "%" #f))
			    (runs-header  (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
			    (run-id       (dboard:data-get-curr-run-id *data*))
			    (tests-dat    (let ((tdat (mt:get-tests-for-run run-id 
									    (hash-table-ref/default *searchpatts* "test-name" "%/%")
									    (hash-table-keys *state-ignore-hash*) ;; '()
									    (hash-table-keys *status-ignore-hash*) ;; '()

									    not-in: *hide-not-hide*

									    qryvals: "id,testname,item_path,state,status"))) ;; get 'em all
					    (sort tdat (lambda (a b)
							 (let* ((aval (vector-ref a 2))
								(bval (vector-ref b 2))
								(anum (string->number aval))
								(bnum (string->number bval)))
							   (if (and anum bnum)
							       (< anum bnum)







|


|


|



>
|
>
|







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
	 (run-matrix (iup:matrix
		      #:expand "YES"
		      #:click-cb
		      (lambda (obj lin col status)
			(let* ((toolpath (car (argv)))
			       (key      (conc lin ":" col))
			       (test-id  (hash-table-ref/default cell-lookup key -1))
			       (cmd      (conc toolpath " -test " (dboard:data-get-curr-run-id *data*) "," test-id "&")))
			  (system cmd)))))
	 (updater  (lambda ()
		     (let* ((runs-dat     (db:get-runs-by-patt db *keys* "%" #f #f #f))
			    (runs-header  (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
			    (run-id       (dboard:data-get-curr-run-id *data*))
			    (tests-dat    (let ((tdat (db:get-tests-for-run db run-id 
									    (hash-table-ref/default *searchpatts* "test-name" "%/%")
									    (hash-table-keys *state-ignore-hash*) ;; '()
									    (hash-table-keys *status-ignore-hash*) ;; '()
									    #f #f
									    *hide-not-hide*
									    #f #f
									    "id,testname,item_path,state,status"))) ;; get 'em all
					    (sort tdat (lambda (a b)
							 (let* ((aval (vector-ref a 2))
								(bval (vector-ref b 2))
								(anum (string->number aval))
								(bnum (string->number bval)))
							   (if (and anum bnum)
							       (< anum bnum)
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
     tb
     run-matrix)))

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

(define (make-dashboard-buttons nruns ntests keynames)
  (let* ((nkeys   (length keynames))
	 (runsvec (make-vector nruns))
	 (header  (make-vector nruns))
	 (lftcol  (make-vector ntests))
	 (keycol  (make-vector ntests))
	 (controls '())
	 (lftlst  '())







|







1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
     tb
     run-matrix)))

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

(define (make-dashboard-buttons db nruns ntests keynames)
  (let* ((nkeys   (length keynames))
	 (runsvec (make-vector nruns))
	 (header  (make-vector nruns))
	 (lftcol  (make-vector ntests))
	 (keycol  (make-vector ntests))
	 (controls '())
	 (lftlst  '())
1234
1235
1236
1237
1238
1239
1240
1241


1242
1243
1244
1245
1246
1247
1248
	      (let ((hideit (iup:button "HideTests" #:action (lambda (obj)
							       (set! *hide-not-hide* (not *hide-not-hide*))
							       (iup:attribute-set! obj "TITLE" (if *hide-not-hide* "HideTests" "NotHide"))
							       (mark-for-update)))))
		(set! *hide-not-hide-button* hideit)
		hideit))
	     (iup:hbox
	      (iup:button "Quit"      #:action (lambda (obj)(if *db* (sqlite3:finalize! *db*))(exit)))


	      (iup:button "Refresh"   #:action (lambda (obj)
						 (mark-for-update)))
	      (iup:button "Collapse"  #:action (lambda (obj)
						 (let ((myname (iup:attribute obj "TITLE")))
						   (if (equal? myname "Collapse")
						       (begin
							 (for-each (lambda (tname)







|
>
>







1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
	      (let ((hideit (iup:button "HideTests" #:action (lambda (obj)
							       (set! *hide-not-hide* (not *hide-not-hide*))
							       (iup:attribute-set! obj "TITLE" (if *hide-not-hide* "HideTests" "NotHide"))
							       (mark-for-update)))))
		(set! *hide-not-hide-button* hideit)
		hideit))
	     (iup:hbox
	      (iup:button "Quit"      #:action (lambda (obj)
						 ;; (if *dbstruct-local* (db:close-all *dbstruct-local*))
						 (exit)))
	      (iup:button "Refresh"   #:action (lambda (obj)
						 (mark-for-update)))
	      (iup:button "Collapse"  #:action (lambda (obj)
						 (let ((myname (iup:attribute obj "TITLE")))
						   (if (equal? myname "Collapse")
						       (begin
							 (for-each (lambda (tname)
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
	      (map (lambda (status)
		     (iup:toggle status  #:action   (lambda (obj val)
						      (mark-for-update)
						      (if (eq? val 1)
							  (hash-table-set! *status-ignore-hash* status #t)
							  (hash-table-delete! *status-ignore-hash* status))
						      (set-bg-on-filter))))
		   *common:std-statuses*)) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP")))
	     (apply 
	      iup:hbox
	      (map (lambda (state)
		     (iup:toggle state   #:action   (lambda (obj val)
						      (mark-for-update)
						      (if (eq? val 1)
							  (hash-table-set! *state-ignore-hash* state #t)
							  (hash-table-delete! *state-ignore-hash* state))
						      (set-bg-on-filter))))
		   *common:std-states*)) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED")))
	     (iup:valuator #:valuechanged_cb (lambda (obj)
					       (let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10))))
						     (oldmax   (string->number (iup:attribute obj "MAX")))
						     (maxruns  *tot-run-count*))
						 (set! *start-run-offset* val)
						 (mark-for-update)
						 (debug:print 6 "*start-run-offset* " *start-run-offset* " maxruns: " maxruns ", val: " val " oldmax: " oldmax)







|









|







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
	      (map (lambda (status)
		     (iup:toggle status  #:action   (lambda (obj val)
						      (mark-for-update)
						      (if (eq? val 1)
							  (hash-table-set! *status-ignore-hash* status #t)
							  (hash-table-delete! *status-ignore-hash* status))
						      (set-bg-on-filter))))
		   (map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP")))
	     (apply 
	      iup:hbox
	      (map (lambda (state)
		     (iup:toggle state   #:action   (lambda (obj val)
						      (mark-for-update)
						      (if (eq? val 1)
							  (hash-table-set! *state-ignore-hash* state #t)
							  (hash-table-delete! *state-ignore-hash* state))
						      (set-bg-on-filter))))
		   (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED")))
	     (iup:valuator #:valuechanged_cb (lambda (obj)
					       (let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10))))
						     (oldmax   (string->number (iup:attribute obj "MAX")))
						     (maxruns  *tot-run-count*))
						 (set! *start-run-offset* val)
						 (mark-for-update)
						 (debug:print 6 "*start-run-offset* " *start-run-offset* " maxruns: " maxruns ", val: " val " oldmax: " oldmax)
1376
1377
1378
1379
1380
1381
1382

1383
1384
1385
1386
1387
1388
1389
1390
				       #:size "60x15" 
				       #:expand "HORIZONTAL"
				       #:fontsize "10" 
				       #:action (lambda (x)
						  (let* ((toolpath (car (argv)))
							 (buttndat (hash-table-ref *buttondat* button-key))
							 (test-id  (db:test-get-id (vector-ref buttndat 3)))

							 (cmd  (conc toolpath " -test " test-id "&")))
					;(print "Launching " cmd)
						    (system cmd))))))
	  (hash-table-set! *buttondat* button-key (vector 0 "100 100 100" button-key #f #f)) 
	  (vector-set! testvec testnum butn)
	  (loop runnum (+ testnum 1) testvec (cons butn res))))))
    ;; now assemble the hdrlst and bdylst and kick off the dialog
    (iup:show







>
|







1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
				       #:size "60x15" 
				       #:expand "HORIZONTAL"
				       #:fontsize "10" 
				       #:action (lambda (x)
						  (let* ((toolpath (car (argv)))
							 (buttndat (hash-table-ref *buttondat* button-key))
							 (test-id  (db:test-get-id (vector-ref buttndat 3)))
							 (run-id   (db:test-get-run_id (vector-ref buttndat 3)))
							 (cmd  (conc toolpath " -test " run-id "," test-id "&")))
					;(print "Launching " cmd)
						    (system cmd))))))
	  (hash-table-set! *buttondat* button-key (vector 0 "100 100 100" button-key #f #f)) 
	  (vector-set! testvec testnum butn)
	  (loop runnum (+ testnum 1) testvec (cons butn res))))))
    ;; now assemble the hdrlst and bdylst and kick off the dialog
    (iup:show
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
					(apply iup:hbox (reverse hdrlst))
					(apply iup:hbox (reverse bdylst))))))
			 controls))
	     (tabs (iup:tabs
		    #:tabchangepos-cb (lambda (obj curr prev)
					(set! *please-update-buttons* #t)
					(set! *current-tab-number* curr))
		    (dashboard:summary)
		    runs-view
		    (dashboard:one-run)
		    (dashboard:run-controls)
		    )))
	;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
	(iup:attribute-set! tabs "TABTITLE0" "Summary")
	(iup:attribute-set! tabs "TABTITLE1" "Runs")
	(iup:attribute-set! tabs "TABTITLE2" "Run Summary")
	(iup:attribute-set! tabs "TABTITLE3" "Run Control")







|

|







1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
					(apply iup:hbox (reverse hdrlst))
					(apply iup:hbox (reverse bdylst))))))
			 controls))
	     (tabs (iup:tabs
		    #:tabchangepos-cb (lambda (obj curr prev)
					(set! *please-update-buttons* #t)
					(set! *current-tab-number* curr))
		    (dashboard:summary db)
		    runs-view
		    (dashboard:one-run db)
		    (dashboard:run-controls)
		    )))
	;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
	(iup:attribute-set! tabs "TABTITLE0" "Summary")
	(iup:attribute-set! tabs "TABTITLE1" "Runs")
	(iup:attribute-set! tabs "TABTITLE2" "Run Summary")
	(iup:attribute-set! tabs "TABTITLE3" "Run Control")
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
(define *tim* (iup:timer))
(define *ord* #f)
(iup:attribute-set! *tim* "TIME" 300)
(iup:attribute-set! *tim* "RUN" "YES")

;; Move this stuff to db.scm? I'm not sure that is the right thing to do...
;;
(define *last-db-update-time* (file-modification-time (conc *toppath* "/megatest.db")))
(define *last-recalc-ended-time* 0)

(define (dashboard:been-changed)
  (> (file-modification-time (conc *toppath* "/megatest.db")) *last-db-update-time*))

(define (dashboard:set-db-update-time)
  (set! *last-db-update-time* (file-modification-time (conc *toppath* "/megatest.db"))))

(define (dashboard:recalc modtime please-update-buttons last-db-update-time)
  (or please-update-buttons
      (and (> (current-milliseconds)(+ *last-recalc-ended-time* 150))
	   (> modtime last-db-update-time)
	   (> (current-seconds)(+ last-db-update-time 1)))))

(define *monitor-db-path* (conc *toppath* "/monitor.db"))
(define *last-monitor-update-time* 0)

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










(define (dashboard:run-update x)
  (let* ((modtime         (file-modification-time *db-file-path*))
	 (monitor-modtime (if (file-exists? *monitor-db-path*)
			      (file-modification-time *monitor-db-path*)
			      -1))
	 (run-update-time (current-seconds))
	 (recalc          (dashboard:recalc modtime *please-update-buttons* *last-db-update-time*)))
    (if (and (eq? *current-tab-number* 0)
	     (> monitor-modtime *last-monitor-update-time*))

	(begin
	  (set! *last-monitor-update-time* monitor-modtime)
	  (if dashboard:update-servers-table (dashboard:update-servers-table))))
    (if recalc
	(begin	
	  (case *current-tab-number* 
	    ((0) 
	     (if dashboard:update-summary-tab (dashboard:update-summary-tab)))
	    ((1) ;; The runs table is active







|



|


|







|



|
|
>
>
>
>
>
>
>
>
>


|






|
>

|







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
(define *tim* (iup:timer))
(define *ord* #f)
(iup:attribute-set! *tim* "TIME" 300)
(iup:attribute-set! *tim* "RUN" "YES")

;; Move this stuff to db.scm? I'm not sure that is the right thing to do...
;;
(define *last-db-update-time* (file-modification-time *db-file-path*)) ;; (conc *toppath* "/db/main.db")))
(define *last-recalc-ended-time* 0)

(define (dashboard:been-changed)
  (> (file-modification-time *db-file-path*) *last-db-update-time*))

(define (dashboard:set-db-update-time)
  (set! *last-db-update-time* (file-modification-time *db-file-path*)))

(define (dashboard:recalc modtime please-update-buttons last-db-update-time)
  (or please-update-buttons
      (and (> (current-milliseconds)(+ *last-recalc-ended-time* 150))
	   (> modtime last-db-update-time)
	   (> (current-seconds)(+ last-db-update-time 1)))))

(define *monitor-db-path* (conc *dbdir* "/monitor.db"))
(define *last-monitor-update-time* 0)

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

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

(define (dashboard:run-update x)
  (let* ((modtime         (dashboard:get-youngest-run-db-mod-time)) ;; (file-modification-time *db-file-path*))
	 (monitor-modtime (if (file-exists? *monitor-db-path*)
			      (file-modification-time *monitor-db-path*)
			      -1))
	 (run-update-time (current-seconds))
	 (recalc          (dashboard:recalc modtime *please-update-buttons* *last-db-update-time*)))
    (if (and (eq? *current-tab-number* 0)
	     (or (> monitor-modtime *last-monitor-update-time*)
		 (> (- run-update-time *last-monitor-update-time*) 5))) ;; update every 1/2 minute just in case
	(begin
	  (set! *last-monitor-update-time* run-update-time) ;; monitor-modtime)
	  (if dashboard:update-servers-table (dashboard:update-servers-table))))
    (if recalc
	(begin	
	  (case *current-tab-number* 
	    ((0) 
	     (if dashboard:update-summary-tab (dashboard:update-summary-tab)))
	    ((1) ;; The runs table is active
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

(cond 
 ((args:get-arg "-run")
  (let ((runid (string->number (args:get-arg "-run"))))
    (if runid
	(begin
	  (lambda (x)
	    (on-exit (lambda ()
		       (if *db* (sqlite3:finalize! *db*))))
	    (cdb:remote-run examine-run *db* runid)))
	(begin
	  (print "ERROR: runid is not a number " (args:get-arg "-run"))
	  (exit 1)))))
 ((args:get-arg "-test")
  (let ((testid (string->number (args:get-arg "-test"))))


    (if (and (number? testid)

	     (>= testid 0))
	(examine-test testid)
	(begin
	  (debug:print 3 "INFO: tried to open test with invalid test-id. " (args:get-arg "-test"))
	  (exit 1)))))
 ((args:get-arg "-guimonitor")
  (gui-monitor *db*))
 (else
  (set! uidat (make-dashboard-buttons *num-runs* *num-tests* *dbkeys*))
  (iup:callback-set! *tim*
		     "ACTION_CB"
		     (lambda (x)
		       (let ((update-is-running #f))
			 (mutex-lock! *update-mutex*)
			 (set! update-is-running *update-is-running*)
			 (if (not update-is-running)







|
<
|



|
|
>
>
|
>
|
|

|


|

|







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

(cond 
 ((args:get-arg "-run")
  (let ((runid (string->number (args:get-arg "-run"))))
    (if runid
	(begin
	  (lambda (x)
	    (on-exit std-exit-procedure)

	    (examine-run *dbstruct-local* runid)))
	(begin
	  (print "ERROR: runid is not a number " (args:get-arg "-run"))
	  (exit 1)))))
 ((args:get-arg "-test") ;; run-id,test-id
  (let* ((dat     (map string->number (string-split (args:get-arg "-test") ",")))
	 (run-id  (car dat))
	 (test-id (cadr dat)))
    (if (and (number? run-id)
	     (number? test-id)
	     (>= test-id 0))
	(examine-test run-id test-id)
	(begin
	  (debug:print 3 "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test"))
	  (exit 1)))))
 ((args:get-arg "-guimonitor")
  (gui-monitor *dbstruct-local*))
 (else
  (set! uidat (make-dashboard-buttons *dbstruct-local* *num-runs* *num-tests* *dbkeys*))
  (iup:callback-set! *tim*
		     "ACTION_CB"
		     (lambda (x)
		       (let ((update-is-running #f))
			 (mutex-lock! *update-mutex*)
			 (set! update-is-running *update-is-running*)
			 (if (not update-is-running)
1562
1563
1564
1565
1566
1567
1568
1569
			  ;;   (if (not *please-update-buttons*)
			  ;;       (loop))))))
      (th2 (make-thread iup:main-loop "Main loop")))
  (thread-start! th1)
  (thread-start! th2)
  (thread-join! th2))

;; (iup:main-loop)







|
1576
1577
1578
1579
1580
1581
1582
1583
			  ;;   (if (not *please-update-buttons*)
			  ;;       (loop))))))
      (th2 (make-thread iup:main-loop "Main loop")))
  (thread-start! th1)
  (thread-start! th2)
  (thread-join! th2))

;; (iup:main-loop)(db:close-all *dbstruct-local*)

Deleted datashare-testing/.datashare.config version [1d9aef34b1].

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
# Read in the users vars first (so the offical data cannot be overridden
[include datastore.config]

[storagegroups]
1 eng /tmp/datastore/eng

[areas]
synthesis asic/synthesis
verilog   asic/verilog
oalibs    custom/oalibs

[target]
basepath #{getenv BASEPATH}

[quality]
0 untested
1 lightly tested
2 tested
3 full QA
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































Added datashare-testing/.sd.config version [3db28d187c].







































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
# Read in the users vars first (so the offical data cannot be overridden
[include ~/.datashare.config]

# Read in local overrides
[include datashare.config]

# Replace [storage] with settings entry - more secure
[settings]

storage /tmp/#{getenv USER}/datashare/disk1 \
        /tmp/#{getenv USER}/datashare/disk2

basepath #{getenv BASEPATH}

[areas]
synthesis  asic/synthesis
verilog    asic/verilog
customlibs custom/oalibs
megatest   tools/megatest

[quality]
0 untested
1 lightly tested
2 tested
3 full QA

[database]
location /tmp/#{getenv USER}/datashare

[pathmaps]
SHELF /tmp/#{getenv USER}/theshelf

[buildmethods]
customlibs make setup;make install

Modified datashare.scm from [c941a31a14] to [2abd8aec1c].

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
(use canvas-draw)
(import canvas-draw-iup)

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

(declare (uses configf))











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

;;
;; GLOBALS
;;
(define *datashare:current-tab-number* 0)

(define datashare:help (conc "Usage: datashare [action [params ...]]

Note: run datashare without parameters to start the gui.

  publish <area> <key> [group]        : Publish data to share, use group to protect (i)
  get <area> <key> [destpath]         : Get a link to data, put the link in destpath (ii)
  update <area> <key>                 : Update the link to data to the latest iteration.



(i)  Uses group ownership of files to be published for group if not specified


(ii) Uses local path or looks up script to find path in configs


Part of the Megatest tool suite. Learn more at http://www.kiatoa.com/fossils/megatest


Version: " megatest-fossil-hash)) ;; "







































;;======================================================================
;; DB
;;======================================================================

(define (datashare:initialize-db db)
  (for-each
   (lambda (qry)
     (sqlite3:execute db qry))
   (list 
    "CREATE TABLE pkgs 
         (id        INTEGER PRIMARY KEY,
          area      TEXT,



          key       TEXT,

          iteration INTEGER,
          submitter TEXT,
          datetime  TEXT,
          storegrp  TEXT,
          datavol   INTEGER,
          quality   TEXT,
          disk_id   INTEGER,
          comment   TEXT);"
    "CREATE TABLE refs
         (id        INTEGER PRIMARY KEY,
          pkg_id    INTEGER,
          destlink  TEXT);"
    "CREATE TABLE disks
         (id         INTEGER PRIMARY KEY,
          storegrp   TEXT,
          path       TEXT);")))














































































;; Create the sqlite db
(define (datashare:open-db path) 

  (if (and path
	   (directory? path)
	   (file-read-access? path))
      (let* ((dbpath    (conc path "/datashare.db"))
	     (writeable (file-write-access? dbpath))
	     (dbexists  (file-exists? dbpath))
	     (handler   (make-busy-timeout 136000)))
	(handle-exceptions
	 exn
	 (begin
	   (debug:print 2 "ERROR: problem accessing db " dbpath
			((condition-property-accessor 'exn 'message) exn))
	   (exit))
	 (set! db (sqlite3:open-database dbpath)))
	(if *db-write-access* (sqlite3:set-busy-handler! db handler))
	(if (not dbexists)
	    (begin
	      (datashare:initialize-db db)))
	db)))

























































































































































































;;======================================================================
;; GUI
;;======================================================================

;; The main menu 
(define (datashare:main-menu)







>
>
>
>
>
>
>
>
>
>







>




|
|
|
>

>
|
>
>
|
>

|
>



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










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








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


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







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
(use canvas-draw)
(import canvas-draw-iup)

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

(declare (uses configf))
(declare (uses tree))
(declare (uses margs))
;; (declare (uses dcommon))
;; (declare (uses launch))
;; (declare (uses gutils))
;; (declare (uses db))
;; (declare (uses synchash))
;; (declare (uses server))
;; (declare (uses megatest-version))
;; (declare (uses tbd))

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

;;
;; GLOBALS
;;
(define *datashare:current-tab-number* 0)
(define *args-hash* (make-hash-table))
(define datashare:help (conc "Usage: datashare [action [params ...]]

Note: run datashare without parameters to start the gui.

  list-areas                          : List the allowed areas

  list-versions <area>                : List versions available in <area>
         options : -full, -vpatt patt

  publish <path> <area> <version>     : Publish data for area and with version

  get <area> <version>                : Get a link to data, put the link in destpath
         options : -i iteration

  update <area>                       : Update the link to data to the latest iteration.

Part of the Megatest tool suite.
Learn more at http://www.kiatoa.com/fossils/megatest

Version: " megatest-fossil-hash)) ;; "

;;======================================================================
;; RECORDS
;;======================================================================

;; make-vector-record "testing" datastore pkg id area version_name store_type copied source_path iteration submitter datetime storegrp datavol quality disk_id comment
;; testing
(define (make-datashare:pkg)(make-vector 15))
(define-inline (datashare:pkg-get-id             vec)    (vector-ref  vec 0))
(define-inline (datashare:pkg-get-area           vec)    (vector-ref  vec 1))
(define-inline (datashare:pkg-get-version_name   vec)    (vector-ref  vec 2))
(define-inline (datashare:pkg-get-store_type     vec)    (vector-ref  vec 3))
(define-inline (datashare:pkg-get-copied         vec)    (vector-ref  vec 4))
(define-inline (datashare:pkg-get-source_path    vec)    (vector-ref  vec 5))
(define-inline (datashare:pkg-get-iteration      vec)    (vector-ref  vec 6))
(define-inline (datashare:pkg-get-submitter      vec)    (vector-ref  vec 7))
(define-inline (datashare:pkg-get-datetime       vec)    (vector-ref  vec 8))
(define-inline (datashare:pkg-get-storegrp       vec)    (vector-ref  vec 9))
(define-inline (datashare:pkg-get-datavol        vec)    (vector-ref  vec 10))
(define-inline (datashare:pkg-get-quality        vec)    (vector-ref  vec 11))
(define-inline (datashare:pkg-get-disk_id        vec)    (vector-ref  vec 12))
(define-inline (datashare:pkg-get-comment        vec)    (vector-ref  vec 13))
(define-inline (datashare:pkg-get-stored_path    vec)    (vector-ref  vec 14))
(define-inline (datashare:pkg-set-id!            vec val)(vector-set! vec 0 val))
(define-inline (datashare:pkg-set-area!          vec val)(vector-set! vec 1 val))
(define-inline (datashare:pkg-set-version_name!  vec val)(vector-set! vec 2 val))
(define-inline (datashare:pkg-set-store_type!    vec val)(vector-set! vec 3 val))
(define-inline (datashare:pkg-set-copied!        vec val)(vector-set! vec 4 val))
(define-inline (datashare:pkg-set-source_path!   vec val)(vector-set! vec 5 val))
(define-inline (datashare:pkg-set-iteration!     vec val)(vector-set! vec 6 val))
(define-inline (datashare:pkg-set-submitter!     vec val)(vector-set! vec 7 val))
(define-inline (datashare:pkg-set-datetime!      vec val)(vector-set! vec 8 val))
(define-inline (datashare:pkg-set-storegrp!      vec val)(vector-set! vec 9 val))
(define-inline (datashare:pkg-set-datavol!       vec val)(vector-set! vec 10 val))
(define-inline (datashare:pkg-set-quality!       vec val)(vector-set! vec 11 val))
(define-inline (datashare:pkg-set-disk_id!       vec val)(vector-set! vec 12 val))
(define-inline (datashare:pkg-set-comment!       vec val)(vector-set! vec 13 val))
(define-inline (datashare:pkg-set-stored_path!   vec val)(vector-set! vec 14 val))

;;======================================================================
;; DB
;;======================================================================

(define (datashare:initialize-db db)
  (for-each
   (lambda (qry)
     (sqlite3:execute db qry))
   (list 
    "CREATE TABLE pkgs 
         (id           INTEGER PRIMARY KEY,
          area         TEXT,
          version_name TEXT,
          store_type   TEXT DEFAULT 'copy',
          copied       INTEGER DEFAULT 0,
          source_path  TEXT,
          stored_path  TEXT,
          iteration    INTEGER DEFAULT 0,
          submitter    TEXT,
          datetime     TIMESTAMP DEFAULT (strftime('%s','now')),
          storegrp     TEXT,
          datavol      INTEGER,
          quality      TEXT,
          disk_id      INTEGER,
          comment      TEXT);"
    "CREATE TABLE refs
         (id        INTEGER PRIMARY KEY,
          pkg_id    INTEGER,
          destlink  TEXT);"
    "CREATE TABLE disks
         (id         INTEGER PRIMARY KEY,
          storegrp   TEXT,
          path       TEXT);")))

(define (datashare:register-data db area version-name store-type submitter quality source-path comment)
  (let ((iter-qry       (sqlite3:prepare db "SELECT max(iteration) FROM pkgs WHERE area=? AND version_name=?;"))
	(next-iteration 0))
    (sqlite3:with-transaction
     db
     (lambda ()
       (sqlite3:for-each-row
	(lambda (iteration)
	  (if (and (number? iteration)
		   (>= iteration next-iteration))
	      (set! next-iteration (+ iteration 1))))
	iter-qry area version-name)
       ;; now store the data
       (sqlite3:execute db "INSERT INTO pkgs (area,version_name,iteration,store_type,submitter,source_path,quality,comment) 
                                 VALUES (?,?,?,?,?,?,?,?);"
			area version-name next-iteration (conc store-type) submitter source-path quality comment)))
    (sqlite3:finalize! iter-qry)
    next-iteration))

(define (datashare:get-id db area version-name iteration)
  (let ((res #f))
    (sqlite3:for-each-row
     (lambda (id)
       (set! res id))
     db
     "SELECT id FROM pkgs WHERE area=? AND version_name=? AND iteration=?;"
     area version-name iteration)
    res))

(define (datashare:set-stored-path db id path)
  (sqlite3:execute db "UPDATE pkgs SET stored_path=? WHERE id=?;" path id))

(define (datashare:set-copied db id value)
  (sqlite3:execute db "UPDATE pkgs SET copied=? WHERE id=?;" value id))
  
(define (datashare:get-pkg-record db area version-name iteration)
  (let ((res #f))
    (sqlite3:for-each-row
     (lambda (a . b)
       (set! res (apply vector a b)))
     db 
     "SELECT * FROM pkgs WHERE area=? AND version_name=? AND iteration=?;"
     area 
     version-name
     iteration)
    res))

;; take version-name iteration and register or update "lastest/0"
;;
(define (datashare:set-latest db id area version-name iteration)
  (let* ((rec         (datashare:get-pkg-record db area version-name iteration))
	 (latest-id   (datashare:get-id db area "latest" 0))
	 (stored-path (datashare:pkg-get-stored_path rec)))
    (if latest-id ;; have a record - bump the link pointer
	(datashare:set-stored-path db latest-id stored-path)
	(datashare:register-data db area "latest" 'link "auto" "na" stored-path "latest data"))))

;; set a package ref, this is the location where the link back to the stored data 
;; is put. 
;;
;; if there is nothing at that location then the record can be removed
;; if there are no refs for a particular pkg-id then that pkg-id is a 
;; candidate for removal
;;
(define (datashare:record-pkg-ref db pkg-id dest-link)
  (sqlite3:execute db "INSERT INTO refs (pkg_id,destlink) VALUES (?,?);" pkg-id dest-link))
  
(define (datashare:count-refs db pkg-id)
  (let ((res 0))
    (sqlite3:for-each-row
     (lambda (count)
       (set! res count))
     db
     "SELECT count(id) FROM refs WHERE pkg_id=?;"
     pkg-id)
    res))

;; Create the sqlite db
(define (datashare:open-db configdat) 
  (let ((path (configf:lookup configdat "database" "location")))
    (if (and path
	     (directory? path)
	     (file-read-access? path))
	(let* ((dbpath    (conc path "/datashare.db"))
	       (writeable (file-write-access? dbpath))
	       (dbexists  (file-exists? dbpath))
	       (handler   (make-busy-timeout 136000)))
	  (handle-exceptions
	   exn
	   (begin
	     (debug:print 2 "ERROR: problem accessing db " dbpath
			  ((condition-property-accessor 'exn 'message) exn))
	     (exit))
	   (set! db (sqlite3:open-database dbpath)))
	  (if *db-write-access* (sqlite3:set-busy-handler! db handler))
	  (if (not dbexists)
	      (begin
		(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))
        (print "exn=" (condition->list exn))
        (print " status:  " ((condition-property-accessor 'sqlite3 'status) exn))
        (print-call-chain (current-error-port))
        (thread-sleep! sleep-time)
        (print "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up")))
     (apply open-run-close-exception-handling proc idb params))
   (apply open-run-close-no-exception-handling proc idb params)))

(define (open-run-close-no-exception-handling  proc idb . params)
  ;; (print "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params)
  (let* ((db (cond
	      ((sqlite3:database? idb)     idb)
	      ((not idb)                   (print "ERROR: cannot open-run-close with #f anymore"))
	      ((procedure? idb)            (idb))
	      (else                        (print "ERROR: cannot open-run-close with #f anymore"))))
	 (res #f))
    (set! res (apply proc db params))
    (if (not idb)(sqlite3:finalize! dbstruct))
    ;; (print "open-run-close-no-exception-handling END" )
    res))

(define open-run-close open-run-close-no-exception-handling)

(define (datashare:get-pkgs db area-filter version-filter iter-filter)
  (let ((res '()))
    (sqlite3:for-each-row ;; replace with fold ...
     (lambda (a . b)
       (set! res (cons (list->vector (cons a b)) res)))
     db 
     (conc "SELECT id,area,version_name,store_type,copied,source_path,iteration,submitter,datetime,storegrp,datavol,quality,disk_id,comment,stored_path "
	   " FROM pkgs WHERE area like ? AND version_name LIKE ? AND iteration " iter-filter ";")
     area-filter version-filter)
    (reverse res)))

(define (datashare:get-pkg db area-name version-name #!key (iteration #f))
  (let ((dat '())
	(res #f))
    (sqlite3:for-each-row ;; replace with fold ...
     (lambda (a . b)
       (set! dat (cons (list->vector (cons a b)) dat)))
     db 
     (conc "SELECT id,area,version_name,store_type,copied,source_path,iteration,submitter,datetime,storegrp,datavol,quality,disk_id,comment,stored_path "
	   " FROM pkgs WHERE area=? AND version_name=? ORDER BY iteration ASC;")
     area-name version-name)
    ;; now filter for iteration, either max if #f or specific one
    (if (null? dat)
	#f
	(let loop ((hed (car dat))
		   (tal (cdr dat))
		   (cur 0))
	  (let ((itr (datashare:pkg-get-iteration hed)))
	    (if (equal? itr iteration) ;; this is the one if iteration is specified
		hed
		(if (null? tal)
		    hed
		    (loop (car tal)(cdr tal)))))))))

(define (datashare:get-versions-for-area db area-name #!key (version-patt #f))
  (let ((res '())
	(data (make-hash-table)))
    (sqlite3:for-each-row
     (lambda (version-name submitter iteration submitted-time comment)
       ;;                                              0           1         2           3           4
       (hash-table-set! data version-name (vector version-name submitter iteration submitted-time comment)))
     db 
     "SELECT version_name,submitter,iteration,datetime,comment FROM pkgs WHERE area='megatest' AND version_name != 'latest' AND version_name LIKE ? ORDER BY datetime asc;"
     (or version-patt "%"))
    (map (lambda (x)(hash-table-ref data x))(sort (hash-table-keys data) string-ci>=))))

;;======================================================================
;; DATA IMPORT/EXPORT
;;======================================================================

(define (datashare:import-data configdat source-path dest-path area version iteration)
  (let* ((space-avail (car dest-path))
	 (disk-path   (cdr dest-path))
	 (targ-path   (conc disk-path "/" area "/" version "/" iteration))
	 (id          (datashare:get-id db area version iteration))
	 (db          (datashare:open-db configdat)))
    (if (> space-avail 10000) ;; dumb heuristic
	(begin
	  (create-directory targ-path #t)
	  (datashare:set-stored-path db id targ-path)
	  (print "Running command: rsync -av " source-path "/ " targ-path "/")
	  (let ((th1 (make-thread (lambda ()
				    (let ((pid (process-run "rsync" (list "-av" (conc source-path "/") (conc targ-path "/")))))
				      (process-wait pid)
				      (datashare:set-copied db id "yes")
				      (sqlite3:finalize! db)))
				   "Data copy")))
	    (thread-start! th1))
	  #t)
	(begin
	  (print "ERROR: Not enough space in storage area " dest-path)
	  (datashare:set-copied db id "no")
	  (sqlite3:finalize! db)
	  #f))))

(define (datashare:get-areas configdat)
  (let* ((areadat (configf:get-section configdat "areas"))
	 (areas   (if areadat (map car areadat) '())))
    areas))

(define (datashare:publish configdat publish-type area-name version comment spath submitter quality)
  ;; input checks
  (cond 
   ((not (member area-name (datashare:get-areas configdat)))
    (cons #f (conc "Illegal area name \"" area-name "\"")))
   (else
    (let ((db          (datashare:open-db configdat))
	  (iteration   (datashare:register-data db area-name version publish-type submitter quality spath comment))
	  (dest-store  (datashare:get-best-storage configdat)))
      (if iteration
	  (if (eq? 'copy publish-type)
	      (begin
		(datashare:import-data configdat spath dest-store area-name version iteration)
		(let ((id (datashare:get-id db area-name version iteration)))
		  (datashare:set-latest db id area-name version iteration)))
	      (let ((id (datashare:get-id db area-name version iteration)))
		(datashare:set-stored-path db id spath)
		(datashare:set-copied db id "yes")
		(datashare:set-copied db id "n/a")
		(datashare:set-latest db id area-name version iteration)))
	  (print "ERROR: Failed to get an iteration number"))
      (sqlite3:finalize! db)
      (cons #t "Successfully saved data")))))

(define (datashare:get-best-storage configdat)
  (let* ((storage     (configf:lookup configdat "settings" "storage"))
	 (store-areas (if storage (string-split storage) '())))
    (print "Looking for available space in " store-areas)
    (datashare:find-most-space store-areas)))

;; (string->number (list-ref (with-input-from-pipe "df -B1000000 /tmp" (lambda ()(read-line)(string-split (read-line)))) 3))

(define (datashare:find-most-space paths)
  (fold (lambda (area res)
	  ;; (print "area=" area " res=" res)
	  (let ((maxspace (car res))
		(currpath (cdr res)))
	    ;; (print currpath " " maxspace)
	    (if (file-write-access? area)
		(let ((currspace (string->number
				  (list-ref
				   (with-input-from-pipe 
				    ;; (conc "df --output=avail " area)
				    (conc "df -B1000000 " area)
				    ;; (lambda ()(read)(read))
				    (lambda ()(read-line)(string-split (read-line))))
				   3))))
		  (if (> currspace maxspace) 
		      (cons currspace area)
		      res))
		res)))
	(cons 0 #f)
	paths))

;; remove existing link and if possible ...
;; create path to next of tip of target, create link back to source
(define (datashare:build-dir-make-link source target)
  (if (file-exists? target)(datashare:backup-move target))
  (create-directory (pathname-directory target) #t)
  (create-symbolic-link source target))

(define (datashare:backup-move path)
  (let* ((trashdir  (conc (pathname-directory path) "/.trash"))
	 (trashfile (conc trashdir "/" (current-seconds) "-" (pathname-file path))))
    (create-directory trashdir #t)
    (if (directory? path)
	(system (conc "mv " path " " trashfile))
	(file-move path trash-file))))

;;======================================================================
;; GUI
;;======================================================================

;; The main menu 
(define (datashare:main-menu)
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
		       ;;  					     ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current
		       ;;  					     ;; #:x 'mouse
		       ;;  					     ;; #:y 'mouse
		       ;;  )					     
		       ))))

(define (datashare:publish-view configdat)


  (let* ((label-size  "50x")
	 (areas-sel   (iup:listbox #:expand "YES" #:dropdown "YES"))



	 (version-val (iup:textbox #:expand "YES" #:size "50x"))

	 (iteration   (iup:textbox #:expand "YES" #:size "20x"))


	 (comment     (iup:textbox #:expand "YES"))
	 (source-path (iup:textbox #:expand "YES"))





















	 (browse-btn  (iup:button "Browse"
				  #:size "40x"
				  #:action (lambda (obj)
					     (let* ((fd  (iup:file-dialog #:dialogtype "DIR"))
						    (top (iup:show fd #:modal? "YES")))
					       (iup:attribute-set! source-path "VALUE"
								   (iup:attribute fd "VALUE"))
					       (iup:destroy! fd))))))







    (iup:vbox
     (iup:hbox (iup:label "Area:"        #:size label-size)   areas-sel)

     (iup:hbox (iup:label "Version:"     #:size label-size)   version-val

	       (iup:label "Iteration:")   iteration)
     (iup:hbox (iup:label "Comment:"     #:size label-size)   comment)
     (iup:hbox (iup:label "Source path:" #:size label-size)   source-path browse-btn))))













(define (datashare:get-view configdat)
  (iup:vbox
   (iup:hbox 




















    (iup:button "Pushme"


		#:expand "YES"
















		))))
















































































(define (datashare:manage-view configdat)
  (iup:vbox
   (iup:hbox 
    (iup:button "Pushme"
		#:expand "YES"
		))))







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





|


>
>
>
>
>
>
>

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



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







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
		       ;;  					     ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current
		       ;;  					     ;; #:x 'mouse
		       ;;  					     ;; #:y 'mouse
		       ;;  )					     
		       ))))

(define (datashare:publish-view configdat)
  ;; (pp (hash-table->alist configdat))
  (let* ((areas       (configf:get-section configdat "areas"))
	 (label-size  "70x")
	 (areas-sel   (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES"))
	 (version-tb  (iup:textbox #:expand "HORIZONTAL")) ;;  #:size "50x"))
	 (areas-sel   (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES"))
	 (component   (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES" ))
	 (version-val (iup:textbox #:expand "HORIZONTAL" #:size "50x"))
	 ;; (copy-link   (iup:toggle  #:expand "HORIZONTAL"))
	 ;; (iteration   (iup:textbox #:expand "YES" #:size "20x"))
	 ;; (iteration   (iup:textbox #:expand "HORIZONTAL" #:size "20x"))
	 (area-filter (iup:textbox #:expand "HORIZONTAL" #:value "%"))
	 (comment-tb  (iup:textbox #:expand "YES" #:multiline "YES"))
	 (source-tb   (iup:textbox #:expand "HORIZONTAL"
				   #:value (or (configf:lookup configdat "settings" "basepath")
					       "")))
	 (publish     (lambda (publish-type)
			(let* ((area-num    (or (string->number (iup:attribute areas-sel "VALUE")) 0))
			       (area-dat    (if (> area-num 0)(list-ref areas (- area-num 1))'("NOT SELECTED" "NOT SELECTED")))
			       (area-path   (cadr area-dat))
			       (area-name   (car  area-dat))
			       (version     (iup:attribute version-tb "VALUE"))
			       (comment     (iup:attribute comment-tb "VALUE"))
			       (spath       (iup:attribute source-tb  "VALUE"))
			       (submitter   (current-user-name))
			       (quality     2))
			  (datashare:publish configdat publish-type area-name version comment spath submitter quality))))
	 (copy        (iup:button "Copy and Publish"
				  #:expand "HORIZONTAL"
				  #:action (lambda (obj)
					     (publish 'copy))))
	 (link        (iup:button "Link and Publish"
				  #:expand "HORIZONTAL"
				  #:action (lambda (obj)
					     (publish 'link))))
	 (browse-btn  (iup:button "Browse"
				  #:size "40x"
				  #:action (lambda (obj)
					     (let* ((fd  (iup:file-dialog #:dialogtype "DIR"))
						    (top (iup:show fd #:modal? "YES")))
					       (iup:attribute-set! source-tb "VALUE"
								   (iup:attribute fd "VALUE"))
					       (iup:destroy! fd))))))
    (print "areas")
    ;; (pp areas)
    (fold (lambda (areadat num)
	    ;; (print "Adding num=" num ", areadat=" areadat)
	    (iup:attribute-set! areas-sel (conc num) (car areadat))
	    (+ 1 num))
	  1 areas)
    (iup:vbox
     (iup:hbox (iup:label "Area:"        #:size label-size) ;; area-filter 
	       areas-sel)
     (iup:hbox (iup:label "Version:"     #:size label-size)   version-tb)
     ;; (iup:hbox (iup:label "Link only"    #:size label-size)   copy-link)
     ;; 	       (iup:label "Iteration:")   iteration)
     (iup:hbox (iup:label "Comment:"     #:size label-size)   comment-tb)
     (iup:hbox (iup:label "Source base path:" #:size label-size)   source-tb browse-btn)
     (iup:hbox copy link))))

(define (datashare:lst->path pathlst)
  (conc "/" (string-intersperse (map conc pathlst) "/")))

(define (datashare:path->lst path)
  (string-split path "/"))

(define (datashare:pathdat-apply-heuristics configdat path)
  (cond
   ((file-exists? path) "found")
   (else (conc path " not installed"))))

(define (datashare:get-view configdat)
  (iup:vbox
   (iup:hbox
    (let* ((label-size     "60x")
	   ;; filter elements
	   (area-filter    "%")
	   (version-filter "%")
	   (iter-filter    ">= 0")
	   ;; reverse lookup from path to data for src and installed
	   (srcdat         (make-hash-table)) ;; reverse lookup
	   (installed-dat  (make-hash-table))
	   ;; config values
	   (basepath       (configf:lookup configdat "settings" "basepath"))
	   ;; gui elements
	   (submitter      (iup:label "" #:expand "HORIZONTAL"))
	   (date-submitted (iup:label "" #:expand "HORIZONTAL"))
	   (comment        (iup:label "" #:expand "HORIZONTAL"))
	   (copy-link      (iup:label "" #:expand "HORIZONTAL"))
	   (quality        (iup:label "" #:expand "HORIZONTAL"))
	   (installed-status (iup:label "" #:expand "HORIZONTAL"))
	   ;; misc 
	   (curr-record    #f)
	   ;; (source-data    (iup:label "" #:expand "HORIZONTAL"))
	   (tb             (iup:treebox
			    #:value 0
			    #:name "Packages"
			    #:expand "YES"
			    #:addexpanded "NO"
			    #:selection-cb
			    (lambda (obj id state)
			      ;; (print "obj: " obj ", id: " id ", state: " state)
			      (let* ((path   (datashare:lst->path (cdr (tree:node->path obj id))))
				     (record (hash-table-ref/default srcdat path #f)))
				(if record
				    (begin
				      (set! curr-record record)
				      (iup:attribute-set! submitter      "TITLE" (datashare:pkg-get-submitter record))
				      (iup:attribute-set! date-submitted "TITLE" (time->string (seconds->local-time (datashare:pkg-get-datetime record))))
				      (iup:attribute-set! comment        "TITLE" (datashare:pkg-get-comment record))
				      (iup:attribute-set! quality        "TITLE" (datashare:pkg-get-quality record))
				      (iup:attribute-set! copy-link      "TITLE" (datashare:pkg-get-store_type record))
				      ))
				;; (print  "id=" id " path=" path " record=" record);; (tree:node->path obj id) " run-id: " run-id)
				))))
	   (tb2             (iup:treebox
			    #:value 0
			    #:name "Installed"
			    #:expand "YES"
			    #:addexpanded "NO"
			    #:selection-cb
			    (lambda (obj id state)
			      ;; (print "obj: " obj ", id: " id ", state: " state)
			      (let* ((path   (datashare:lst->path (cdr (tree:node->path obj id))))
				     (status (hash-table-ref/default installed-dat path #f)))
				(iup:attribute-set! installed-status "TITLE" (if status status ""))
				))))
	   (refresh        (lambda (obj)
			     (let* ((db    (datashare:open-db configdat))
				    (areas (or (configf:get-section configdat "areas") '())))
			       ;;
			       ;; first update the Sources
			       ;;
			       (for-each
				(lambda (pkgitem)
				  (let* ((pkg-path   (list (datashare:pkg-get-area  pkgitem)
							   (datashare:pkg-get-version_name pkgitem)
							   (datashare:pkg-get-iteration pkgitem)))
					 (pkg-id     (datashare:pkg-get-id          pkgitem))
					 (path       (datashare:lst->path pkg-path)))
				    ;; (print "tree:add-node tb=" tb ", pkg-path=" pkg-path ", pkg-id=" pkg-id)
				    (if (not (hash-table-ref/default srcdat path #f))
					(tree:add-node tb "Packages" pkg-path userdata: (conc "pkg-id: " pkg-id)))
				    ;; (print "path=" path " pkgitem=" pkgitem)
				    (hash-table-set! srcdat path pkgitem)))
				(datashare:get-pkgs db area-filter version-filter iter-filter))
			       ;;
			       ;; then update the installed
			       ;;
			       (for-each
				(lambda (area)
				  (let* ((path     (conc "/" (cadr area)))
					 (fullpath (conc basepath path)))
				    (if (not (hash-table-ref/default installed-dat path #f))
					(tree:add-node tb2 "Installed" (datashare:path->lst path)))
				    (hash-table-set! installed-dat path (datashare:pathdat-apply-heuristics configdat fullpath))))
				areas)
			       (sqlite3:finalize! db))))
	   (apply          (iup:button "Apply"
				       #:action
				       (lambda (obj)
					 (if curr-record
					     (let* ((area        (datashare:pkg-get-area        curr-record))
						    (stored-path (datashare:pkg-get-stored_path curr-record))
						    (source-type (datashare:pkg-get-store_type  curr-record))
						    (source-path (case source-type ;;  (equal? source-type "link"))
								   ((link)(datashare:pkg-get-source-path curr-record))
								   ((copy)stored-path)
								   (else #f)))
						    (dest-stub   (configf:lookup configdat "areas" area))
						    (target-path (conc basepath "/" dest-stub)))
					       (datashare:build-dir-make-link stored-path target-path)
					       (print "Creating link from " stored-path " to " target-path)))))))
      (iup:vbox 
       (iup:hbox tb tb2)
       (iup:frame 
	#:title "Source Info"
	(iup:vbox
	 (iup:hbox (iup:button "Refresh" #:action refresh) apply)
	 (iup:hbox (iup:label "Submitter: ") ;;  #:size label-size)
		   submitter 
		   (iup:label "Submitted on: ") ;;  #:size label-size)
		   date-submitted)
	 (iup:hbox (iup:label "Data stored: ")
		   copy-link
		   (iup:label "Quality: ")
		   quality)
	 (iup:hbox (iup:label "Comment: ")
		   comment)))
       (iup:frame
	#:title "Installed Info"
	(iup:vbox
	 (iup:hbox (iup:label "Installed status/path: ") installed-status)))
       )))))

(define (datashare:manage-view configdat)
  (iup:vbox
   (iup:hbox 
    (iup:button "Pushme"
		#:expand "YES"
		))))
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
	;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
	(iup:attribute-set! tabs "TABTITLE0" "Publish")
	(iup:attribute-set! tabs "TABTITLE1" "Get")
	(iup:attribute-set! tabs "TABTITLE2" "Manage")
	;; (iup:attribute-set! tabs "BGCOLOR" "190 190 190")
	tabs)))
  (iup:main-loop))



























;;======================================================================
;; MAIN
;;======================================================================

(define (datashare:load-config path)
  (let ((fname (conc path "/.datashare.config")))
    (ini:property-separator-patt " *  *")
    (ini:property-separator #\space)
    (if (file-exists? fname)
	;; (ini:read-ini fname)
	(read-config fname #f #t)
	(make-hash-table))))














































































(define (main)
  (let* ((args      (argv))
	 (prog      (car args))
	 (rema      (cdr args))



	 (configdat (datashare:load-config (pathname-directory prog))))
    (cond

     ((eq? (length rema) 1)
      (case (string->symbol (car rema))
	((help -h -help --h --help)
	 (print datashare:help))


	(else
	 (print "ERROR: Unrecognised command. Try \"datashare help\""))))

     ((null? rema)(datashare:gui configdat))
     ((>= (length rema) 2)
      (apply process-action (car rema)(cdr rema)))
     (else (print "ERROR: Unrecognised command. Try \"datashare help\"")))))

(main)







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





|
|







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




>
>
>
|

>




>
>


>


|



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
	;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
	(iup:attribute-set! tabs "TABTITLE0" "Publish")
	(iup:attribute-set! tabs "TABTITLE1" "Get")
	(iup:attribute-set! tabs "TABTITLE2" "Manage")
	;; (iup:attribute-set! tabs "BGCOLOR" "190 190 190")
	tabs)))
  (iup:main-loop))

;;======================================================================
;; MISC
;;======================================================================


(define (datashare:do-as-calling-user proc)
  (let ((eid (current-effective-user-id))
        (cid (current-user-id)))
    (if (not (eq? eid cid)) ;; running suid
            (set! (current-effective-user-id) cid))
    ;; (print "running as " (current-effective-user-id))
    (proc)
    (if (not (eq? eid cid))
        (set! (current-effective-user-id) eid))))

(define (datashare:find name paths)
  (if (null? paths)
      #f
      (let loop ((hed (car paths))
		 (tal (cdr paths)))
	(if (file-exists? (conc hed "/" name))
	    hed
	    (if (null? tal)
		#f
		(loop (car tal)(cdr tal)))))))

;;======================================================================
;; MAIN
;;======================================================================

(define (datashare:load-config exe-dir exe-name)
  (let* ((fname   (conc exe-dir "/." exe-name ".config")))
    (ini:property-separator-patt " *  *")
    (ini:property-separator #\space)
    (if (file-exists? fname)
	;; (ini:read-ini fname)
	(read-config fname #f #t)
	(make-hash-table))))

(define (datashare:process-action configdat action . args)
  (case (string->symbol action)
    ((get)
     (if (< (length args) 2)
	 (begin 
	   (print "ERROR: Missing arguments; " (string-intersperse args ", "))
	   (exit 1))
	 (let* ((basepath    (configf:lookup configdat "settings" "basepath"))
		(db          (datashare:open-db configdat))
		(area        (car args))
		(version     (cadr args)) ;;    iteration
		(remargs     (args:get-args args '("-i") '() args:arg-hash 0))
		(iteration   (if (args:get-arg "-i")(string->number (args:get-arg "-i")) #f))
		(curr-record (datashare:get-pkg db area version iteration: iteration)))
	   (if (not curr-record)
	       (begin
		 (print "ERROR: No matching record found; area=" area ", version=" version ", iteration=" (if iteration iteration "(max)"))
		 (exit 1))
	       (let* ((stored-path (datashare:pkg-get-stored_path curr-record))
		      (source-type (datashare:pkg-get-store_type  curr-record))
		      (source-path (case source-type ;;  (equal? source-type "link"))
				     ((link) (datashare:pkg-get-source-path curr-record))
				     ((copy) stored-path)
				     (else #f)))
		      (dest-stub   (configf:lookup configdat "areas" area))
		      (target-path (conc basepath "/" dest-stub)))
		 (datashare:build-dir-make-link stored-path target-path)
		 (datashare:record-pkg-ref db (datashare:pkg-get-id curr-record) target-path)
		 (sqlite3:finalize! db)
		 (print "Creating link from " stored-path " to " target-path))))))
    ((publish)
     (if (< (length args) 3)
	 (begin 
	   (print "ERROR: Missing arguments; " (string-intersperse args ", "))
	   (exit 1))
	 (let* ((srcpath  (list-ref args 0))
		(areaname (list-ref args 1))
		(version  (list-ref args 2))
		(remargs  (args:get-args (drop args 2)
					 '("-type" ;; link or copy (default is copy)
					   "-m")
 					 '()
 					 args:arg-hash
 					 0))
		(publish-type (if (equal? (args:get-arg "-type") "link") 'link 'copy))
		(comment      (or (args:get-arg "-m") ""))
		(submitter    (current-user-name))
		(quality      (args:get-arg "-quality"))
		(publish-res  (datashare:publish configdat publish-type areaname version comment srcpath submitter quality)))
	   (if (not (car publish-res))
	       (begin
		 (print "ERROR: " (cdr publish-res))
		 (exit 1))))))
    ((list-versions)
     (let ((area-name (car args)) ;;      version patt   full print
	   (remargs   (args:get-args args '("-vpatt") '("-full") args:arg-hash 0))
	   (db        (datashare:open-db configdat))
	   (versions  (datashare:get-versions-for-area db (car args) version-patt: (args:get-arg "-vpatt"))))
       ;; (print "area-name=" area-name " args=" args " *args-hash*=" (hash-table->alist *args-hash*))
       (map (lambda (x)
	      (if (args:get-arg "-full")
		  (format #t 
			  "~10a~10a~4a~27a~30a\n"
			  (vector-ref x 0)
			  (vector-ref x 1) 
			  (vector-ref x 2) 
			  (conc "\"" (time->string (seconds->local-time (vector-ref x 3))) "\"")
			  (conc "\"" (vector-ref x 4) "\""))
		  (print (vector-ref x 0))))
	    versions)
       (sqlite3:finalize! db)))))

;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION!
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.datasharerc")))
  (if (file-exists? debugcontrolf)
      (load debugcontrolf)))

(define (main)
  (let* ((args      (argv))
	 (prog      (car args))
	 (rema      (cdr args))
	 (exe-name  (pathname-file (car (argv))))
	 (exe-dir   (or (pathname-directory prog)
			(datashare:find exe-name (string-split (get-environment-variable "PATH") ":"))))
	 (configdat (datashare:load-config exe-dir exe-name)))
    (cond
     ;; one-word commands
     ((eq? (length rema) 1)
      (case (string->symbol (car rema))
	((help -h -help --h --help)
	 (print datashare:help))
	((list-areas)
	 (map print (datashare:get-areas configdat)))
	(else
	 (print "ERROR: Unrecognised command. Try \"datashare help\""))))
     ;; multi-word commands
     ((null? rema)(datashare:gui configdat))
     ((>= (length rema) 2)
      (apply datashare:process-action configdat (car rema)(cdr rema)))
     (else (print "ERROR: Unrecognised command. Try \"datashare help\"")))))

(main)

Modified db.scm from [eb228185ab] to [cd6cb3bd8f].

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

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

(require-extension (srfi 18) extras tcp) ;;  rpc)
;; (import (prefix rpc rpc:))

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

;; Note, try to remove this dependency 
;; (use zmq)

(declare (unit db))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
(declare (uses fs-transport))
(declare (uses client))
(declare (uses mt))

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




;; timestamp type (val1 val2 ...)



;; type: meta-info, step













(define *incoming-writes*      '())




















(define *completed-writes*   (make-hash-table))




(define *incoming-last-time* (current-seconds))




(define *incoming-mutex*     (make-mutex))













(define *completed-mutex*    (make-mutex))

















(define *cache-on* #f)















































(define (db:set-sync db)
  (let* ((syncval  (config-lookup *configdat* "setup"     "synchronous"))
	 (val      (cond   ;; 0 | OFF | 1 | NORMAL | 2 | FULL;
		    ((not syncval) #f)












		    ((string->number syncval)
		     (let ((val (string->number syncval)))




		       (if (member val '(0 1 2)) val #f)))
		    ((string-match (regexp "yes" #t) syncval) 1)
		    ((string-match (regexp "no"  #t) syncval) 0)
		    ((string-match (regexp "(off|normal|full)" #t) syncval) syncval)


		    (else 
		     (debug:print 0 "ERROR: synchronous must be 0,1,2,OFF,NORMAL or FULL, you provided: " syncval)

		     #f))))







    (if val










	(begin


	  (debug:print-info 9 "db:set-sync, setting pragma synchronous to " val)


	  (sqlite3:execute db (conc "PRAGMA synchronous = '" val "';"))))))
















(define (open-db) ;;  (conc *toppath* "/megatest.db") (car *configinfo*)))
  (if (not *toppath*)





      (if (not (launch:setup-for-run))
	  (begin














	    (debug:print 0 "ERROR: Attempted to open db when not in megatest area. Exiting.")
















	    (exit))))











  (let* ((dbpath       (conc *toppath* "/megatest.db")) ;; fname)
	 (dbexists     (file-exists? dbpath))




	 (write-access (file-write-access? dbpath))


	 (db           (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath))
	 (handler      (make-busy-timeout (if (args:get-arg "-override-timeout")

















































					      (string->number (args:get-arg "-override-timeout"))






					      6000)))) ;; NB// this is in milliseconds. 136000))) ;; 136000 = 2.2 minutes


    (if (and dbexists
















































	     (not write-access))






	(set! *db-write-access* write-access)) ;; only unset so other db's also can use this control

































































































    (debug:print-info 11 "open-db, dbpath=" dbpath " argv=" (argv))


































    (if write-access (sqlite3:set-busy-handler! db handler))























































    (if (not dbexists)






















	(db:initialize db))























    ;; Moving db:set-sync to a call in run.scm - it is a persistent value and only needs to be set once







    ;; (db:set-sync db)






    (sqlite3:execute db "PRAGMA synchronous = 0;")






























































    db))

;; keeping it around for debugging purposes only
(define (open-run-close-no-exception-handling  proc idb . params)
  (debug:print-info 11 "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params)
  (if (or *db-write-access*
	  (not (member proc *db:all-write-procs*)))
      (let* ((db   (cond

		    ((sqlite3:database? idb) idb)
		    ((not idb)               (open-db))
		    ((procedure? idb)       (idb))
		    (else   	            (open-db))))
	     (res #f))
	(set! res (apply proc db params))
	(if (not idb)(sqlite3:finalize! db))
	(debug:print-info 11 "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 "EXCEPTION: database probably overloaded or unreadable.")
	(debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
	(print "exn=" (condition->list exn))
	(debug:print 0 " status:  " ((condition-property-accessor 'sqlite3 'status) exn))
	(print-call-chain)
	(thread-sleep! sleep-time)
	(debug:print-info 0 "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up")))
     (apply open-run-close-exception-handling proc idb params))
   (apply open-run-close-no-exception-handling proc idb params)))

;; (define open-run-close open-run-close-exception-handling)
(define open-run-close open-run-close-exception-handling)

(define *global-delta* 0)
(define *last-global-delta-printed* 0)

(define (open-run-close-measure  proc idb . params)
  (debug:print-info 11 "open-run-close-measure START, idb=" idb ", params=" params)
  (let* ((start-ms (current-milliseconds))
	 (db       (if idb idb (open-db)))
         (throttle (string->number (config-lookup *configdat* "setup" "throttle"))))
    ;; (db:set-sync db)
    (set! res      (apply proc db params))
    (if (not idb)(sqlite3:finalize! db))
    ;; scale by 10, average with current value.
    (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms)
						 (if throttle throttle 0.01)))
			    2))
    (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit
	(begin
	  (debug:print-info 1 "launch throttle factor=" *global-delta*)
	  (set! *last-global-delta-printed* *global-delta*)))
    (debug:print-info 11 "open-run-close-measure END" )
    res))

(define (db:initialize db)
  (debug:print-info 11 "db:initialize START")
  (let* ((configdat (car *configinfo*))  ;; tut tut, global warning...
	 (keys     (keys:config-get-fields configdat))
	 (havekeys (> (length keys) 0))
	 (keystr   (keys->keystr keys))
	 (fieldstr (keys->key/field keys)))

    (for-each (lambda (key)
		(let ((keyn key))
		  (if (member (string-downcase keyn)
			      (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count"
				    "pass_count"))
		      (begin
			(print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table")
			(system (conc "rm -f " dbpath))
			(exit 1)))))
	      keys)
    ;; (sqlite3:execute db "PRAGMA synchronous = OFF;")
    (db:set-sync db)

    (sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));")
    (for-each (lambda (key)
		(sqlite3:execute db "INSERT INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT"))
	      keys)
    (sqlite3:execute db (conc 
			 "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, " 
			 fieldstr (if havekeys "," "")
			 "runname TEXT,"
			 "state TEXT DEFAULT '',"
			 "status TEXT DEFAULT '',"
			 "owner TEXT DEFAULT '',"
			 "event_time TIMESTAMP,"
			 "comment TEXT DEFAULT '',"
			 "fail_count INTEGER DEFAULT 0,"
			 "pass_count INTEGER DEFAULT 0,"
			 "CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));"))
    (sqlite3:execute db (conc "CREATE INDEX runs_index ON runs (runname" (if havekeys "," "") keystr ");"))
    (sqlite3:execute db 
		     "CREATE TABLE IF NOT EXISTS tests 
                    (id INTEGER PRIMARY KEY,
                     run_id     INTEGER,
                     testname   TEXT,
                     host       TEXT DEFAULT 'n/a',
                     cpuload    REAL DEFAULT -1,
                     diskfree   INTEGER DEFAULT -1,
                     uname      TEXT DEFAULT 'n/a', 
                     rundir     TEXT DEFAULT 'n/a',
                     shortdir   TEXT DEFAULT '',
                     item_path  TEXT DEFAULT '',
                     state      TEXT DEFAULT 'NOT_STARTED',
                     status     TEXT DEFAULT 'FAIL',
                     attemptnum INTEGER DEFAULT 0,
                     final_logf TEXT DEFAULT 'logs/final.log',
                     logdat     BLOB, 
                     run_duration INTEGER DEFAULT 0,
                     comment    TEXT DEFAULT '',
                     event_time TIMESTAMP,
                     fail_count INTEGER DEFAULT 0,
                     pass_count INTEGER DEFAULT 0,
                     archived   INTEGER DEFAULT 0, -- 0=no, 1=in progress, 2=yes
                     CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path)
          );")
    (sqlite3:execute db "CREATE INDEX tests_index ON tests (run_id, testname, item_path);")
    (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;")
    (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps 
                              (id INTEGER PRIMARY KEY,
                               test_id INTEGER, 
                               stepname TEXT, 
                               state TEXT DEFAULT 'NOT_STARTED', 
                               status TEXT DEFAULT 'n/a',
                               event_time TIMESTAMP,
                               comment TEXT DEFAULT '',
                               logfile TEXT DEFAULT '',
                               CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));")
    (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);")
    (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT,
                                  CONSTRAINT metadat_constraint UNIQUE (var));")
    (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);")
    (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta (id INTEGER PRIMARY KEY,
                                     testname    TEXT DEFAULT '',
                                     author      TEXT DEFAULT '',
                                     owner       TEXT DEFAULT '',
                                     description TEXT DEFAULT '',
                                     reviewed    TIMESTAMP,
                                     iterated    TEXT DEFAULT '',
                                     avg_runtime REAL,
                                     avg_disk    REAL,
                                     tags        TEXT DEFAULT '',
                                     jobgroup    TEXT DEFAULT 'default',
                                CONSTRAINT test_meta_constraint UNIQUE (testname));")




































































































    (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY,
                                test_id INTEGER,
                                category TEXT DEFAULT '',
                                variable TEXT,
	                        value REAL,
	                        expected REAL,
	                        tol REAL,
                                units TEXT,
                                comment TEXT DEFAULT '',
                                status TEXT DEFAULT 'n/a',
                                type TEXT DEFAULT '',
                              CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));")
    ;; Must do this *after* running patch db !! No more. 
    (db:set-var db "MEGATEST_VERSION" megatest-version)
    (debug:print-info 11 "db:initialize END")
    ))

;;======================================================================
;; T E S T   S P E C I F I C   D B 
;;======================================================================





;; Create the sqlite db for the individual test(s)

(define (open-test-db work-area) 
  (debug:print-info 11 "open-test-db " work-area)
  (if (and work-area 
	   (directory? work-area)
	   (file-read-access? work-area))

      (let* ((dbpath    (conc work-area "/testdat.db"))
	     (tdb-writeable (file-write-access? dbpath))
	     (dbexists  (file-exists? dbpath))
	     (handler   (make-busy-timeout (if (args:get-arg "-override-timeout")
					       (string->number (args:get-arg "-override-timeout"))
					       136000))))
	(handle-exceptions
	 exn
	 (begin
	   (debug:print 2 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test"

			((condition-property-accessor 'exn 'message) exn))
	   (set! db (sqlite3:open-database ":memory:"))) ;; open an in-memory db to allow readonly access 
	 (set! db (sqlite3:open-database dbpath)))
	(if *db-write-access* (sqlite3:set-busy-handler! db handler))
	(if (not dbexists)

	    (begin
	      ;; Why use FULL here? This data is not that critical
	      ;; (sqlite3:execute db "PRAGMA synchronous = FULL;")
	      (debug:print-info 11 "Initialized test database " dbpath)
	      (db:testdb-initialize db)))


	;; (sqlite3:execute db "PRAGMA synchronous = 0;")
	(debug:print-info 11 "open-test-db END (sucessful)" work-area)
	;; now let's test that everything is correct
	(handle-exceptions
	 exn
	 (begin
	   (debug:print 0 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test"
			((condition-property-accessor 'exn 'message) exn))
	   #f)
	 ;; Is there a cheaper single line operation that will check for existance of a table
	 ;; and raise an exception ?
	 (sqlite3:execute db "SELECT id FROM test_data LIMIT 1;"))
	db)

































      (begin
	(debug:print-info 11 "open-test-db END (unsucessful)" work-area)
	#f)))












;; find and open the testdat.db file for an existing test




(define (db:open-test-db-by-test-id db test-id #!key (work-area #f))
  (let* ((test-path (if work-area

			work-area



			(cdb:remote-run db:test-get-rundir-from-test-id db test-id))))


    (debug:print 3 "TEST PATH: " test-path)




    (open-test-db test-path)))







(define (db:testdb-initialize db)



  (debug:print 11 "db:testdb-initialize START")

  (for-each

   (lambda (sqlcmd)
     (sqlite3:execute db sqlcmd))
   (list "CREATE TABLE IF NOT EXISTS test_rundat (
              id INTEGER PRIMARY KEY,
              update_time TIMESTAMP,
              cpuload INTEGER DEFAULT -1,
              diskfree INTEGER DEFAULT -1,
              diskusage INTGER DEFAULT -1,
              run_duration INTEGER DEFAULT 0);"
	 "CREATE TABLE IF NOT EXISTS test_data (
              id INTEGER PRIMARY KEY,
              test_id INTEGER,
              category TEXT DEFAULT '',
              variable TEXT,
	      value REAL,
	      expected REAL,
	      tol REAL,
              units TEXT,
              comment TEXT DEFAULT '',
              status TEXT DEFAULT 'n/a',
              type TEXT DEFAULT '',
              CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));"
	 "CREATE TABLE IF NOT EXISTS test_steps (
              id INTEGER PRIMARY KEY,
              test_id INTEGER, 


              stepname TEXT, 
              state TEXT DEFAULT 'NOT_STARTED', 
              status TEXT DEFAULT 'n/a',
              event_time TIMESTAMP,
              comment TEXT DEFAULT '',
              logfile TEXT DEFAULT '',
              CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));"
	 ;; test_meta can be used for handing commands to the test
	 ;; e.g. KILLREQ

	 ;;      the ackstate is set to 1 once the command has been completed
	 "CREATE TABLE IF NOT EXISTS test_meta (
              id INTEGER PRIMARY KEY,
              var TEXT,
              val TEXT,

              ackstate INTEGER DEFAULT 0,
              CONSTRAINT metadat_constraint UNIQUE (var));"))
  (debug:print 11 "db:testdb-initialize END"))



;;======================================================================
;; L O G G I N G    D B 
;;======================================================================

(define (open-logging-db) ;;  (conc *toppath* "/megatest.db") (car *configinfo*)))
  (let* ((dbpath    (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname)
	 (dbexists  (file-exists? dbpath))
	 (db        (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath))
	 (handler   (make-busy-timeout (if (args:get-arg "-override-timeout")
					   (string->number (args:get-arg "-override-timeout"))
					   136000)))) ;; 136000)))
    (sqlite3:set-busy-handler! db handler)
    (if (not dbexists)
	(begin
	  (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log (id INTEGER PRIMARY KEY,event_time TIMESTAMP DEFAULT (strftime('%s','now')),logline TEXT,pwd TEXT,cmdline TEXT,pid INTEGER);")
	  (sqlite3:execute db (conc "PRAGMA synchronous = 0;"))))

    db))

(define (db:log-local-event . loglst)
  (let ((logline (apply conc loglst)))
    ;; (pwd     (current-directory))
    ;; (cmdline (string-intersperse (argv) " "))
    ;; (pid     (current-process-id)))
    (db:log-event logline)))

(define (db:log-event logline)
  (let ((db (open-logging-db)))
    (sqlite3:execute db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);"
		     logline
		     (current-directory)
		     (string-intersperse (argv) " ")
		     (current-process-id))
    (sqlite3:finalize! db)
    logline))

;;======================================================================
;; TODO:
;;   put deltas into an assoc list with version numbers
;;   apply all from last to current
;;======================================================================
(define (patch-db db)
  (handle-exceptions
   exn
   (begin
     (print "Exception: " exn)
     (print "ERROR: Possible out of date schema, attempting to add table metadata...")
     (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER, var TEXT, val TEXT,
                                 CONSTRAINT metadat_constraint UNIQUE (var));")
     (if (not (db:get-var db "MEGATEST_VERSION"))
	 (db:set-var db "MEGATEST_VERSION" 1.17)))
   (let ((mver (db:get-var db "MEGATEST_VERSION"))
	 (test-meta-def "CREATE TABLE IF NOT EXISTS test_meta (id INTEGER PRIMARY KEY,
                                     testname    TEXT DEFAULT '',
                                     author      TEXT DEFAULT '',
                                     owner       TEXT DEFAULT '',
                                     description TEXT DEFAULT '',
                                     reviewed    TIMESTAMP,
                                     iterated    TEXT DEFAULT '',
                                     avg_runtime REAL,
                                     avg_disk    REAL,
                                     tags        TEXT DEFAULT '',
                                CONSTRAINT test_meta_constraint UNIQUE (testname));"))
     (print "Current schema version: " mver " current megatest version: " megatest-version)
     (cond
      ((not mver)
       (print "Adding megatest-version to metadata") ;; Need to recreate the table
       (sqlite3:execute db "DROP TABLE IF EXISTS metadat;")
       (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER, var TEXT, val TEXT,
                                  CONSTRAINT metadat_constraint UNIQUE (var));")
       (db:set-var db "MEGATEST_VERSION" 1.17)
       (patch-db))
      ((< mver 1.21)
       (sqlite3:execute db "DROP TABLE IF EXISTS metadat;")
       (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER, var TEXT, val TEXT,
                                  CONSTRAINT metadat_constraint UNIQUE (var));")
       (db:set-var db "MEGATEST_VERSION" 1.21) ;; set before, just in case the changes are already applied
       (sqlite3:execute db test-meta-def)
					;(for-each 
					; (lambda (stmt)
					;   (sqlite3:execute db stmt))
					; (list 
					;  "ALTER TABLE tests ADD COLUMN first_err TEXT;"
					;  "ALTER TABLE tests ADD COLUMN first_warn TEXT;"
					;  ))
       (patch-db))
      ((< mver 1.24)
       (db:set-var db "MEGATEST_VERSION" 1.24)
       (sqlite3:execute db "DROP TABLE IF EXISTS test_data;")
       (sqlite3:execute db "DROP TABLE IF EXISTS test_meta;")
       (sqlite3:execute db test-meta-def)
       (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY,
                                test_id INTEGER,
                                category TEXT DEFAULT '',
                                variable TEXT,
	                        value REAL,
	                        expected REAL,
	                        tol REAL,
                                units TEXT,
                                comment TEXT DEFAULT '',
                                status TEXT DEFAULT 'n/a',
                              CONSTRAINT test_data UNIQUE (test_id,category,variable));")
       (print "WARNING: Table test_data and test_meta were recreated. Please do megatest -update-meta")
       (patch-db))
      ((< mver 1.27)
       (db:set-var db "MEGATEST_VERSION" 1.27)
       (sqlite3:execute db "ALTER TABLE test_data ADD COLUMN type TEXT DEFAULT '';")
       (patch-db))
      ((< mver 1.29)
       (db:set-var db "MEGATEST_VERSION" 1.29)
       (sqlite3:execute db "ALTER TABLE test_steps ADD COLUMN logfile TEXT DEFAULT '';")
       (sqlite3:execute db "ALTER TABLE tests ADD COLUMN shortdir TEXT DEFAULT '';"))
      ((< mver 1.36)
       (db:set-var db "MEGATEST_VERSION" 1.36)
       (sqlite3:execute db "ALTER TABLE test_meta ADD COLUMN jobgroup TEXT DEFAULT 'default';"))
      ((< mver 1.37)
       (db:set-var db "MEGATEST_VERSION" 1.37)
       (sqlite3:execute db "ALTER TABLE tests ADD COLUMN archived INTEGER DEFAULT 0;")) 
      ((< mver megatest-version)
       (db:set-var db "MEGATEST_VERSION" megatest-version))))))

;;======================================================================
;; M A I N T E N A N C E
;;======================================================================























































;;  select end_time-now from
;;      (select testname,item_path,event_time+run_duration as
;;                          end_time,strftime('%s','now') as now from tests where state in
;;      ('RUNNING','REMOTEHOSTSTART','LAUNCED'));

(define (db:find-and-mark-incomplete db #!key (ovr-deadtime #f))


  (let* ((incompleted '())
	 (oldlaunched '())
	 (toplevels   '())
	 (deadtime-str (configf:lookup *configdat* "setup" "deadtime"))
	 (deadtime     (if (and deadtime-str
				(string->number deadtime-str))
			   (string->number deadtime-str)
			   7200)) ;; two hours
	 (run-ids      (db:get-run-ids db))) ;; iterate over runs to divy up the calls
    (if (number? ovr-deadtime)(set! deadtime ovr-deadtime))
    (for-each
     (lambda (run-id)

       ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes
       ;;
       ;; THIS CANNOT WORK. The run_duration is not updated in the central db due to performance concerns.
       ;;                   The testdat.db file must be consulted.
       ;;
       ;; HOWEVER: this code in run:test seems to work fine
       ;;              (> (- (current-seconds)(+ (db:test-get-event_time testdat)
       ;;                     (db:test-get-run_duration testdat)))
       ;;                    600) 
       (db:delay-if-busy)
       (sqlite3:for-each-row 
	(lambda (test-id run-dir uname testname item-path)
	  (if (and (equal? uname "n/a")
		   (equal? item-path "")) ;; this is a toplevel test
	      ;; what to do with toplevel? call rollup?
	      (begin
		(set! toplevels   (cons (list test-id run-dir uname testname item-path run-id) toplevels))
		(debug:print-info 0 "Found old toplevel test in RUNNING state, test-id=" test-id))
	      (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted))))
	db
	"SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 600 AND state IN ('RUNNING','REMOTEHOSTSTART');"
	run-id)

       ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config
       ;;
       (db:delay-if-busy)
       (sqlite3:for-each-row
	(lambda (test-id run-dir uname testname item-path)
	  (if (and (equal? uname "n/a")
		   (equal? item-path "")) ;; this is a toplevel test
	      ;; what to do with toplevel? call rollup?
	      (set! toplevels   (cons (list test-id run-dir uname testname item-path run-id) toplevels))
	      (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched))))
	db
	"SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');"
	run-id))
     run-ids)

    
    ;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE.
    ;;
    (db:delay-if-busy)
    (let* ((min-incompleted (filter (lambda (x)
				     (let* ((testpath (cadr x))
					    (tdatpath (conc testpath "/testdat.db"))
					    (dbexists (file-exists? tdatpath)))
				       (or (not dbexists) ;; if no file then something wrong - mark as incomplete
					   (> (- (current-seconds)(file-modification-time tdatpath)) 600)))) ;; no change in 10 minutes to testdat.db - she's dead Jim
				   incompleted))
	  (min-incompleted-ids (map car min-incompleted))
	  (all-ids             (append min-incompleted-ids (map car oldlaunched))))
      (if (> (length all-ids) 0)
	  (begin
	    (debug:print 0 "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") " as INCOMPLETE")
	    (sqlite3:execute 
	     db
	     (conc "UPDATE tests SET state='INCOMPLETE' WHERE id IN (" 
		   (string-intersperse (map conc all-ids) ",")
		   ");")))))

    ;; Now do rollups for the toplevel tests
    ;;

    (for-each
     (lambda (toptest)
       (let ((test-name (list-ref toptest 3))
	     (run-id    (list-ref toptest 5)))
	 (cdb:top-test-set-per-pf-counts *runremote* run-id test-name)))
     toplevels)))
		     
;; Clean out old junk and vacuum the database
;;
;; Ultimately do something like this:
;;
;; 1. Look at test records either deleted or part of deleted run:
;;    a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown'
;;    b. If test dir gone, delete the test record
;; 2. Look at run records
;;    a. If have tests that are not deleted, set state='unknown'
;;    b. ....
;;
(define (db:clean-up db)


  (let ((count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);"))
	(statements
	 (map (lambda (stmt)
		(sqlite3:prepare db stmt))
	      (list
	       ;; delete all tests that belong to runs that are 'deleted'
	       "DELETE FROM tests WHERE run_id in (SELECT id FROM runs WHERE state='deleted');"
	       ;; delete all tests that are 'DELETED'
	       "DELETE FROM tests WHERE state='DELETED';"
	       ;; delete all tests that have no run
	       "DELETE FROM tests WHERE run_id NOT IN (SELECT DISTINCT id FROM runs);"
	       ;; delete all runs that are state='deleted'
	       "DELETE FROM runs WHERE state='deleted';"
	       ;; delete empty runs
	       "DELETE FROM runs WHERE id NOT IN (SELECT DISTINCT r.id FROM runs AS r INNER JOIN tests AS t ON t.run_id=r.id);"
	       ))))

























































































    (sqlite3:with-transaction 
     db
     (lambda ()
       (sqlite3:for-each-row (lambda (tot)
			       (debug:print-info 0 "Records count before clean: " tot))
			     count-stmt)
       (map sqlite3:execute statements)
       (sqlite3:for-each-row (lambda (tot)
			       (debug:print-info 0 "Records count after  clean: " tot))
			     count-stmt)))
    (map sqlite3:finalize! statements)
    (sqlite3:finalize! count-stmt)
    (db:find-and-mark-incomplete db)

    (sqlite3:execute db "VACUUM;")))


;;======================================================================
;; meta get and set vars

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

;; returns number if string->number is successful, string otherwise
;; also updates *global-delta*



(define (db:get-var db var)
  (debug:print-info 11 "db:get-var START " var)
  (let* ((start-ms (current-milliseconds))
         (throttle (let ((t  (config-lookup *configdat* "setup" "throttle")))
		     (if t (string->number t) t)))
	 (res      #f))



    (sqlite3:for-each-row
     (lambda (val)
       (set! res val))

     db "SELECT val FROM metadat WHERE var=?;" var)
    ;; convert to number if can
    (if (string? res)
	(let ((valnum (string->number res)))
	  (if valnum (set! res valnum))))
    ;; scale by 10, average with current value.
    (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms)
						 (if throttle throttle 0.01)))
			    2))
    (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit
	(begin
	  (debug:print-info 4 "launch throttle factor=" *global-delta*)
	  (set! *last-global-delta-printed* *global-delta*)))
    (debug:print-info 11 "db:get-var END " var " val=" res)
    res))

(define (db:set-var db var val)

  (debug:print-info 11 "db:set-var START " var " " val)
  (db:delay-if-busy)
  (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val)
  (debug:print-info 11 "db:set-var END " var " " val))

(define (db:del-var db var)
  (debug:print-info 11 "db:del-var START " var)
  (db:delay-if-busy)


  (sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var)
  (debug:print-info 11 "db:del-var END " var))

;; use a global for some primitive caching, it is just silly to
;; re-read the db over and over again for the keys since they never
;; change

;; why get the keys from the db? why not get from the *configdat*
;; using keys:config-get-fields?

(define (db:get-keys db)
  (if *db-keys* *db-keys* 
      (let ((res '()))


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

;; 
(define (db:get-value-by-header row header field)
  (debug:print-info 4 "db:get-value-by-header row: " row " header: " header " field: " field)
  (if (null? header) #f
      (let loop ((hed (car header))
		 (tal (cdr header))
		 (n   0))
	(if (equal? hed field)
	    (vector-ref row n)
	    (if (null? tal) #f (loop (car tal)(cdr tal)(+ n 1)))))))






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

(define (db:get-run-name-from-id db run-id)





  (let ((res #f))
    (sqlite3:for-each-row
     (lambda (runname)
       (set! res runname))
     db
     "SELECT runname FROM runs WHERE id=?;"
     run-id)
    res))

(define (db:get-run-key-val db run-id key)





  (let ((res #f))
    (sqlite3:for-each-row
     (lambda (val)
       (set! res val))
     db 
     (conc "SELECT " key " FROM runs WHERE id=?;")
     run-id)
    res))

;; keys list to key1,key2,key3 ...
(define (runs:get-std-run-fields keys remfields)
  (let* ((header    (append keys remfields))
	 (keystr    (conc (keys->keystr keys) ","
			  (string-intersperse remfields ","))))
    (list keystr header)))







|
<
<
|



<
<
<




<








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

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

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

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






|
>
|
|
|
|


|

















|





|

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

|
<




|
>






|
<


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











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











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

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

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








|







|
>




<
<
<













|
<
<

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





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





|
>
>
|






|
<

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

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


|
|
|
|
|
|
|
|
|
|











>


|
|
|













|
>
>
|















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












|
>
|
>


<
>




>
>
>
|
<



|
>
>
>



>
|












<


|
>
|
|
|
<

|
<
|
>
>
|
<








|


>
>
|
|
|
|
|



|

<








>
>
>
>
>




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

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







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

;;======================================================================
;; 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 format dot-locking z3)
(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 *rundb-mutex* (make-mutex)) ;; prevent problems opening/closing rundb's
(define *number-of-writes* 0)
(define *number-non-write-queries* 0)

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

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

;; Get/open a database
;;    if run-id => get run specific db
;;    if #f     => get main db
;;    if db already open - return inmem
;;    if db not open, open inmem, rundb and sync then return inmem
;;    inuse gets set automatically for rundb's
;;
(define (db:get-db dbstruct run-id)
  (if (sqlite3:database? dbstruct) ;; pass sqlite3 databases on through
      dbstruct
      (begin
	(mutex-lock! *rundb-mutex*)
	(let ((dbdat (if (or (not run-id)
			     (eq? run-id 0))
			 (db:open-main dbstruct)
			 (db:open-rundb dbstruct run-id)
			 )))
	  ;; db prunning would go here
	  (mutex-unlock! *rundb-mutex*)
	  dbdat))))

(define (db:dbdat-get-db dbdat)
  (if (pair? dbdat)
      (car dbdat)
      dbdat))

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

;; mod-read:
;;     'mod   modified data
;;     'read  read data
;;
(define (db:done-with dbstruct run-id mod-read)
  (if (not (sqlite3:database? dbstruct))
      (begin
	(mutex-lock! *rundb-mutex*)
	(if (eq? mod-read 'mod)
	    (dbr:dbstruct-set-mtime! dbstruct (current-milliseconds))
	    (dbr:dbstruct-set-rtime! dbstruct (current-milliseconds)))
	(dbr:dbstruct-set-inuse! dbstruct #f)
	(mutex-unlock! *rundb-mutex*))))

;; (db:with-db dbstruct run-id sqlite3:exec "select blah from blaz;")
;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no
;;
(define (db:with-db dbstruct run-id r/w proc . params)
  (let* ((dbdat (if (vector? dbstruct)
		    (db:get-db dbstruct run-id)
		    dbstruct)) ;; cheat, allow for passing in a dbdat
	 (db    (db:dbdat-get-db dbdat)))
    (db:delay-if-busy dbdat)
    (handle-exceptions
     exn
     (begin
       (debug:print 0 "ERROR: sqlite3 issue in db:with-db, dbstruct=" dbstruct ", run-id=" run-id ", proc=" proc ", params=" params " error: " ((condition-property-accessor 'exn 'message) exn))
       (print-call-chain (current-error-port)))
     (let ((res (apply proc db params)))
       (if (vector? dbstruct)(db:done-with dbstruct run-id r/w))
       res))))

;;======================================================================
;; K E E P   F I L E D B   I N   dbstruct
;;======================================================================

;; (define (db:get-filedb dbstruct run-id)
;;   (let ((db (vector-ref dbstruct 2)))
;;     (if db
;; 	db
;; 	(let ((fdb (filedb:open-db (conc *toplevel* "/db/files.db"))))
;; 	  (vector-set! dbstruct 2 fdb)
;; 	  fdb))))
;; 
;; ;; Can also be used to save arbitrary strings
;; ;;
;; (define (db:save-path dbstruct path)
;;   (let ((fdb (db:get-filedb dbstruct)))b
;;     (filedb:register-path fdb path)))
;; 
;; ;; Use to get a path. To get an arbitrary string see next define
;; ;;
;; (define (db:get-path dbstruct id)
;;   (let ((fdb (db:get-filedb dbstruct)))
;;     (filedb:get-path db id)))

;; NB// #f => return dbdir only
;;      (was planned to be;  zeroth db with name=main.db)
;;
(define (db:dbfile-path run-id)
  (let* (;; (toppath      (dbr:dbstruct-get-path  dbstruct))
	 (link-tree-path  (configf:lookup *configdat* "setup" "linktree"))
	 (dbpath          (configf:lookup *configdat* "setup" "dbdir"))
	 (fname           (if run-id
			      (if (eq? run-id 0) "main.db" (conc run-id ".db"))
			      #f))
	 (dbdir           (if dbpath
			      dbpath
			      (conc link-tree-path "/.db/"))))
    (handle-exceptions
     exn
     (begin
       (debug:print 0 "ERROR: Couldn't create path to " dbdir)
       (exit 1))
     (if (not (directory? dbdir))(create-directory dbdir #t)))
    (if fname
	(conc dbdir fname)
	dbdir)))
	       
(define (db:set-sync db)
  (let ((syncprag (configf:lookup *configdat* "setup" "sychronous")))
    (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 1) ";"))))

;; open an sql database inside a file lock
;;
;; returns: db existed-prior-to-opening
;;
(define (db:lock-create-open fname initproc)
  (if (file-exists? fname)
      (let ((db (sqlite3:open-database fname)))
	(sqlite3:set-busy-handler! db (make-busy-timeout 136000))
	(db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;")
	db)
      (let* ((parent-dir   (pathname-directory fname))
	     (dir-writable (file-write-access? parent-dir)))
	(if dir-writable
	    (let ((exists  (file-exists? fname))
		  (lock    (obtain-dot-lock fname 1 5 10))
		  (db      (sqlite3:open-database fname)))
	      (sqlite3:set-busy-handler! db (make-busy-timeout 136000))
	      (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;")
	      (if (not exists)(initproc db))



	      (release-dot-lock fname)
	      db)
	    (begin
	      (debug:print 0 "ERROR: no such db in non-writable dir " fname)
	      (sqlite3:open-database fname))))))

;; This routine creates the db. It is only called if the db is not already opened
;; 
(define (db:open-rundb dbstruct run-id #!key (attemptnum 0)(do-not-open #f)) ;;  (conc *toppath* "/megatest.db") (car *configinfo*)))
  (let* ((local  (dbr:dbstruct-get-local dbstruct))
	 (rdb    (if local
		     (dbr:dbstruct-get-localdb dbstruct run-id)
		     (dbr:dbstruct-get-inmem dbstruct)))) ;; (dbr:dbstruct-get-runrec dbstruct run-id 'inmem)))
    (if (or rdb
	    do-not-open)
	rdb
	(let* ((dbpath       (db:dbfile-path run-id)) ;; (conc toppath "/db/" run-id ".db"))
	       (dbexists     (file-exists? dbpath))
	       (inmem        (if local #f (db:open-inmem-db)))
	       (refdb        (if local #f (db:open-inmem-db)))
	       (db           (db:lock-create-open dbpath ;; this is the database physically on disk
						  (lambda (db)
						    (handle-exceptions
						     exn
						     (begin
						       (release-dot-lock dbpath)
						       (if (> attemptnum 2)
							   (debug:print 0 "ERROR: tried twice, cannot create/initialize db for run-id " run-id ", at path " dbpath)
							   (db:open-rundb dbstruct run-id attemptnum (+ attemptnum 1))))
						     (db:initialize-run-id-db db)
						     (sqlite3:execute 
						      db
						      "INSERT OR IGNORE INTO tests (id,run_id,testname,event_time,item_path,state,status) VALUES (?,?,'bogustest',strftime('%s','now'),'nowherepath','DELETED','n/a');"
						      (* run-id 30000) ;; allow for up to 30k tests per run
						      run-id)
						     ;; do a dummy query to test that the table exists and the db is truly readable
						     (sqlite3:execute db "SELECT * FROM tests WHERE id=?;" (* run-id 30000))
						    )))) ;; add strings db to rundb, not in use yet
	       ;;   )) ;; (sqlite3:open-database dbpath))
	       (olddb        (if *megatest-db*
				 *megatest-db* 
				 (let ((db (db:open-megatest-db)))
				   (set! *megatest-db* db)
				   db)))
	       (write-access (file-write-access? dbpath))
	       ;; (handler      (make-busy-timeout 136000))
	       )

	  (if (and dbexists (not write-access))
	      (set! *db-write-access* #f)) ;; only unset so other db's also can use this control
	  (dbr:dbstruct-set-rundb!  dbstruct (cons db dbpath))
	  (dbr:dbstruct-set-inuse!  dbstruct #t)
	  (dbr:dbstruct-set-olddb!  dbstruct olddb)
	  ;; (dbr:dbstruct-set-run-id! dbstruct run-id)
	  (if local
	      (begin
		(dbr:dbstruct-set-localdb! dbstruct run-id db) ;; (dbr:dbstruct-set-inmem! dbstruct db) ;; direct access ...
		db)
	      (begin
		(dbr:dbstruct-set-inmem!  dbstruct inmem)
		;; dec 14, 2014 - keep deleted records available. hunch is that they are needed for id placeholders
		;; (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';") ;; they just slow us down in this context
		(db:sync-tables db:sync-tests-only db inmem)
		(db:delay-if-busy refdb) ;; dbpath: (db:dbdat-get-path refdb)) ;; What does delaying here achieve? 
		(dbr:dbstruct-set-refdb!  dbstruct refdb)
		(db:sync-tables db:sync-tests-only inmem refdb) ;; use inmem as the reference, don't read again from db
		;; sync once more to deal with delays?
		;; (db:sync-tables db:sync-tests-only db inmem)
		;; (db:sync-tables db:sync-tests-only inmem refdb)
		inmem))))))

;; This routine creates the db. It is only called if the db is not already ls opened
;;
(define (db:open-main dbstruct) ;;  (conc *toppath* "/megatest.db") (car *configinfo*)))
  (let ((mdb (dbr:dbstruct-get-main dbstruct)))
    (if mdb
	mdb
	(let* ((dbpath       (db:dbfile-path 0))
	       (dbexists     (file-exists? dbpath))
	       (db           (db:lock-create-open dbpath db:initialize-main-db))
	       (olddb        (db:open-megatest-db))
	       (write-access (file-write-access? dbpath))
	       (dbdat        (cons db dbpath)))
	  (if (and dbexists (not write-access))
	      (set! *db-write-access* #f))
	  (dbr:dbstruct-set-main!   dbstruct dbdat)
	  (dbr:dbstruct-set-olddb!  dbstruct olddb) ;; olddb is already a (cons db path)
	  dbdat))))

;; Make the dbstruct, setup up auxillary db's and call for main db at least once
;;
(define (db:setup run-id #!key (local #f))
  (let* ((dbdir    (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
	 (dbstruct (make-dbr:dbstruct path: dbdir local: local)))
    dbstruct))

;; Open the classic megatest.db file in toppath
;;
(define (db:open-megatest-db)
  (let* ((dbpath       (conc *toppath* "/megatest.db"))
	 (dbexists     (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)))
    (if (and dbexists (not write-access))
	(set! *db-write-access* #f))
    (cons db dbpath)))

;; sync run to disk if touched
;;
(define (db:sync-touched dbstruct run-id #!key (force-sync #f))
  (let ((mtime  (dbr:dbstruct-get-mtime dbstruct))
	(stime  (dbr:dbstruct-get-stime dbstruct))
	(rundb  (dbr:dbstruct-get-rundb dbstruct))
	(inmem  (dbr:dbstruct-get-inmem dbstruct))
	(maindb (dbr:dbstruct-get-main  dbstruct))
	(refdb  (dbr:dbstruct-get-refdb dbstruct))
	(olddb  (dbr:dbstruct-get-olddb dbstruct))
	;; (runid  (dbr:dbstruct-get-run-id dbstruct))
	)
    (debug:print-info 4 "Syncing for run-id: " run-id)
    ;; (mutex-lock! *http-mutex*)
    (if (eq? run-id 0)
	;; runid equal to 0 is main.db
	(if maindb
	    (if (or (not (number? mtime))
		    (not (number? stime))
		    (> mtime stime)
		    force-sync)
		(begin
		  (db:delay-if-busy maindb)
		  (db:delay-if-busy olddb)
		  (let ((num-synced (db:sync-tables (db:sync-main-list maindb) maindb olddb)))
		    (dbr:dbstruct-set-stime! dbstruct (current-milliseconds))
		    num-synced)
		  0))
	    (begin
	      ;; this can occur when using local access (i.e. not in a server)
	      ;; need a flag to turn it off.
	      ;;
	      (debug:print 3 "WARNING: call to sync main.db to megatest.db but main not initialized")
	      0))
	;; any other runid is a run
	(if (or (not (number? mtime))
		(not (number? stime))
		(> mtime stime)
		force-sync)
	    (begin
	      (db:delay-if-busy rundb)
	      (db:delay-if-busy olddb)
	      (dbr:dbstruct-set-stime! dbstruct (current-milliseconds))
	      (let ((num-synced (db:sync-tables db:sync-tests-only inmem refdb rundb olddb)))
		;; (mutex-unlock! *http-mutex*)
		num-synced)
	      (begin
		;; (mutex-unlock! *http-mutex*)
		0))))))

(define (db:close-main dbstruct)
  (let ((maindb (dbr:dbstruct-get-main dbstruct)))
    (if maindb
	(begin
	  (sqlite3:finalize! (db:dbdat-get-db maindb))
	  (dbr:dbstruct-set-main! dbstruct #f)))))

(define (db:close-run-db dbstruct run-id)
  (let ((rdb (db:open-rundb dbstruct run-id do-not-open: #t)))
    (if (and rdb
	     (sqlite3:database? rdb))
	(begin
	  (sqlite3:finalize! rdb)
	  (dbr:dbstruct-set-localdb! dbstruct run-id #f)
	  (dbr:dbstruct-set-inmem! dbstruct #f)))))

;; close all opened run-id dbs
(define (db:close-all dbstruct)
  ;; finalize main.db
  (db:sync-touched dbstruct 0 force-sync: #t)
  ;;(common:db-block-further-queries)
  ;; (mutex-lock! *db-sync-mutex*) ;; with this perhaps it isn't necessary to use the block-further-queries mechanism?

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

  ;; (let* ((local (dbr:dbstruct-get-local dbstruct))
  ;;        (rundb (db:dbdat-get-db (dbr:dbstruct-get-rundb dbstruct))))
  ;;   (if local
  ;;       (for-each
  ;;        (lambda (dbdat)
  ;;          (let ((db (db:dbdat-get-db dbdat)))
  ;;            (if (sqlite3:database? db)
  ;;       	 (begin
  ;;       	   (sqlite3:interrupt! db)
  ;;       	   (sqlite3:finalize! db #t)))))
  ;;        ;; TODO: Come back to this and rework to delete from hashtable when finalized
  ;;        (hash-table-values (dbr:dbstruct-get-locdbs dbstruct))))
  ;;   (thread-sleep! 3)
  ;;   (if (and rundb
  ;;            (sqlite3:database? rundb))
  ;;       (handle-exceptions
  ;;        exn
  ;;        (begin 
  ;;          (debug:print 0 "WARNING: database files may not have been closed correctly. Consider running -cleanup-db")
  ;;          (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
  ;;          (debug:print 0 " db: " rundb)
  ;;          (print-call-chain (current-error-port))
  ;;          #f)
  ;;        (sqlite3:interrupt! rundb)
  ;;        (sqlite3:finalize! rundb #t))))
  ;; ;; (mutex-unlock! *db-sync-mutex*)
  )

(define (db:open-inmem-db)
  (let* ((db      (sqlite3:open-database ":memory:"))
	 (handler (make-busy-timeout 3600)))
    (sqlite3:set-busy-handler! db handler)
    (db:initialize-run-id-db db)
    (cons db #f)))

;; just tests, test_steps and test_data tables
(define db:sync-tests-only
  (list
   ;; (list "strs"
   ;;       '("id"             #f)
   ;;       '("str"            #f))
   (list "tests" 
	 '("id"             #f)
	 '("run_id"         #f)
	 '("testname"       #f)
	 '("host"           #f)
	 '("cpuload"        #f)
	 '("diskfree"       #f)
	 '("uname"          #f)
	 '("rundir"         #f)
	 '("shortdir"       #f)
	 '("item_path"      #f)
	 '("state"          #f)
	 '("status"         #f)
	 '("attemptnum"     #f)
	 '("final_logf"     #f)
	 '("logdat"         #f)
	 '("run_duration"   #f)
	 '("comment"        #f)
	 '("event_time"     #f)
	 '("fail_count"     #f)
	 '("pass_count"     #f)
	 '("archived"       #f))
  (list "test_steps"
	 '("id"             #f)
	 '("test_id"        #f)
	 '("stepname"       #f)
	 '("state"          #f)
	 '("status"         #f)
	 '("event_time"     #f)
	 '("comment"        #f)
	 '("logfile"        #f))
   (list "test_data"
	 '("id"             #f)
	 '("test_id"        #f)
	 '("category"       #f)
	 '("variable"       #f)
	 '("value"          #f)
	 '("expected"       #f)
	 '("tol"            #f)
	 '("units"          #f)
	 '("comment"        #f)
	 '("status"         #f)
	 '("type"           #f))))

;; needs db to get keys, this is for syncing all tables
;;
(define (db:sync-main-list db)
  (let ((keys  (db:get-keys db)))
    (list
     (list "keys"
	   '("id"        #f)
	   '("fieldname" #f)
	   '("fieldtype" #f))
     (list "metadat" '("var" #f) '("val" #f))
     (append (list "runs" 
		   '("id"  #f))
	     (map (lambda (k)(list k #f))
		  (append keys
			  (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count"))))
     (list "test_meta"
	   '("id"             #f)
	   '("testname"       #f)
	   '("owner"          #f)
	   '("description"    #f)
	   '("reviewed"       #f)
	   '("iterated"       #f)
	   '("avg_runtime"    #f)
	   '("avg_disk"       #f)
	   '("tags"           #f)
	   '("jobgroup"       #f)))))
    
;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) )
;; db's are dbdat's
;;
(define (db:sync-tables tbls fromdb todb . slave-dbs)
  (mutex-lock! *db-sync-mutex*)
  (handle-exceptions
   exn
   (begin
     (debug:print 0 "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.")
     (print-call-chain (current-error-port))
     (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
     (print "exn=" (condition->list exn))
     (debug:print 0 " status:  " ((condition-property-accessor 'sqlite3 'status) exn))
     (debug:print 0 " src db:  " (db:dbdat-get-path fromdb))
     (for-each (lambda (dbdat)
		 (debug:print 0 " dbpath:  " (db:dbdat-get-path dbdat)))
	       (cons todb slave-dbs))
     (if *server-run* ;; we are inside a server, throw a sync-failed error
	 (signal (make-composite-condition
		 (make-property-condition 'sync-failed 'message "db:sync-tables failed in a server context.")))))

	 ;; (set! *time-to-exit* #t) ;; let watch dog know that it is time to die.
	 ;; (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "shutting-down")
	 ;; (portlogger:open-run-close portlogger:set-port port "released")
	 ;; (exit 1)))
   (cond
    ((not fromdb) (debug:print 3 "WARNING: db:sync-tables called with fromdb missing") -1)
    ((not todb)   (debug:print 3 "WARNING: db:sync-tables called with todb missing") -2)
    ((not (sqlite3:database? (db:dbdat-get-db fromdb)))
     (debug:print 0 "ERROR: db:sync-tables called with fromdb not a database " fromdb) -3)
    ((not (sqlite3:database? (db:dbdat-get-db todb)))
     (debug:print 0 "ERROR: db:sync-tables called with todb not a database " todb) -4)
    (else
     (let ((stmts       (make-hash-table)) ;; table-field => stmt
	   (all-stmts   '())              ;; ( ( stmt1 value1 ) ( stml2 value2 ))
	   (numrecs     (make-hash-table))
	   (start-time  (current-milliseconds))
	   (tot-count   0))
       (for-each ;; table
	(lambda (tabledat)
	  (let* ((tablename  (car tabledat))
		 (fields     (cdr tabledat))
		 (num-fields (length fields))
		 (field->num (make-hash-table))
		 (num->field (apply vector (map car fields)))
		 (full-sel   (conc "SELECT " (string-intersperse (map car fields) ",") 
				   " FROM " tablename ";"))
		 (full-ins   (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) "
				   " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );"))
		 (fromdat    '())
		 (fromdats   '())
		 (totrecords 0)
		 (batch-len  (string->number (or (configf:lookup *configdat* "sync" "batchsize") "10")))
		 (todat      (make-hash-table))
		 (count      0))

	    ;; set up the field->num table
	    (for-each
	     (lambda (field)
	       (hash-table-set! field->num field count)
	       (set! count (+ count 1)))
	     fields)

	    ;; read the source table
	    (sqlite3:for-each-row
	     (lambda (a . b)
	       (set! fromdat (cons (apply vector a b) fromdat))
	       (if (> (length fromdat) batch-len)
		   (begin
		     (set! fromdats (cons fromdat fromdats))
		     (set! fromdat  '())
		     (set! totrecords (+ totrecords 1)))))
	     (db:dbdat-get-db fromdb)
	     full-sel)
	    
	    ;; tack on remaining records in fromdat
	    (if (not (null? fromdat))
		(set! fromdats (cons fromdat fromdats)))

	    (debug:print-info 2 "found " totrecords " records to sync")

	    ;; read the target table
	    (sqlite3:for-each-row
	     (lambda (a . b)
	       (hash-table-set! todat a (apply vector a b)))
	     (db:dbdat-get-db todb)
	     full-sel)

	    ;; first pass implementation, just insert all changed rows
	    (for-each 
	     (lambda (targdb)
	       (let* ((db     (db:dbdat-get-db targdb))
		      (stmth  (sqlite3:prepare db full-ins)))
		 ;; (db:delay-if-busy targdb) ;; NO WAITING
		 (for-each
		  (lambda (fromdat-lst)
		    (sqlite3:with-transaction
		     db
		     (lambda ()
		       (for-each ;; 
			(lambda (fromrow)
			  (let* ((a    (vector-ref fromrow 0))
				 (curr (hash-table-ref/default todat a #f))
				 (same #t))
			    (let loop ((i 0))
			      (if (or (not curr)
				      (not (equal? (vector-ref fromrow i)(vector-ref curr i))))
				  (set! same #f))
			      (if (and same
				       (< i (- num-fields 1)))
				  (loop (+ i 1))))
			    (if (not same)
				(begin
				  (apply sqlite3:execute stmth (vector->list fromrow))
				  (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0)))))))
			fromdat-lst))
		  ))
		  fromdats)
		 (sqlite3:finalize! stmth)))
	     (append (list todb) slave-dbs))))
	tbls)
       (let* ((runtime      (- (current-milliseconds) start-time))
	      (should-print (common:low-noise-print 30 "db sync" (> runtime 500)))) ;; low and high sync times treated as separate.
	 (if should-print (debug:print 0 "INFO: db sync, total run time " runtime " ms"))
	 (for-each 
	  (lambda (dat)
	    (let ((tblname (car dat))
		  (count   (cdr dat)))
	      (set! tot-count (+ tot-count count))
	      (if (> count 0)
		  (if should-print (debug:print 0 (format #f "    ~10a ~5a" tblname count))))))
	  (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b))))))
       tot-count)))
   (mutex-unlock! *db-sync-mutex*)))

;; options:
;;
;;  'killservers  - kills all servers
;;  'dejunk       - removes junk records
;;  'adj-testids  - move test-ids into correct ranges
;;  'old2new      - sync megatest.db records to .db/{main,1,2 ...}.db
;;  'new2old      - sync .db/{main,1,2,3 ...}.db to megatest.db
;;  'closeall     - close all opened dbs
;;
;;  run-ids: '(1 2 3 ...) or #f (for all)
;;
(define (db:multi-db-sync run-ids . options)
  (let* ((toppath  (launch:setup-for-run))
	 (dbstruct (if toppath (make-dbr:dbstruct path: toppath) #f))
	 (mtdb     (if toppath (db:open-megatest-db)))
	 (allow-cleanup (if run-ids #f #t))
	 (run-ids  (if run-ids 
		       run-ids
		       (if toppath (begin
				     (db:delay-if-busy mtdb)
				     (db:get-all-run-ids mtdb)))))
	 (tdbdat  (tasks:open-db))
	 (servers (tasks:get-all-servers (db:delay-if-busy tdbdat))))
    
    ;; kill servers
    (if (member 'killservers options)
	(for-each
	 (lambda (server)
	   (tasks:server-delete-record (db:delay-if-busy tdbdat) (vector-ref server 0) "dbmigration")
	   (tasks:kill-server (vector-ref server 2)(vector-ref server 1)))
	 servers))

    ;; clear out junk records
    ;;
    (if (member 'dejunk options)
	(begin
	  (db:delay-if-busy mtdb)
	  (db:clean-up mtdb)))

    ;; adjust test-ids to fit into proper range
    ;;
    (if (member 'adj-testids options)
	(begin
	  (db:delay-if-busy mtdb)
	  (db:prep-megatest.db-for-migration mtdb)))

    ;; sync runs, test_meta etc.
    ;;
    (if (member 'old2new options)
	(begin
	  (db:sync-tables (db:sync-main-list mtdb) mtdb (db:get-db dbstruct #f))
	  (for-each 
	   (lambda (run-id)
	     (db:delay-if-busy mtdb)
	     (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id))
		   (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)))
	       (debug:print 0 "INFO: Propagating " (length testrecs) " records for run-id=" run-id " to run specific db")
	       (db:replace-test-records dbstruct run-id testrecs)
	       (sqlite3:finalize! (db:dbdat-get-db (dbr:dbstruct-get-rundb dbstruct)))))
	   run-ids)))

    ;; now ensure all newdb data are synced to megatest.db
    ;; do not use the run-ids list passed in to the function
    ;;
    (if (member 'new2old options)
	(let* ((maindb      (make-dbr:dbstruct path: toppath local: #t))
	       (src-run-ids (db:get-all-run-ids (db:dbdat-get-db (db:get-db maindb 0))))
	       (all-run-ids (sort (delete-duplicates (cons 0 src-run-ids)) <))
	       (count       1)
	       (total       (length all-run-ids))
	       (dead-runs  '()))
	  (for-each
	   (lambda (run-id)
	     (debug:print 0 "Processing run " (if (eq? run-id 0) " main.db " run-id) ", " count " of " total)
	     (set! count (+ count 1))
	     (let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))
		    (frundb (db:dbdat-get-db (db:get-db fromdb run-id))))
	       ;; (db:delay-if-busy frundb)
	       ;; (db:delay-if-busy mtdb)
	       ;; (db:clean-up frundb)
	       (if (eq? run-id 0)
		   (begin
		     (db:sync-tables (db:sync-main-list dbstruct) (db:get-db fromdb #f) mtdb)
		     (set! dead-runs (db:clean-up-maindb (db:get-db fromdb #f))))
		   (begin
		     ;; NB// must sync first to ensure deleted tests get marked as such in megatest.db
		     (db:sync-tables db:sync-tests-only (db:get-db fromdb run-id) mtdb)
		     (db:clean-up-rundb (db:get-db fromdb run-id))
		     ))))
	   all-run-ids)
	  ;; removed deleted runs
	  (let ((dbdir (tasks:get-task-db-path)))
	    (for-each (lambda (run-id)
			(let ((fullname (conc dbdir "/" run-id ".db")))
			  (if (file-exists? fullname)
			      (begin
				(debug:print 0 "Removing database file for deleted run " fullname)
				(delete-file fullname)))))
		      dead-runs))))
    ;; (db:close-all dbstruct)
    ;; (sqlite3:finalize! mdb)
    ))

;; keeping it around for debugging purposes only
(define (open-run-close-no-exception-handling  proc idb . params)
  (debug:print-info 11 "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params)
  (if (or *db-write-access*
	  (not (member proc *db:all-write-procs*)))
      (let* ((db (cond
		  ((pair? idb)                 (db:dbdat-get-db idb))
		  ((sqlite3:database? idb)     idb)
		  ((not idb)                   (debug:print 0 "ERROR: cannot open-run-close with #f anymore"))
		  ((procedure? idb)            (idb))
		  (else   	               (debug:print 0 "ERROR: cannot open-run-close with #f anymore"))))
	     (res #f))
	(set! res (apply proc db params))
	(if (not idb)(sqlite3:finalize! dbstruct))
	(debug:print-info 11 "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 "EXCEPTION: database probably overloaded or unreadable.")
	(debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
	(print "exn=" (condition->list exn))
	(debug:print 0 " status:  " ((condition-property-accessor 'sqlite3 'status) exn))
	(print-call-chain (current-error-port))
	(thread-sleep! sleep-time)
	(debug:print-info 0 "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up")))
     (apply open-run-close-exception-handling proc idb params))
   (apply open-run-close-no-exception-handling proc idb params)))

;; (define open-run-close 
(define open-run-close open-run-close-exception-handling)
		;;	   open-run-close-no-exception-handling


;;			   open-run-close-exception-handling)





;;)













(define (db:initialize-main-db dbdat)

  (let* ((configdat (car *configinfo*))  ;; tut tut, global warning...
	 (keys     (keys:config-get-fields configdat))
	 (havekeys (> (length keys) 0))
	 (keystr   (keys->keystr keys))
	 (fieldstr (keys->key/field keys))
	 (db       (db:dbdat-get-db dbdat)))
    (for-each (lambda (key)
		(let ((keyn key))
		  (if (member (string-downcase keyn)
			      (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count"
				    "pass_count"))
		      (begin
			(print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table, you must remove your megatest.db and <linktree>/.db before trying again.")

			(exit 1)))))
	      keys)
    (sqlite3:with-transaction
     db
     (lambda ()
       (sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));")
       (for-each (lambda (key)
		   (sqlite3:execute db "INSERT OR REPLACE INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT"))
		 keys)
       (sqlite3:execute db (conc 
			    "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, \n			 " 
			    fieldstr (if havekeys "," "") "















			 runname    TEXT DEFAULT 'norun',






			 state      TEXT DEFAULT '',
			 status     TEXT DEFAULT '',

			 owner      TEXT DEFAULT '',

			 event_time TIMESTAMP DEFAULT (strftime('%s','now')),
			 comment    TEXT DEFAULT '',

			 fail_count INTEGER DEFAULT 0,
			 pass_count INTEGER DEFAULT 0,

			 CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));"))



       (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta (
                                     id          INTEGER PRIMARY KEY,













                                     testname    TEXT DEFAULT '',
                                     author      TEXT DEFAULT '',
                                     owner       TEXT DEFAULT '',
                                     description TEXT DEFAULT '',
                                     reviewed    TIMESTAMP,
                                     iterated    TEXT DEFAULT '',
                                     avg_runtime REAL,
                                     avg_disk    REAL,
                                     tags        TEXT DEFAULT '',
                                     jobgroup    TEXT DEFAULT 'default',
                                CONSTRAINT test_meta_constraint UNIQUE (testname));")
       (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY,
                                action TEXT DEFAULT '',
                                owner TEXT,
                                state TEXT DEFAULT 'new',
                                target TEXT DEFAULT '',
                                name TEXT DEFAULT '',
                                testpatt TEXT DEFAULT '',
                                keylock TEXT,
                                params TEXT,
                                creation_time TIMESTAMP DEFAULT (strftime('%s','now')),
                                execution_time TIMESTAMP);")
       ;; archive disk areas, cached info from [archive-disks]
       (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_disks (
                                id INTEGER PRIMARY KEY,
                                archive_area_name TEXT,
                                disk_path TEXT,
                                last_df INTEGER DEFAULT -1,
                                last_df_time TIMESTAMP DEFAULT (strftime('%s','now')),
                                creation_time TIMESTAMP DEFAULT (strftime('%','now')));")
       ;; individual bup (or tar) data chunks
       (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_blocks (
                                id INTEGER PRIMARY KEY,
                                archive_disk_id INTEGER,
                                disk_path TEXT,
                                last_du INTEGER DEFAULT -1,
                                last_du_time TIMESTAMP DEFAULT (strftime('%s','now')),
                                creation_time TIMESTAMP DEFAULT (strftime('%','now')));")
       ;; tests allocated to what chunks. reusing a chunk for a test/item_path is very efficient
       ;; NB// the per run/test recording of where the archive is stored is done in the test
       ;;      record. 
       (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_allocations (
                                id INTEGER PRIMARY KEY,
                                archive_block_id INTEGER,
                                testname TEXT,
                                item_path TEXT,
                                creation_time TIMESTAMP DEFAULT (strftime('%','now')));")
       ;; move this clean up call somewhere else
       (sqlite3:execute db "DELETE FROM tasks_queue WHERE state='done' AND creation_time < ?;" (- (current-seconds)(* 24 60 60))) ;; remove older than 24 hrs
       (sqlite3:execute db (conc "CREATE INDEX IF NOT EXISTS runs_index ON runs (runname" (if havekeys "," "") keystr ");"))
       ;; (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;")
       (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);")
       (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT,
                                  CONSTRAINT metadat_constraint UNIQUE (var));")
       (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);")
       ;; Must do this *after* running patch db !! No more. 
       ;; cannot use db:set-var since it will deadlock, hardwire the code here
       (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" megatest-version)
       (debug:print-info 11 "db:initialize END")))))

;;======================================================================
;; R U N   S P E C I F I C   D B 
;;======================================================================

(define (db:initialize-run-id-db db)
  (sqlite3:with-transaction 
   db
   (lambda ()
     (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tests 
                    (id INTEGER PRIMARY KEY,
                     run_id       INTEGER   DEFAULT -1,
                     testname     TEXT      DEFAULT 'noname',
                     host         TEXT      DEFAULT 'n/a',
                     cpuload      REAL      DEFAULT -1,
                     diskfree     INTEGER   DEFAULT -1,
                     uname        TEXT      DEFAULT 'n/a', 
                     rundir       TEXT      DEFAULT '/tmp/badname',
                     shortdir     TEXT      DEFAULT '/tmp/badname',
                     item_path    TEXT      DEFAULT '',
                     state        TEXT      DEFAULT 'NOT_STARTED',
                     status       TEXT      DEFAULT 'FAIL',
                     attemptnum   INTEGER   DEFAULT 0,
                     final_logf   TEXT      DEFAULT 'logs/final.log',
                     logdat       TEXT      DEFAULT '', 
                     run_duration INTEGER   DEFAULT 0,
                     comment      TEXT      DEFAULT '',
                     event_time   TIMESTAMP DEFAULT (strftime('%s','now')),
                     fail_count   INTEGER   DEFAULT 0,
                     pass_count   INTEGER   DEFAULT 0,
                     archived     INTEGER   DEFAULT 0, -- 0=no, > 1=archive block id where test data can be found
                        CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path));")
     (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path);")
     (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps 
                              (id INTEGER PRIMARY KEY,
                               test_id INTEGER, 
                               stepname TEXT, 
                               state TEXT DEFAULT 'NOT_STARTED', 
                               status TEXT DEFAULT 'n/a',
                               event_time TIMESTAMP,
                               comment TEXT DEFAULT '',
                               logfile TEXT DEFAULT '',
                               CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));")
     ;;   (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data 
     ;;                               (id          INTEGER PRIMARY KEY,
     ;;                                      reviewed    TIMESTAMP DEFAULT (strftime('%s','now')),
     ;;                                      iterated    TEXT DEFAULT '',
     ;;                                      avg_runtime REAL DEFAULT -1,
     ;;                                      avg_disk    REAL DEFAULT -1,
     ;;                                      tags        TEXT DEFAULT '',
     ;;                                      jobgroup    TEXT DEFAULT 'default',
     ;;                                 CONSTRAINT test_meta_constraint UNIQUE (testname));")
     (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY,
                                test_id INTEGER,
                                category TEXT DEFAULT '',
                                variable TEXT,
	                        value REAL,
	                        expected REAL,
	                        tol REAL,
                                units TEXT,
                                comment TEXT DEFAULT '',
                                status TEXT DEFAULT 'n/a',
                                type TEXT DEFAULT '',
                              CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));")
     ;; Why use FULL here? This data is not that critical
     ;; (sqlite3:execute db "PRAGMA synchronous = FULL;")
     (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat (

                              id           INTEGER PRIMARY KEY,

                              test_id      INTEGER,

                              update_time  TIMESTAMP,
                              cpuload      INTEGER DEFAULT -1,
                              diskfree     INTEGER DEFAULT -1,
                              diskusage    INTGER DEFAULT -1,
                              run_duration INTEGER DEFAULT 0);")
     (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archives (
                              id           INTEGER PRIMARY KEY,
                              test_id      INTEGER,


                              state        TEXT DEFAULT 'new',
                              status       TEXT DEFAULT 'n/a',
                              archive_type TEXT DEFAULT 'bup',
                              du           INTEGER,




                              archive_path TEXT);")))
  db)



;;======================================================================
;; A R C H I V E S
;;======================================================================


;; dneeded is minimum space needed, scan for existing archives that 
;; are on disks with adequate space and already have this test/itempath
;; archived
;;
(define (db:archive-get-allocations dbstruct testname itempath dneeded)
  (let* ((dbdat        (db:get-db dbstruct #f)) ;; archive tables are in main.db
	 (db           (db:dbdat-get-db dbdat))
	 (res          '())
	 (blocks       '())) ;; a block is an archive chunck that can be added too if there is space
    (sqlite3:for-each-row


     (lambda (id archive-disk-id disk-path last-du last-du-time)
       (set! res (cons (vector id archive-disk-id disk-path last-du last-du-time) res)))







     db
     "SELECT b.id,b.archive_disk_id,b.disk_path,b.last_du,b.last_du_time FROM archive_blocks AS b
        INNER JOIN archive_allocations AS a ON a.archive_block_id=b.id
        WHERE a.testname=? AND a.item_path=?;" 
     testname itempath)
    ;; Now res has list of candidate paths, look in archive_disks for candidate with potential free space
    (if (null? res)
	'()
	(sqlite3:for-each-row
	 (lambda (id archive-area-name disk-path last-df last-df-time)
	   (set! blocks (cons (vector id archive-area-name disk-path last-df last-df-time) blocks)))
	 db 
	 (conc
	  "SELECT d.id,d.archive_area_name,disk_path,last_df,last_df_time FROM archive_disks AS d
             INNER JOIN archive_blocks AS b ON d.id=b.archive_disk_id
             WHERE b.id IN (" (string-intersperse (map conc res) ",") ") AND
         last_df > ?;")
	 dneeded))
    blocks))
    
;; returns id of the record, register a disk allocated to archiving and record it's last known
;; available space
;;
(define (db:archive-register-disk dbstruct bdisk-name bdisk-path df)
  (let* ((dbdat        (db:get-db dbstruct #f)) ;; archive tables are in main.db
	 (db           (db:dbdat-get-db dbdat))
	 (res          #f))
    (sqlite3:for-each-row
     (lambda (id)
       (set! res id))
     db
     "SELECT id FROM archive_disks WHERE archive_area_name=? AND disk_path=?;"
     bdisk-name bdisk-path)
    (if res ;; record exists, update df and return id
	(begin


	  (sqlite3:execute db "UPDATE archive_disks SET last_df=?,last_df_time=(strftime('%s','now'))
                                  WHERE archive_area_name=? AND disk_path=?;"
			   df bdisk-name bdisk-path)
	  res)
	(begin
	  (sqlite3:execute
	   db
	   "INSERT OR REPLACE INTO archive_disks (archive_area_name,disk_path,last_df)
                VALUES (?,?,?);"
	   bdisk-name bdisk-path df)
	  (db:archive-register-disk dbstruct bdisk-name bdisk-path df)))))


;; record an archive path created on a given archive disk (identified by it's bdisk-id)
;; if path starts with / then it is full, otherwise it is relative to the archive disk
;; preference is to store the relative path.
;;
(define (db:archive-register-block-name dbstruct bdisk-id archive-path #!key (du #f))
  (let* ((dbdat        (db:get-db dbstruct #f)) ;; archive tables are in main.db
	 (db           (db:dbdat-get-db dbdat))
	 (res          #f))
    ;; first look to see if this path is already registered
    (sqlite3:for-each-row
     (lambda (id)
       (set! res id))
     db
     "SELECT id FROM archive_blocks WHERE archive_disk_id=? AND disk_path=?;"
     bdisk-id archive-path)
    (if res ;; record exists, update du if applicable and return res
	(begin
	  (if du (sqlite3:exectute db "UPDATE archive_blocks SET last_du=?,last_du_time=(strftime('%s','now'))
                                          WHERE archive_disk_id=? AND disk_path=?;"
				   bdisk-id archive-path du))
	  res)
	(begin
	  (sqlite3:execute db "INSERT OR REPLACE INTO archive_blocks (archive_disk_id,disk_path,last_du)
                                                        VALUES (?,?,?);"
			   bdisk-id archive-path (or du 0))
	  (db:archive-register-block-name dbstruct bdisk-id archive-path du: du)))))


;; The "archived" field in tests is overloaded; 0 = not archived, > 0 archived in block with given id
;;
(define (db:test-set-archive-block-id dbstruct run-id test-id archive-block-id)
  (db:with-db
   dbstruct
   run-id
   #f
   (lambda (db)
     (sqlite3:execute db "UPDATE tests SET archived=? WHERE id=?;"









		      archive-block-id test-id))))







 
;; Look up the archive block info given a block-id
;;
(define (db:test-get-archive-block-info dbstruct archive-block-id)
  (db:with-db
   dbstruct
   #f
   #f
   (lambda (db)

     (let ((res #f))

       (sqlite3:for-each-row 
	;;        0         1           2        3          4           5
	(lambda (id archive-disk-id disk-path last-du last-du-time creation-time)
	  (set! res (vector id archive-disk-id disk-path last-du last-du-time creation-time)))

	db
	"SELECT id,archive_disk_id,disk_path,last_du,last_du_time,creation_time FROM archive_blocks WHERE id=?;"

	archive-block-id)
       res))))

;; (define (db:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey)
;;   (let* ((dbdat        (db:get-db dbstruct #f)) ;; archive tables are in main.db
;; 	 (db           (db:dbdat-get-db dbdat))
;; 	 (res          '())
;; 	 (blocks       '())) ;; a block is an archive chunck that can be added too if there is space
;;     (sqlite3:for-each-row  #f)

;;======================================================================
;; L O G G I N G    D B 
;;======================================================================

(define (open-logging-db) ;;  (conc *toppath* "/megatest.db") (car *configinfo*)))
  (let* ((dbpath    (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname)
	 (dbexists  (file-exists? dbpath))
	 (db        (sqlite3:open-database dbpath))
	 (handler   (make-busy-timeout (if (args:get-arg "-override-timeout")
					   (string->number (args:get-arg "-override-timeout"))
					   136000)))) ;; 136000)))
    (sqlite3:set-busy-handler! db handler)
    (if (not dbexists)
	(begin
	  (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log (id INTEGER PRIMARY KEY,event_time TIMESTAMP DEFAULT (strftime('%s','now')),logline TEXT,pwd TEXT,cmdline TEXT,pid INTEGER);")
	  (db:set-sync db) ;; (sqlite3:execute db (conc "PRAGMA synchronous = 0;"))
	  ))
    db))

(define (db:log-local-event . loglst)
  (let ((logline (apply conc loglst)))



    (db:log-event logline)))

(define (db:log-event logline)
  (let ((db (open-logging-db)))
    (sqlite3:execute db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);"
		     logline
		     (current-directory)
		     (string-intersperse (argv) " ")
		     (current-process-id))
    (sqlite3:finalize! db)
    logline))

;;======================================================================
;; D B   U T I L S


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
















































































;;======================================================================
;; M A I N T E N A N C E
;;======================================================================

(define (db:have-incompletes? dbstruct run-id ovr-deadtime)
  (let* ((dbdat        (db:get-db dbstruct run-id))
	 (db           (db:dbdat-get-db dbdat))
	 (incompleted '())
	 (oldlaunched '())
	 (toplevels   '())
	 (deadtime-str (configf:lookup *configdat* "setup" "deadtime"))
	 (deadtime     (if (and deadtime-str
				(string->number deadtime-str))
			   (string->number deadtime-str)
			   7200))) ;; two hours
    (if (number? ovr-deadtime)(set! deadtime ovr-deadtime))
    
    ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes
    ;;
    ;; HOWEVER: this code in run:test seems to work fine
    ;;              (> (- (current-seconds)(+ (db:test-get-event_time testdat)
    ;;                     (db:test-get-run_duration testdat)))
    ;;                    600) 
    (db:delay-if-busy dbdat)
    (sqlite3:for-each-row 
     (lambda (test-id run-dir uname testname item-path)
       (if (and (equal? uname "n/a")
		(equal? item-path "")) ;; this is a toplevel test
	   ;; what to do with toplevel? call rollup?
	   (begin
	     (set! toplevels   (cons (list test-id run-dir uname testname item-path run-id) toplevels))
	     (debug:print-info 0 "Found old toplevel test in RUNNING state, test-id=" test-id))
	   (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted))))
     db
     "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');"
     run-id deadtime)

    ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config
    ;;
    (db:delay-if-busy dbdat)
    (sqlite3:for-each-row
     (lambda (test-id run-dir uname testname item-path)
       (if (and (equal? uname "n/a")
		(equal? item-path "")) ;; this is a toplevel test
	   ;; what to do with toplevel? call rollup?
	   (set! toplevels   (cons (list test-id run-dir uname testname item-path run-id) toplevels))
	   (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched))))
     db
     "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');"
     run-id)
    
    (debug:print-info 18 "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.")
    (if (and (null? incompleted)
	     (null? oldlaunched)
	     (null? toplevels))
	#f
	#t)))

;;  select end_time-now from
;;      (select testname,item_path,event_time+run_duration as
;;                          end_time,strftime('%s','now') as now from tests where state in
;;      ('RUNNING','REMOTEHOSTSTART','LAUNCED'));

(define (db:find-and-mark-incomplete dbstruct run-id ovr-deadtime)
  (let* ((dbdat        (db:get-db dbstruct run-id))
	 (db           (db:dbdat-get-db dbdat))
	 (incompleted '())
	 (oldlaunched '())
	 (toplevels   '())
	 (deadtime-str (configf:lookup *configdat* "setup" "deadtime"))
	 (deadtime     (if (and deadtime-str
				(string->number deadtime-str))
			   (string->number deadtime-str)
			   7200))) ;; two hours

    (if (number? ovr-deadtime)(set! deadtime ovr-deadtime))


    
    ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes
    ;;



    ;; HOWEVER: this code in run:test seems to work fine
    ;;              (> (- (current-seconds)(+ (db:test-get-event_time testdat)
    ;;                     (db:test-get-run_duration testdat)))
    ;;                    600) 
    (db:delay-if-busy dbdat)
    (sqlite3:for-each-row 
     (lambda (test-id run-dir uname testname item-path)
       (if (and (equal? uname "n/a")
		(equal? item-path "")) ;; this is a toplevel test
	   ;; what to do with toplevel? call rollup?
	   (begin
	     (set! toplevels   (cons (list test-id run-dir uname testname item-path run-id) toplevels))
	     (debug:print-info 0 "Found old toplevel test in RUNNING state, test-id=" test-id))
	   (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted))))
     db
     "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');"
     run-id deadtime)

    ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config
    ;;
    (db:delay-if-busy dbdat)
    (sqlite3:for-each-row
     (lambda (test-id run-dir uname testname item-path)
       (if (and (equal? uname "n/a")
		(equal? item-path "")) ;; this is a toplevel test
	   ;; what to do with toplevel? call rollup?
	   (set! toplevels   (cons (list test-id run-dir uname testname item-path run-id) toplevels))
	   (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched))))
     db
     "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');"
     run-id)
    
    (debug:print-info 18 "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.")

    ;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE.
    ;;
    (db:delay-if-busy dbdat)
    (let* (;; (min-incompleted (filter (lambda (x)
	   ;;      		      (let* ((testpath (cadr x))
	   ;;      			     (tdatpath (conc testpath "/testdat.db"))
	   ;;      			     (dbexists (file-exists? tdatpath)))
	   ;;      			(or (not dbexists) ;; if no file then something wrong - mark as incomplete
	   ;;      			    (> (- (current-seconds)(file-modification-time tdatpath)) 600)))) ;; no change in 10 minutes to testdat.db - she's dead Jim
	   ;;      		    incompleted))
	   (min-incompleted-ids (map car incompleted)) ;; do 'em all
	   (all-ids             (append min-incompleted-ids (map car oldlaunched))))
      (if (> (length all-ids) 0)
	  (begin
	    (debug:print 0 "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") " as INCOMPLETE")
	    (sqlite3:execute 
	     db
	     (conc "UPDATE tests SET state='INCOMPLETE' WHERE id IN (" 
		   (string-intersperse (map conc all-ids) ",")
		   ");")))))

    ;; Now do rollups for the toplevel tests
    ;;
    (db:delay-if-busy dbdat)
    (for-each
     (lambda (toptest)
       (let ((test-name (list-ref toptest 3)))
;;	     (run-id    (list-ref toptest 5)))
	  (db:general-call db 'top-test-set-per-pf-counts (list test-name run-id test-name test-name test-name)))) ;; (list run-id test-name))))
     toplevels)))
		     
;; Clean out old junk and vacuum the database
;;
;; Ultimately do something like this:
;;
;; 1. Look at test records either deleted or part of deleted run:
;;    a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown'
;;    b. If test dir gone, delete the test record
;; 2. Look at run records
;;    a. If have tests that are not deleted, set state='unknown'
;;    b. ....
;;
(define (db:clean-up dbdat)
  ;; (debug:print 0 "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db")
  (let* ((db         (db:dbdat-get-db dbdat))
	 (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);"))
	(statements
	 (map (lambda (stmt)
		(sqlite3:prepare db stmt))
	      (list
	       ;; delete all tests that belong to runs that are 'deleted'
	       "DELETE FROM tests WHERE run_id in (SELECT id FROM runs WHERE state='deleted');"
	       ;; delete all tests that are 'DELETED'
	       "DELETE FROM tests WHERE state='DELETED';"
	       ;; delete all tests that have no run
	       "DELETE FROM tests WHERE run_id NOT IN (SELECT DISTINCT id FROM runs);"
	       ;; delete all runs that are state='deleted'
	       "DELETE FROM runs WHERE state='deleted';"
	       ;; delete empty runs
	       "DELETE FROM runs WHERE id NOT IN (SELECT DISTINCT r.id FROM runs AS r INNER JOIN tests AS t ON t.run_id=r.id);"
	       ))))
    (db:delay-if-busy dbdat)
    (sqlite3:with-transaction 
     db
     (lambda ()
       (sqlite3:for-each-row (lambda (tot)
			       (debug:print-info 0 "Records count before clean: " tot))
			     count-stmt)
       (map sqlite3:execute statements)
       (sqlite3:for-each-row (lambda (tot)
			       (debug:print-info 0 "Records count after  clean: " tot))
			     count-stmt)))
    (map sqlite3:finalize! statements)
    (sqlite3:finalize! count-stmt)
    ;; (db:find-and-mark-incomplete db)
    (db:delay-if-busy dbdat)
    (sqlite3:execute db "VACUUM;")))

;; Clean out old junk and vacuum the database
;;
;; Ultimately do something like this:
;;
;; 1. Look at test records either deleted or part of deleted run:
;;    a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown'
;;    b. If test dir gone, delete the test record
;; 2. Look at run records
;;    a. If have tests that are not deleted, set state='unknown'
;;    b. ....
;;
(define (db:clean-up-rundb dbdat)
  ;; (debug:print 0 "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db")
  (let* ((db         (db:dbdat-get-db dbdat))
	 (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests);"))
	(statements
	 (map (lambda (stmt)
		(sqlite3:prepare db stmt))
	      (list
	       ;; delete all tests that belong to runs that are 'deleted'
	       ;; (conc "DELETE FROM tests WHERE run_id NOT IN (" (string-intersperse (map conc valid-runs) ",") ");")
	       ;; delete all tests that are 'DELETED'
	       "DELETE FROM tests WHERE state='DELETED';"
	       ))))
    (db:delay-if-busy dbdat)
    (sqlite3:with-transaction 
     db
     (lambda ()
       (sqlite3:for-each-row (lambda (tot)
			       (debug:print-info 0 "Records count before clean: " tot))
			     count-stmt)
       (map sqlite3:execute statements)
       (sqlite3:for-each-row (lambda (tot)
			       (debug:print-info 0 "Records count after  clean: " tot))
			     count-stmt)))
    (map sqlite3:finalize! statements)
    (sqlite3:finalize! count-stmt)
    ;; (db:find-and-mark-incomplete db)
    (db:delay-if-busy dbdat)
    (sqlite3:execute db "VACUUM;")))

;; Clean out old junk and vacuum the database
;;
;; Ultimately do something like this:
;;
;; 1. Look at test records either deleted or part of deleted run:
;;    a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown'
;;    b. If test dir gone, delete the test record
;; 2. Look at run records
;;    a. If have tests that are not deleted, set state='unknown'
;;    b. ....
;;
(define (db:clean-up-maindb dbdat)
  ;; (debug:print 0 "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db")
  (let* ((db         (db:dbdat-get-db dbdat))
	 (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM runs);"))
	 (statements
	  (map (lambda (stmt)
		 (sqlite3:prepare db stmt))
	       (list
		;; delete all tests that belong to runs that are 'deleted'
		;; (conc "DELETE FROM tests WHERE run_id NOT IN (" (string-intersperse (map conc valid-runs) ",") ");")
		;; delete all tests that are 'DELETED'
		"DELETE FROM runs WHERE state='deleted';"
		)))
	 (dead-runs '()))
    (sqlite3:for-each-row
     (lambda (run-id)
       (set! dead-runs (cons run-id dead-runs)))
       db
       "SELECT id FROM runs WHERE state='deleted';")
    (db:delay-if-busy dbdat)
    (sqlite3:with-transaction 
     db
     (lambda ()
       (sqlite3:for-each-row (lambda (tot)
			       (debug:print-info 0 "Records count before clean: " tot))
			     count-stmt)
       (map sqlite3:execute statements)
       (sqlite3:for-each-row (lambda (tot)
			       (debug:print-info 0 "Records count after  clean: " tot))
			     count-stmt)))
    (map sqlite3:finalize! statements)
    (sqlite3:finalize! count-stmt)
    ;; (db:find-and-mark-incomplete db)
    (db:delay-if-busy dbdat)
    (sqlite3:execute db "VACUUM;")
    dead-runs))

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

;; M E T A   G E T   A N D   S E T   V A R S
;;======================================================================

;; returns number if string->number is successful, string otherwise
;; also updates *global-delta*
;;
;; Operates on megatestdb
;;
(define (db:get-var dbstruct var)

  (let* ((start-ms (current-milliseconds))
         (throttle (let ((t  (config-lookup *configdat* "setup" "throttle")))
		     (if t (string->number t) t)))
	 (res      #f)
	 (dbdat    (db:get-db dbstruct #f))
	 (db       (db:dbdat-get-db dbdat)))
    (db:delay-if-busy dbdat)
    (sqlite3:for-each-row
     (lambda (val)
       (set! res val))
     db
     "SELECT val FROM metadat WHERE var=?;" var)
    ;; convert to number if can
    (if (string? res)
	(let ((valnum (string->number res)))
	  (if valnum (set! res valnum))))
    ;; scale by 10, average with current value.
    (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms)
						 (if throttle throttle 0.01)))
			    2))
    (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit
	(begin
	  (debug:print-info 4 "launch throttle factor=" *global-delta*)
	  (set! *last-global-delta-printed* *global-delta*)))

    res))

(define (db:set-var dbstruct var val)
  (let ((dbdat (db:get-db dbstruct #f))
	(db    (db:dbdat-get-db dbdat)))
    (db:delay-if-busy dbdat)
    (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val)))


(define (db:del-var dbstruct var)

  ;; (db:delay-if-busy)
  (db:with-db dbstruct #f #t 
	      (lambda (db)
		(sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var))))


;; use a global for some primitive caching, it is just silly to
;; re-read the db over and over again for the keys since they never
;; change

;; why get the keys from the db? why not get from the *configdat*
;; using keys:config-get-fields?

(define (db:get-keys dbstruct)
  (if *db-keys* *db-keys* 
      (let ((res '()))
	(db:with-db dbstruct #f #f
		    (lambda (db)
		      (sqlite3:for-each-row 
		       (lambda (key)
			 (set! res (cons key res)))
		       db
		       "SELECT fieldname FROM keys ORDER BY id DESC;")))
	(set! *db-keys* res)
	res)))

;; look up values in a header/data structure
(define (db:get-value-by-header row header field)

  (if (null? header) #f
      (let loop ((hed (car header))
		 (tal (cdr header))
		 (n   0))
	(if (equal? hed field)
	    (vector-ref row n)
	    (if (null? tal) #f (loop (car tal)(cdr tal)(+ n 1)))))))

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

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

(define (db:get-run-name-from-id dbstruct run-id)
  (db:with-db 
   dbstruct
   #f ;; this is for the main runs db
   #f ;; does not modify db
   (lambda (db)
     (let ((res #f))
       (sqlite3:for-each-row
	(lambda (runname)
	  (set! res runname))
	db
	"SELECT runname FROM runs WHERE id=?;"
	run-id)
       res))))

(define (db:get-run-key-val dbstruct run-id key)
  (db:with-db
   dbstruct
   #f
   #f
   (lambda (db)
     (let ((res #f))
       (sqlite3:for-each-row
	(lambda (val)
	  (set! res val))
	db
	(conc "SELECT " key " FROM runs WHERE id=?;")
	run-id)
       res))))

;; keys list to key1,key2,key3 ...
(define (runs:get-std-run-fields keys remfields)
  (let* ((header    (append keys remfields))
	 (keystr    (conc (keys->keystr keys) ","
			  (string-intersperse remfields ","))))
    (list keystr header)))
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
				 (conc fieldname " " wildtype " '" patt "'")))
			     (if (null? patts)
				 '("")
				 patts))
			comparator)))


;; register a test run with the db


(define (db:register-run db keyvals runname state status user)
  (debug:print 3 "runs:register-run runname: " runname " state: " state " status: " status " user: " user)


  (let* ((keys      (map car keyvals))
	 (keystr    (keys->keystr keys))	 
	 (comma     (if (> (length keys) 0) "," ""))
	 (andstr    (if (> (length keys) 0) " AND " ""))
	 (valslots  (keys->valslots keys)) ;; ?,?,? ...
	 (allvals   (append (list runname state status user) (map cadr keyvals)))
	 (qryvals   (append (list runname) (map cadr keyvals)))
	 (key=?str  (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND ")))
    (debug:print 3 "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str)
    (debug:print 2 "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run")
    (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and"
	(let ((res #f))
	  (db:delay-if-busy)
	  (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");")
		 allvals)

	  (apply sqlite3:for-each-row 
		 (lambda (id)
		   (set! res id))
		 db
		 (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");")))
					;(debug:print 4 "qry: " qry) 
		   qry)
		 qryvals)
	  (db:delay-if-busy)
	  (sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res)
	  res) 
	(begin
	  (debug:print 0 "ERROR: Called without all necessary keys")
	  #f))))


;; replace header and keystr with a call to runs:get-std-run-fields
;;
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
;; runpatts: patt1,patt2 ...
;;
(define (db:get-runs db runpatt count offset keypatts)
  (let* ((res       '())
	 (keys       (db:get-keys db))
	 (runpattstr (db:patt->like "runname" runpatt))
	 (remfields  (list "id" "runname" "state" "status" "owner" "event_time"))
	 (header     (append keys remfields))
	 (keystr     (conc (keys->keystr keys) ","
		           (string-intersperse remfields ",")))
	 (qrystr     (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? "
		           ;; Generate: " AND x LIKE 'keypatt' ..."
		           (if (null? keypatts) ""
		               (conc " AND "
				     (string-join 
				      (map (lambda (keypatt)
					     (let ((key  (car keypatt))
						   (patt (cadr keypatt)))
					       (db:patt->like key patt)))
					   keypatts)
				      " AND ")))
		           " AND state != 'deleted' ORDER BY event_time DESC "
		           (if (number? count)
		               (conc " LIMIT " count)
		               "")
		           (if (number? offset)
		               (conc " OFFSET " offset)
		               ""))))
    (debug:print-info 11 "db:get-runs START qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count)


    (sqlite3:for-each-row
     (lambda (a . x)
       (set! res (cons (apply vector a x) res)))
     db
     qrystr
     )
    (debug:print-info 11 "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count)
    (vector header res)))














































;; Get all targets from the db
;;
(define (db:get-targets db)
  (let* ((res       '())
	 (keys       (db:get-keys db))
	 (header     keys) ;; (map key:get-fieldname keys))
	 (keystr     (keys->keystr keys))
	 (qrystr     (conc "SELECT " keystr " FROM runs;"))
	 (seen       (make-hash-table)))





    (sqlite3:for-each-row
     (lambda (a . x)
       (let ((targ (cons a x)))
	 (if (not (hash-table-ref/default seen targ #f))
	     (begin
	       (hash-table-set! seen targ #t)
	       (set! res (cons (apply vector targ) res))))))
     db
     qrystr)
    (debug:print-info 11 "db:get-targets END qrystr: " qrystr )
    (vector header res)))

;; just get count of runs
(define (db:get-num-runs db runpatt)





  (let ((numruns 0))
    (debug:print-info 11 "db:get-num-runs START " runpatt)
    (sqlite3:for-each-row 
     (lambda (count)
       (set! numruns count))
     db
     "SELECT COUNT(id) FROM runs WHERE runname LIKE ? AND state != 'deleted';" runpatt)
    (debug:print-info 11 "db:get-num-runs END " runpatt)
    numruns))















;; get some basic run stats
;;
;; ( (runname (( state  count ) ... ))
;;   (   ...  
(define (db:get-run-stats db)


  (let ((totals       (make-hash-table))

	(res          '()))



    (sqlite3:for-each-row
     (lambda (runname state count)
       (let* ((stateparts (string-split state "|"))
	      (newstate   (conc (car stateparts) "\n" (cadr stateparts))))
	 (hash-table-set! totals newstate (+ (hash-table-ref/default totals newstate 0) count))
	 (set! res (cons (list runname newstate count) res))))
     db
     "SELECT runname,t.state||'|'||t.status AS s,count(t.id) FROM runs AS r INNER JOIN tests AS t ON r.id=t.run_id GROUP BY s,runname ORDER BY r.event_time,s DESC;" )






















    ;; (set! res (reverse res))



    (for-each (lambda (state)
		(set! res (cons (list "Totals" state (hash-table-ref totals state)) res)))
	      (sort (hash-table-keys totals) string>=))
    res))

;; db:get-runs-by-patt
;; get runs by list of criteria
;; register a test run with the db
;;
;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo))
;;  to extract info from the structure returned
;;
(define (db:get-runs-by-patt db keys runnamepatt targpatt offset limit) ;; test-name)
  (let* ((tmp      (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time")))
	 (keystr   (car tmp))
	 (header   (cadr tmp))
	 (res     '())
	 (key-patt "")
	 (runwildtype (if (substring-index "%" runnamepatt) "like" "glob"))
	 (qry-str  #f)
	 (keyvals  (if targpatt (keys:target->keyval keys targpatt) '())))
    (for-each (lambda (keyval)
		(let* ((key    (car keyval))
		       (patt   (cadr keyval))
		       (fulkey (conc ":" key))
		       (wildtype (if (substring-index "%" patt) "like" "glob")))
		  (if patt
		      (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'"))
		      (begin
			(debug:print 0 "ERROR: searching for runs with no pattern set for " fulkey)
			(exit 6)))))
	      keyvals)
    (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt " ORDER BY event_time"
			(if limit  (conc " LIMIT " limit)   "")
			(if offset (conc " OFFSET " offset) "")
			";"))
    (debug:print-info 4 "runs:get-runs-by-patt qry=" qry-str " " runnamepatt)


    (sqlite3:for-each-row 
     (lambda (a . r)
       (set! res (cons (list->vector (cons a r)) res)))
     db 
     qry-str
     runnamepatt)
    (vector header res)))

;; use (get-value-by-header (db:get-header runinfo)(db:get-row runinfo))
(define (db:get-run-info db run-id)
  ;;(if (hash-table-ref/default *run-info-cache* run-id #f)
  ;;    (hash-table-ref *run-info-cache* run-id)


  (let* ((res      #f)
	 (keys      (db:get-keys db))
	 (remfields (list "id" "runname" "state" "status" "owner" "event_time"))
	 (header    (append keys remfields))
	 (keystr    (conc (keys->keystr keys) ","
			  (string-intersperse remfields ","))))
    (debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)

    (sqlite3:for-each-row
     (lambda (a . x)
       (set! res (apply vector a x)))
     db
     (conc "SELECT " keystr " FROM runs WHERE id=? AND state != 'deleted';")
     run-id)
    (debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)
    (let ((finalres (vector header res)))
      ;; (hash-table-set! *run-info-cache* run-id finalres)
      finalres)))

(define (db:set-comment-for-run db run-id comment)
  (debug:print-info 11 "db:set-comment-for-run START run-id: " run-id " comment: " comment)
  (db:delay-if-busy)




  (sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment run-id)
  (debug:print-info 11 "db:set-comment-for-run END run-id: " run-id " comment: " comment))

;; does not (obviously!) removed dependent data. But why not!!?
(define (db:delete-run db run-id)
  (common:clear-caches) ;; don't trust caches after doing any deletion
  ;; First set any related tests to DELETED




  (db:delay-if-busy)
  (let ((stmt1 (sqlite3:prepare db "UPDATE tests SET state='DELETED',comment='' WHERE run_id=?;"))
	(stmt2 (sqlite3:prepare db "UPDATE runs SET state='deleted',comment='' WHERE id=?;")))
    (sqlite3:with-transaction
     db (lambda ()
	  (sqlite3:execute stmt1 run-id)
	  (sqlite3:execute stmt2 run-id)))
    (sqlite3:finalize! stmt1)
    (sqlite3:finalize! stmt2)))
;;  (sqlite3:execute db "DELETE FROM runs WHERE id=?;" run-id))

(define (db:update-run-event_time db run-id)
  (debug:print-info 11 "db:update-run-event_time START run-id: " run-id)
  (db:delay-if-busy)




  (sqlite3:execute db "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id)
  (debug:print-info 11 "db:update-run-event_time END run-id: " run-id)) 





(define (db:lock/unlock-run db run-id lock unlock user)
  (let ((newlockval (if lock "locked"
			(if unlock
			    "unlocked"
			    "locked")))) ;; semi-failsafe
    (db:delay-if-busy)
    (sqlite3:execute db "UPDATE runs SET state=? WHERE id=?;" newlockval run-id)
    (sqlite3:execute db "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);"
		     user (conc newlockval " " run-id))
    (debug:print-info 1 "" newlockval " run number " run-id)))

(define (db:set-run-status db run-id status #!key (msg #f))


  (db:delay-if-busy)
  (if msg
      (sqlite3:execute db "UPDATE runs SET status=?,comment=? WHERE id=?;" status msg run-id)
      (sqlite3:execute db "UPDATE runs SET status=? WHERE id=?;" status run-id)))

(define (db:get-run-status db run-id)
  (let ((res "n/a"))





    (sqlite3:for-each-row 
     (lambda (status)
       (set! res status))
     db 
     "SELECT status FROM runs WHERE id=?;" 
     run-id)
    res))

(define (db:get-run-ids db)
  (let ((res '()))
    (sqlite3:for-each-row
     (lambda (id)
       (set! res (cons id res)))
     db 
     "SELECT id FROM runs;")))

;;======================================================================
;; K E Y S
;;======================================================================

;; get key val pairs for a given run-id
;; ( (FIELDNAME1 keyval1) (FIELDNAME2 keyval2) ... )
(define (db:get-key-val-pairs db run-id)
  (let* ((keys (db:get-keys db))
	 (res  '()))
    (debug:print-info 11 "db:get-key-val-pairs START keys: " keys " run-id: " run-id)

    (for-each 
     (lambda (key)
       (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
	 ;; (debug:print 0 "qry: " qry)
	 (sqlite3:for-each-row 
	  (lambda (key-val)
	    (set! res (cons (list key key-val) res)))
	  db qry run-id)))
     keys)
    (debug:print-info 11 "db:get-key-val-pairs END keys: " keys " run-id: " run-id)
    (reverse res)))

;; get key vals for a given run-id
(define (db:get-key-vals db run-id)
  (let ((mykeyvals (hash-table-ref/default *keyvals* run-id #f)))
    (if mykeyvals 
	mykeyvals
	(let* ((keys (db:get-keys db))
	       (res  '()))
	  (debug:print-info 11 "db:get-key-vals START keys: " keys " run-id: " run-id)


	  (for-each 
	   (lambda (key)
	     (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
	       ;; (debug:print 0 "qry: " qry)

	       (sqlite3:for-each-row 
		(lambda (key-val)
		  (set! res (cons key-val res)))
		db qry run-id)))
	   keys)
	  (debug:print-info 11 "db:get-key-vals END keys: " keys " run-id: " run-id)
	  (let ((final-res (reverse res)))
	    (hash-table-set! *keyvals* run-id final-res)
	    final-res)))))

;; The target is keyval1/keyval2..., cached in *target* as it is used often
(define (db:get-target db run-id)
  (let ((mytarg (hash-table-ref/default *target* run-id #f)))
    (if mytarg
	mytarg
	(let* ((keyvals (db:get-key-vals db run-id))
	       (thekey  (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/")))
	  (hash-table-set! *target* run-id thekey)
	  thekey))))


















;;======================================================================
;;  T E S T S
;;======================================================================

;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN
;; i.e. these lists define what to NOT show.
;; states and statuses are required to be lists, empty is ok
;; not-in #t = above behaviour, #f = must match
(define (db:get-tests-for-run db run-id testpatt states statuses offset limit not-in sort-by sort-order
			      #!key



			      (qryvals #f))
  (let* ((qryvalstr       (case qryvals
			    ((shortlist) "id,run_id,testname,item_path,state,status")
			    ((#f)        "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")
			    (else        qryvals)))
	 (res            '())
	 ;; if states or statuses are null then assume match all when not-in is false
	 (states-qry      (if (null? states) 
			      #f
			      (conc " state "  
				    (if not-in
					" NOT IN ('"
					" IN ('") 
				    (string-intersperse states   "','")
				    "')")))
	 (statuses-qry    (if (null? statuses)
			      #f
			      (conc " status "
				    (if not-in 
					" NOT IN ('"
					" IN ('") 
				    (string-intersperse statuses "','")
				    "')")))
	 (states-statuses-qry 
	  (cond 
	   ((and states-qry statuses-qry)
	    (conc " AND ( " states-qry " AND " statuses-qry " ) "))
	   (states-qry  
	    (conc " AND " states-qry))
	   (statuses-qry 
	    (conc " AND " statuses-qry))
	   (else "")))
	 (tests-match-qry (tests:match->sqlqry testpatt))
	 (qry             (conc "SELECT " qryvalstr
				" FROM tests WHERE run_id=? AND state != 'DELETED' "
				states-statuses-qry
				(if tests-match-qry (conc " AND (" tests-match-qry ") ") "")
				(case sort-by
				  ((rundir)      " ORDER BY length(rundir) ")
				  ((testname)    (conc " ORDER BY testname " (if sort-order (conc sort-order ",") "") " item_path "))
				  ((statestatus) (conc " ORDER BY state " (if  sort-order (conc sort-order ",") "") " status "))
				  ((event_time)  " ORDER BY event_time ")
				  (else          (if (string? sort-by)
						     (conc " ORDER BY " sort-by)
						     "")))
				(if sort-order sort-order "")
				(if limit  (conc " LIMIT " limit)   "")
				(if offset (conc " OFFSET " offset) "")
				";"
				)))
    (debug:print-info 8 "db:get-tests-for-run qry=" qry)


    (sqlite3:for-each-row 
     (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment)
       (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res)))
     db 
     qry
     run-id
     )
    (case qryvals
      ((shortlist)(map db:test-short-record->norm res))
      ((#f)       res)
      (else       res))))

(define (db:test-short-record->norm inrec)
  ;;  "id,run_id,testname,item_path,state,status"
  ;;  "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
  (vector (vector-ref inrec 0) ;; id
	  (vector-ref inrec 1) ;; run_id
	  (vector-ref inrec 2) ;; testname
	  (vector-ref inrec 4) ;; state
	  (vector-ref inrec 5) ;; status
	  -1 "" -1 -1 "" "-" 
	  (vector-ref inrec 3) ;; item-path
	  -1 "-" "-"))


(define (db:get-tests-for-run-state-status db run-id testpatt)
  (let ((res            '())
	(tests-match-qry (tests:match->sqlqry testpatt)))





    (sqlite3:for-each-row
     (lambda (id testname item-path state status)
       ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
       (set! res (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res)))
     db 
     (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? " 
	   (if tests-match-qry (conc " AND (" tests-match-qry ") ") ""))

     run-id)
    res))

(define (db:get-testinfo-state-status db test-id)
  (let ((res            #f))


    (sqlite3:for-each-row
     (lambda (run-id testname item-path state status)
       ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
       (set! res (vector test-id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-")))
     db 
     "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=?;" 
     test-id)
    res))

;; get a useful subset of the tests data (used in dashboard
;; use db:mintests-get-{id ,run_id,testname ...}

(define (db:get-tests-for-runs-mindata db run-ids testpatt states status not-in)

  (db:get-tests-for-runs db run-ids testpatt states status not-in: not-in qryvals: "id,run_id,testname,state,status,event_time,item_path"))






;; NB // This is get tests for "runs" (note the plural!!)

;;
;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN
;; i.e. these lists define what to NOT show.
;; states and statuses are required to be lists, empty is ok
;; not-in #t = above behaviour, #f = must match
;; run-ids is a list of run-ids or a single number or #f for all runs
(define (db:get-tests-for-runs db run-ids testpatt states statuses 
			       #!key (not-in #t)
			       (sort-by #f)
			       (qryvals "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")) ;; 'rundir 'event_time
  (let* ((res '())
	 ;; if states or statuses are null then assume match all when not-in is false
	 (states-qry      (if (null? states) 
			      #f
			      (conc " state "  
				    (if not-in "NOT" "") 
				    " IN ('" 
				    (string-intersperse states   "','")
				    "')")))
	 (statuses-qry    (if (null? statuses)
			      #f
			      (conc " status "
				    (if not-in "NOT" "") 
				    " IN ('" 
				    (string-intersperse statuses "','")
				    "')")))
	 (tests-match-qry (tests:match->sqlqry testpatt))
	 (qry             (conc "SELECT " qryvals 
				" FROM tests WHERE state != 'DELETED' "
				(if run-ids
				    (if (list? run-ids)
					(conc "AND run_id IN (" (string-intersperse (map conc run-ids) ",") ") ")
					(conc "AND run_id=" run-ids " "))
				    " ") ;; #f => run-ids don't filter on run-ids
				(if states-qry   (conc " AND " states-qry)   "")
				(if statuses-qry (conc " AND " statuses-qry) "")
				(if tests-match-qry (conc " AND (" tests-match-qry ") ") "")
				(case sort-by
				  ((rundir)     " ORDER BY length(rundir) DESC;")
				  ((event_time) " ORDER BY event_time ASC;")
				  (else         ";"))
				)))
    (debug:print-info 8 "db:get-tests-for-runs qry=" qry)
    (sqlite3:for-each-row 
     (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment)
       (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res)))
     db 
     qry
     )
    res))

;; this one is a bit broken BUG FIXME
(define (db:delete-test-step-records db test-id #!key (work-area #f))
  ;; Breaking it into two queries for better file access interleaving
  (let* ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)))
    ;; test db's can go away - must check every time
    (if (sqlite3:database? tdb)
	(begin
	  (sqlite3:execute tdb "DELETE FROM test_steps;")
	  (sqlite3:execute tdb "DELETE FROM test_data;")
	  (sqlite3:finalize! tdb)))))

;; 
(define (db:delete-test-records db tdb test-id #!key (force #f))
  (common:clear-caches)
  (db:delay-if-busy)
  (if tdb 
      (begin
	(sqlite3:execute tdb "DELETE FROM test_steps;")
	(sqlite3:execute tdb "DELETE FROM test_data;")))
  ;; (sqlite3:execute db "DELETE FROM tests WHERE id=?;" test-id))
  (if db 
      (begin
	(sqlite3:execute db "DELETE FROM test_steps WHERE test_id=?;" test-id)
	(sqlite3:execute db "DELETE FROM test_data  WHERE test_id=?;" test-id)
	(if force
	    (sqlite3:execute db "DELETE FROM tests WHERE id=?;" test-id)
	    (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id)))))

(define (db:delete-tests-for-run db run-id)
  (common:clear-caches)



  (db:delay-if-busy)

  (sqlite3:execute db "DELETE FROM tests WHERE run_id=?;" run-id))

(define (db:delete-old-deleted-test-records db)
  (common:clear-caches)

  (let ((targtime (- (current-seconds)(* 30 24 60 60)))) ;; one month in the past


    (db:delay-if-busy)




    (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED' AND event_time<?;" targtime)))


;; set tests with state currstate and status currstatus to newstate and newstatus
;; use currstate = #f and or currstatus = #f to apply to any state or status respectively
;; WARNING: SQL injection risk. NB// See new but not yet used "faster" version below
;;




(define (db:set-tests-state-status db run-id testnames currstate currstatus newstate newstatus)
  (for-each (lambda (testname)
	      (let ((qry (conc "UPDATE tests SET state=?,status=? WHERE "
			       (if currstate  (conc "state='" currstate "' AND ") "")
			       (if currstatus (conc "status='" currstatus "' AND ") "")
			       " run_id=? AND testname=? AND NOT (item_path='' AND testname in (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")))
		;;(debug:print 0 "QRY: " qry)
		(db:delay-if-busy)
		(sqlite3:execute db qry run-id newstate newstatus testname testname)))
	    testnames))

(define (cdb:delete-tests-in-state serverdat run-id state)
  (common:clear-caches)
  (cdb:client-call serverdat 'delete-tests-in-state #t *default-numtries* run-id state))

(define (cdb:tests-update-cpuload-diskfree serverdat test-id cpuload diskfree)
  (cdb:client-call serverdat 'update-cpuload-diskfree #t *default-numtries* cpuload diskfree test-id))

(define (cdb:tests-update-run-duration serverdat test-id minutes)
  (cdb:client-call serverdat 'update-run-duration #t *default-numtries* minutes test-id))

(define (cdb:tests-update-uname-host serverdat test-id uname hostname)
  (cdb:client-call serverdat 'update-uname-host #t *default-numtries* uname hostname test-id))

;; speed up for common cases with a little logic
;; NB// Ultimately this will be deprecated in deference to mt:test-set-state-status-by-id
;;
(define (db:test-set-state-status-by-id db test-id newstate newstatus newcomment)
  (db:delay-if-busy)




  (cond
   ((and newstate newstatus newcomment)
    (sqlite3:execute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus newcomment test-id))

   ((and newstate newstatus)
    (sqlite3:execute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id))
   (else
    (if newstate   (sqlite3:execute db "UPDATE tests SET state=?   WHERE id=?;" newstate   test-id))
    (if newstatus  (sqlite3:execute db "UPDATE tests SET status=?  WHERE id=?;" newstatus  test-id))
    (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment test-id))))

  (mt:process-triggers test-id newstate newstatus))

;; Never used, but should be?
(define (db:test-set-state-status-by-run-id-testname db run-id test-name item-path status state)
  (db:delay-if-busy)
  (sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strftime('%s','now') WHERE run_id=? AND testname=? AND item_path=?;" 
 		   state status run-id test-name item-path))

(define (db:get-count-tests-running db)
  (let ((res 0))
    (sqlite3:for-each-row



     (lambda (count)
       (set! res count))
     db


     "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id NOT IN (SELECT id FROM runs WHERE state='deleted') AND NOT (uname = 'n/a' AND item_path = '');")

    res))

;; override states to count with list of strings.
;;
(define (db:get-count-tests-running-for-run-id db run-id states)





  (let ((res 0)



	(sqrystr (conc "SELECT count(id) FROM tests WHERE state in ('"
		       (if states
			   (string-intersperse states "','")
			   "RUNNING','LAUNCHED','REMOTEHOSTSTART")
		       "') AND run_id=? AND NOT (uname = 'n/a' AND item_path = '');")))




    (sqlite3:for-each-row



     (lambda (count)
       (set! res count))  ;; select * from tests where run_id=1 and uname = 'n/a' and item_path='';

     db
     sqrystr run-id)
     ;; "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=? AND NOT (uname = 'n/a' AND item_path = '');" run-id)
    res))




(define (db:get-running-stats db)
  (let ((res '()))
    (sqlite3:for-each-row



     (lambda (state count)
       (set! res (cons (list state count) res)))

     db
     "SELECT state,count(id) FROM tests GROUP BY state ORDER BY id DESC;")
    res))

(define (db:get-count-tests-running-in-jobgroup db jobgroup)


  (if (not jobgroup)
      0 ;; 
      (let ((res 0))


	(sqlite3:for-each-row
	 (lambda (count)
	   (set! res count))
	 db











	 "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART')




             AND testname in (SELECT testname FROM test_meta WHERE jobgroup=?)
             AND NOT (uname = 'n/a' AND item_path = '');"
	 jobgroup)
	res)))

;; done with run when:
;;   0 tests in LAUNCHED, NOT_STARTED, REMOTEHOSTSTART, RUNNING
(define (db:estimated-tests-remaining db run-id)
  (let ((res 0))
    (sqlite3:for-each-row


     (lambda (count)
       (set! res count))
     db ;; NB// KILLREQ means the jobs is still probably running

     "SELECT count(id) FROM tests WHERE state in ('LAUNCHED','NOT_STARTED','REMOTEHOSTSTART','RUNNING','KILLREQ') AND run_id=?;" run-id)
    res))

;; map run-id, testname item-path to test-id
(define (db:get-test-id-cached db run-id testname item-path)









  (let* ((test-key (conc run-id "-" testname "-" item-path))
	 (res      (hash-table-ref/default *test-ids* test-key #f)))

    (if res 



	res
	(begin


	  (sqlite3:for-each-row

	   (lambda (id) ;;  run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment )
	     (set! res id)) ;; (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment )))







	   db 
	   "SELECT id FROM tests WHERE run_id=? AND testname=? AND item_path=?;"


	   run-id testname item-path)



	  (hash-table-set! *test-ids* test-key res)













	  res))))


;; map run-id, testname item-path to test-id


(define (db:get-test-id-not-cached db run-id testname item-path)




  (let* ((res #f))

    (sqlite3:for-each-row
     (lambda (id) ;;  run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment )

       (set! res id)) ;; (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment )))

     db 
     "SELECT id FROM tests WHERE run_id=? AND testname=? AND item_path=?;"
     run-id testname item-path)
    res))

(define db:get-test-id db:get-test-id-not-cached)

;; given a test-info record, patch in the latest data from the testdat.db file













;; found in the test run directory

;;
;; NOT USED
;;
(define (db:patch-tdb-data-into-test-info db test-id res #!key (work-area #f))
  (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)))
    ;; get state and status from megatest.db in real time
    ;; other fields that perhaps should be updated:

    ;;   fail_count
    ;;   pass_count
    ;;   final_logf
    (sqlite3:for-each-row
     (lambda (state status final_logf)
       (db:test-set-state!        res state)
       (db:test-set-status!       res status)
       (db:test-set-final_logf!   res final_logf))
     db
     "SELECT state,status,final_logf FROM tests WHERE id=?;"
     test-id)

    (if tdb

	(begin








	  (sqlite3:for-each-row
	   (lambda (update_time cpuload disk_free run_duration)
	     (db:test-set-cpuload!      res cpuload)
	     (db:test-set-diskfree!     res disk_free)
	     (db:test-set-run_duration! res run_duration))
	   tdb
	   "SELECT update_time,cpuload,diskfree,run_duration FROM test_rundat ORDER BY id DESC LIMIT 1;")
	  (sqlite3:finalize! tdb))
	;; if the test db is not found what to do?

	;; 1. set state to DELETED

	;; 2. set status to n/a
	(begin




	  (db:test-set-state!  res "NOT_STARTED")


	  (db:test-set-status! res "n/a")))))


(define *last-test-cache-delete* (current-seconds))

(define (db:clean-all-caches)







  (set! *test-info* (make-hash-table))
  (set! *test-id-cache* (make-hash-table)))

;; Use db:test-get* to access

;;
;; Get test data using test_id
(define (db:get-test-info-by-id db test-id)

  (if (not test-id)
      (begin
	(debug:print-info 4 "db:get-test-info-by-id called with test-id=" test-id)
	#f)

      (let ((res #f))
	(sqlite3:for-each-row
	 (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment)
	   ;;                 0    1       2      3      4        5       6      7        8     9     10      11          12          13       14





	   (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment)))










	 db 



	 "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment FROM tests WHERE id=?;"










	 test-id)
	res)))

















;; Use db:test-get* to access
;;
;; Get test data using test_ids
(define (db:get-test-info-by-ids db test-ids)











  (if (null? test-ids)

      (begin
	(debug:print-info 4 "db:get-test-info-by-ids called with test-ids=" test-ids)

	'())




      (let ((res '()))
	(sqlite3:for-each-row
	 (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment)
	   ;;                 0    1       2      3      4        5       6      7        8     9     10      11          12          13       14
	   (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment)
			   res)))
	 db 
	 (conc "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment FROM tests WHERE id in ("
	       (string-intersperse (map conc test-ids) ",") ");"))
	res)))

(define (db:get-test-info db run-id testname item-path)
  (db:get-test-info-by-id db (db:get-test-id db run-id testname item-path)))









(define (db:test-set-comment db test-id comment)




  (db:delay-if-busy)
  (sqlite3:execute 



   db
   "UPDATE tests SET comment=? WHERE id=?;"


   comment test-id))

(define (cdb:test-set-rundir! serverdat run-id test-name item-path rundir)
  (cdb:client-call serverdat 'test-set-rundir #t *default-numtries* rundir run-id test-name item-path))




(define (cdb:test-set-rundir-by-test-id serverdat test-id rundir)
  (cdb:client-call serverdat 'test-set-rundir-by-test-id #t *default-numtries* rundir test-id))



























(define (db:test-get-rundir-from-test-id db test-id)
  (let ((res #f)) ;; (hash-table-ref/default *test-paths* test-id #f)))
    ;; (if res
    ;;     res
    ;;     (begin
    (sqlite3:for-each-row
     (lambda (tpath)

       (set! res tpath))
     db 
     "SELECT rundir FROM tests WHERE id=?;"
     test-id)
    ;; (hash-table-set! *test-paths* test-id res)
    res)) ;; ))






















(define (cdb:test-set-log! serverdat test-id logf)
  (if (string? logf)(cdb:client-call serverdat 'test-set-log #f *default-numtries* logf test-id)))


;;======================================================================
;; Misc. test related queries
;;======================================================================

;; MUST BE CALLED local!
(define (db:test-get-paths-matching db keynames target fnamepatt #!key (res '()))
  ;; BUG: Move the values derived from args to parameters and push to megatest.scm
  (let* ((testpatt   (if (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%"))
	 (statepatt  (or (args:get-arg "-state")   (args:get-arg ":state")    "%"))
	 (statuspatt (or (args:get-arg "-status")  (args:get-arg ":status")   "%"))
	 (runname    (or (args:get-arg "-runname") (args:get-arg ":runname")  "%"))
	 (paths-from-db (cdb:remote-run db:test-get-paths-matching-keynames-target-new db keynames target res
					testpatt:   testpatt
					statepatt:  statepatt
					statuspatt: statuspatt
					runname:    runname)))
    (if fnamepatt
	(apply append 
	       (map (lambda (p)
		      (if (directory-exists? p)
			  (glob (conc p "/" fnamepatt))
			  '()))
		    paths-from-db))
	paths-from-db)))

(define (db:test-get-paths-matching-keynames-target db keynames target res 
						    #!key
						    (testpatt   "%")
						    (statepatt  "%")
						    (statuspatt "%")
						    (runname    "%"))
  (let* ((keystr (string-intersperse 
		  (map (lambda (key val)
			 (conc "r." key " like '" val "'"))
		       keynames 
		       (string-split target "/"))
		  " AND "))
	 (testqry (tests:match->sqlqry testpatt))
	 (qrystr (conc "SELECT t.rundir FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id WHERE "
		       keystr " AND r.runname LIKE '" runname "' AND " testqry
		       " AND t.state LIKE '" statepatt "' AND t.status LIKE '" statuspatt 
		       "' ORDER BY t.event_time ASC;")))
    (sqlite3:for-each-row 
     (lambda (p)
       (set! res (cons p res)))
     db 
     qrystr)
    res))

(define (db:test-get-paths-matching-keynames-target-new db keynames target res 
							#!key
							(testpatt   "%")
							(statepatt  "%")
							(statuspatt "%")
							(runname    "%"))
  (let* ((row-ids '())
	 (keystr (string-intersperse 
		  (map (lambda (key val)
			 (conc key " like '" val "'"))
		       keynames 
		       (string-split target "/"))
		  " AND "))
	 (testqry (tests:match->sqlqry testpatt))
	 (runsqry (sqlite3:prepare db (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';")))
	 (tstsqry (sqlite3:prepare db (conc "SELECT rundir FROM tests WHERE run_id=? AND " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;"))))

    (sqlite3:for-each-row
     (lambda (rid)
       (set! row-ids (cons rid row-ids)))
     runsqry)
    (for-each (lambda (rid)
		(sqlite3:for-each-row 
		 (lambda (p)
		   (set! res (cons p res)))
		 tstsqry rid))
	      row-ids)
    (sqlite3:finalize! tstsqry)
    (sqlite3:finalize! runsqry)
    res))

;; look through tests from matching runs for a file
(define (db:test-get-first-path-matching db keynames target fname)
  ;; [refpaths] is the section where references to other megatest databases are stored
  (let ((mt-paths (configf:get-section "refpaths"))
	(res       (db:test-get-paths-matching db keynames target fname)))
    (let loop ((pathdat (if (null? paths) #f (car mt-paths)))
	       (tal     (if (null? paths) '()(cdr mt-paths))))
      (if (not (null? res))
	  (car res) ;; return first found
	  (if path
	      (let* ((db     (open-db path: (cadr pathdat)))
		     (newres (db:test-get-paths-matching db keynames target fname)))
		(debug:print-info 4 "Trying " (car pathdat) " at " (cadr pathdat))
		(sqlite3:finalize! db)
		(if (not (null? newres))
		    (car newres)
		    (if (null? tal)
			#f
			(loop (car tal)(cdr tal))))))))))

(define (db:test-toplevel-num-items db run-id testname)
  (let ((res 0))
    (sqlite3:for-each-row
     (lambda (num-items)
       (set! res num-items))
     db
     "SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND state NOT IN ('DELETED');"
     run-id






















     testname)
    res))

;;======================================================================
;; QUEUE UP META, TEST STATUS AND STEPS REMOTE ACCESS
;;======================================================================

;; NOTE: Can remove the regex and base64 encoding for zmq
(define (db:obj->string obj)
  (case *transport-type*
    ((fs) obj)
    ((http)
     (string-substitute
      (regexp "=") "_"
      (base64:base64-encode (with-output-to-string (lambda ()(serialize obj))))



      #t))
    ((zmq)(with-output-to-string (lambda ()(serialize obj))))
    (else obj)))

(define (db:string->obj msg)
  (case *transport-type*
    ((fs) msg)
    ((http)
     (if (string? msg)
	 (with-input-from-string 

	     (base64:base64-decode
	      (string-substitute 
	       (regexp "_") "=" msg #t))
	   (lambda ()(deserialize)))


	 (vector #f #f #f))) ;; crude reply for when things go awry
    ((zmq)(with-input-from-string msg (lambda ()(deserialize))))
    (else msg)))

(define (cdb:use-non-blocking-mode proc)
  (set! *client-non-blocking-mode* #t)
  (let ((res (proc)))
    (set! *client-non-blocking-mode* #f)
    res))

;; params = 'target cached remparams
;;
;; make-vector-record cdb packet client-sig qtype immediate query-sig params qtime
;;
;; cdb:client-call is the unified interface to all the transports. It dispatches the
;;                 query to a server routine (e.g. server:client-send-recieve) that 
;;                 transports the data to the server where it is passed to db:process-queue-item
;;                 which either returns the data to the calling server routine or 
;;                 directly calls the returning procedure (e.g. zmq).
;;
(define (cdb:client-call serverdat qtype immediate numretries . params)
  (debug:print-info 11 "cdb:client-call serverdat=" serverdat ", qtype=" qtype ", immediate=" immediate ", numretries=" numretries ", params=" params)
  (case *transport-type* 
    ((fs)
     (let ((packet (vector "na" qtype immediate "na" params 0)))
       (fs:process-queue-item packet)))
    ((http)
     (let* ((client-sig  (client:get-signature))
	    (query-sig   (message-digest-string (md5-primitive) (conc qtype immediate params)))
	    (zdat        (db:obj->string (vector client-sig qtype immediate query-sig params (current-seconds))))) ;; (with-output-to-string (lambda ()(serialize params))))
       (debug:print-info 11 "zdat=" zdat)
       (let* ((res  #f)
	      (rawdat      (http-transport:client-send-receive serverdat zdat))
	      (tmp         #f))
	 (debug:print-info 11 "Sent " zdat ", received " rawdat)

	 (if rawdat
	     (begin
	       (set! tmp (db:string->obj rawdat))
	       (vector-ref tmp 2))
	     (begin
	       (debug:print 0 "ERROR: Communication with the server failed. Exiting if possible")

	       (exit 1))))))
    ((zmq)
     (handle-exceptions
      exn
      (begin
	(debug:print-info 0 "cdb:client-call timeout or error. Trying again in 5 seconds")
	(thread-sleep! 5) 
	(if (> numretries 0)(apply cdb:client-call serverdat qtype immediate (- numretries 1) params)))
      (let* ((push-socket (vector-ref serverdat 0))
	     (sub-socket  (vector-ref serverdat 1))
	     (client-sig  (client:get-signature))
	     (query-sig   (message-digest-string (md5-primitive) (conc qtype immediate params)))
	     (zdat        (db:obj->string (vector client-sig qtype immediate query-sig params (current-seconds)))) ;; (with-output-to-string (lambda ()(serialize params))))
	     (res  #f)
	     (send-receive (lambda ()
			     (debug:print-info 11 "sending message")
			     (send-message push-socket zdat)
			     (debug:print-info 11 "message sent")
			     (let loop ()
			       ;; get the sender info
			       ;; this should match (client:get-signature)
			       ;; we will need to process "all" messages here some day
			       (receive-message* sub-socket)
			       ;; now get the actual message
			       (let ((myres (db:string->obj (receive-message* sub-socket))))
				 (if (equal? query-sig (vector-ref myres 1))
				     (set! res (vector-ref myres 2))
				     (loop)))))))
	;; (timeout (lambda ()
	;;     	(let loop ((n numretries))
	;;     	  (thread-sleep! 15)
	;;     	  (if (not res)
	;;     	      (if (> numretries 0)
	;;     		  (begin
	;;     		    (debug:print 2 "WARNING: no reply to query " params ", trying resend")
	;;     		    (debug:print-info 11 "re-sending message")
	;;     		    (send-message push-socket zdat)
	;;     		    (debug:print-info 11 "message re-sent")
	;;     		    (loop (- n 1)))
	;;     		  ;; (apply cdb:client-call *runremote* qtype immediate (- numretries 1) params))
	;;     		  (begin
	;;     		    (debug:print 0 "ERROR: cdb:client-call timed out " params ", exiting.")
	;;     		    (exit 5))))))))
	(debug:print-info 11 "Starting threads")
	(let ((th1 (make-thread send-receive "send receive"))
	      ;; (th2 (make-thread timeout      "timeout"))
	      )





	  (thread-start! th1)

	  ;; (thread-start! th2)
	  (thread-join!  th1)
	  (debug:print-info 11 "cdb:client-call returning res=" res)
	  res))))))



(define (cdb:set-verbosity serverdat val)
  (cdb:client-call serverdat 'set-verbosity #f *default-numtries* val))

(define (cdb:login serverdat keyval signature)
  (cdb:client-call serverdat 'login #t *default-numtries* keyval megatest-version signature))

(define (cdb:logout serverdat keyval signature)
  (cdb:client-call serverdat 'logout #t *default-numtries* keyval signature))

(define (cdb:num-clients serverdat)
  (cdb:client-call serverdat 'numclients #t *default-numtries*))

;; I think this would be more efficient if executed on client side FIXME???
(define (cdb:test-set-status-state serverdat test-id status state msg)
  (if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
      (cdb:client-call serverdat 'set-test-start-time #t *default-numtries* test-id))
  (if msg
      (cdb:client-call serverdat 'state-status-msg #t *default-numtries* state status msg test-id)
      (cdb:client-call serverdat 'state-status #t *default-numtries* state status test-id))) ;; run-id test-name item-path minutes cpuload diskfree tmpfree) 

(define (cdb:test-rollup-test_data-pass-fail serverdat test-id)
  (cdb:client-call serverdat 'test_data-pf-rollup #t *default-numtries* test-id test-id test-id test-id))

(define (cdb:pass-fail-counts serverdat test-id fail-count pass-count)
  (cdb:client-call serverdat 'pass-fail-counts #t *default-numtries* fail-count pass-count test-id))

(define (cdb:tests-register-test serverdat run-id test-name item-path)
  (cdb:client-call serverdat 'register-test #t *default-numtries* run-id test-name item-path))

;; more transactioned calls, these for roll-up-pass-fail stuff
(define (cdb:update-pass-fail-counts serverdat run-id test-name)
  (cdb:client-call serverdat 'update-fail-pass-counts #t *default-numtries* run-id test-name run-id test-name run-id test-name))

(define (cdb:top-test-set-running serverdat run-id test-name)
  (cdb:client-call serverdat 'top-test-set-running #t *default-numtries* run-id test-name))

(define (cdb:top-test-set-per-pf-counts serverdat run-id test-name)
  (cdb:client-call serverdat 'top-test-set-per-pf-counts #t *default-numtries* run-id test-name run-id test-name run-id test-name run-id test-name))

;;=

(define (cdb:flush-queue serverdat)
  (cdb:client-call serverdat 'flush #f *default-numtries*))

(define (cdb:kill-server serverdat pid)
  (cdb:client-call serverdat 'killserver #t *default-numtries* pid))

(define (cdb:roll-up-pass-fail-counts serverdat run-id test-name item-path status)
  (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:roll-up-pass-fail-counts #f run-id test-name item-path status))

(define (cdb:get-test-info serverdat run-id test-name item-path)
  (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:get-test-info #f run-id test-name item-path))

(define (cdb:get-test-info-by-id serverdat test-id)
  (let ((test-dat (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:get-test-info-by-id #f test-id)))
    (hash-table-set! *test-info* test-id (vector (current-seconds) test-dat)) ;; cached for use where up-to-date info is not needed
    test-dat))

;; db should be db open proc or #f
(define (cdb:remote-run proc db . params)
  (if (or *db-write-access*
	  (not (member proc *db:all-write-procs*)))
      (handle-exceptions
       exn
       (let ((sleep-time (random 20))
	     (err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
	 (case err-status
	   ((busy)(thread-sleep! 4))
	   (else
	    (debug:print 0 "WARNING: possible problem with call to cdb:remote-run, database may be read-only and locked, waiting and trying again ...")
	    (thread-sleep! sleep-time)))
	 (apply cdb:remote-run proc db params))
       (apply cdb:client-call *runremote* 'immediate #f *default-numtries* open-run-close proc #f params))
      (begin
	(debug:print 0 "ERROR: Attempt to access read-only database")
	#f)))

(define (db:test-get-logfile-info db run-id test-name)
  (let ((res #f))
    (sqlite3:for-each-row 
     (lambda (path final_logf)


       (set! logf final_logf)
       (set! res (list path final_logf))
       (if (directory? path)
	   (debug:print 2 "Found path: " path)
	   (debug:print 2 "No such path: " path)))
     db
     "SELECT rundir,final_logf FROM tests WHERE run_id=? AND testname=? AND item_path='';"
     run-id test-name)
    res))

;;======================================================================
;; A G R E G A T E D   T R A N S A C T I O N   D B   W R I T E S 
;;======================================================================

(define db:queries 



  (list '(register-test          "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');")
	;; Test state and status
	'(set-test-state         "UPDATE tests SET state=?   WHERE id=?;")
	'(set-test-status        "UPDATE tests SET state=?   WHERE id=?;")
	'(state-status           "UPDATE tests SET state=?,status=? WHERE id=?;")
	'(state-status-msg       "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;")
	;; Test comment
	'(set-test-comment       "UPDATE tests SET comment=? WHERE id=?;")
	'(set-test-start-time    "UPDATE tests SET event_time=strftime('%s','now') WHERE id=?;")
	'(pass-fail-counts       "UPDATE tests SET fail_count=?,pass_count=? WHERE id=?;")
	;; test_data-pf-rollup is used to set a tests PASS/FAIL based on the pass/fail info from the steps
	'(test_data-pf-rollup    "UPDATE tests
                                    SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 
                                      THEN 'FAIL'
                                    WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND 
                                      (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL')
                                    THEN 'PASS'
                                    ELSE status
                                    END WHERE id=?;")
	'(test-set-log            "UPDATE tests SET final_logf=? WHERE id=?;")
	'(test-set-rundir-by-test-id "UPDATE tests SET rundir=? WHERE id=?")
	'(test-set-rundir         "UPDATE tests SET rundir=? WHERE run_id=? AND testname=? AND item_path=?;")

	'(delete-tests-in-state   "DELETE FROM tests WHERE state=? AND run_id=?;")

	'(tests:test-set-toplog   "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';")
	'(update-cpuload-diskfree "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;")
	'(update-run-duration     "UPDATE tests SET run_duration=? WHERE id=?;")
	'(update-uname-host       "UPDATE tests SET uname=?,host=? WHERE id=?;")
	'(update-test-state       "UPDATE tests SET state=? WHERE state=? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")
	'(update-test-status      "UPDATE tests SET status=? WHERE status like ? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")
	;; stuff for roll-up-pass-fail-counts
	'(update-fail-pass-counts "UPDATE tests 
             SET fail_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status IN ('FAIL','CHECK')),
                 pass_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED'))
             WHERE run_id=? AND testname=? AND item_path='';")

	'(top-test-set-running  "UPDATE tests SET state='RUNNING' WHERE run_id=? AND testname=? AND item_path='';")
	'(top-test-set-per-pf-counts "UPDATE tests
                       SET state=CASE 
                                   WHEN (SELECT count(id) FROM tests 
                                                WHERE run_id=? AND testname=?
                                                     AND item_path != '' 
                                                     AND status NOT IN ('TEN_STRIKES','BLOCKED')
                                                     AND state in ('RUNNING','NOT_STARTED','LAUNCHED','REMOTEHOSTSTART')) > 0 THEN 'RUNNING'
                                   ELSE 'COMPLETED' END,
                            status=CASE 
                                  WHEN (SELECT count(id) FROM tests
                                         WHERE run_id=? AND testname=?
                                              AND item_path != ''
                                              AND state IN ('NOT_STARTED','BLOCKED')) > 0 THEN 'FAIL'
                                  WHEN fail_count > 0 THEN 'FAIL' 
                                  WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' 
                                  WHEN (SELECT count(id) FROM tests
                                         WHERE run_id=? AND testname=?
                                              AND item_path != ''
                                              AND status = 'SKIP') > 0 THEN 'SKIP'
                                  ELSE 'UNKNOWN' END
                       WHERE run_id=? AND testname=? AND item_path='';")




	))





;; do not run these as part of the transaction
(define db:special-queries   '(rollup-tests-pass-fail
			       ;; db:roll-up-pass-fail-counts  ;; WHY NOT!?
			       login
			       immediate
			       flush
			       sync
			       set-verbosity
			       killserver
			       ))



;; not used, intended to indicate to run in calling process
(define db:run-local-queries '()) ;; rollup-tests-pass-fail))









(define (db:process-cached-writes db)



  (let ((queries    (make-hash-table))
	(data       #f))
    (mutex-lock! *incoming-mutex*)

    ;; data is a list of query packets <vector qry-sig query params
    (set! data (reverse *incoming-writes*)) ;;  (sort ... (lambda (a b)(< (vector-ref a 1)(vector-ref b 1)))))
    (set! *server:last-write-flush* (current-milliseconds))
    (set! *incoming-writes* '())
    (mutex-unlock! *incoming-mutex*)
    (if (> (length data) 0)
	;; Process if we have data
	(begin
	  (debug:print-info 7 "Writing cached data " data)

	  



	  ;; Prepare the needed sql statements

	  ;;
	  (for-each (lambda (request-item)

		      (let ((stmt-key (vector-ref request-item 0))
			    (query    (vector-ref request-item 1)))
			(hash-table-set! queries stmt-key (sqlite3:prepare db query))))


		    data)
	  
	  ;; No outer loop needed. Single loop for write items only. Reads trigger flush of queue
	  ;; and then are executed.


	  (sqlite3:with-transaction 


	   db
	   (lambda ()
	     (for-each
	      (lambda (hed)
		(let* ((params   (vector-ref hed 2))
		       (stmt-key (vector-ref hed 0))
		       (stmt     (hash-table-ref/default queries stmt-key #f)))
		  (if stmt
		      (begin
			(db:delay-if-busy)
			(apply sqlite3:execute stmt params))
		      (debug:print 0 "ERROR: Problem Executing " stmt-key " for " params))))
	      data)))
	  
	  ;; let all the waiting calls know all is done
	  (mutex-lock! *completed-mutex*)
	  (for-each (lambda (item)
		      (let ((qry-sig (cdb:packet-get-client-sig item)))
			(debug:print-info 7 "Registering query " qry-sig " as done")
			(hash-table-set! *completed-writes* qry-sig #t)))
		    data)
	  (mutex-unlock! *completed-mutex*)
	  
	  ;; Finalize the statements. Should this be done inside the mutex above?
	  ;; I think sqlite3 mutexes will keep the data safe
	  (for-each (lambda (stmt-key)
		      (sqlite3:finalize! (hash-table-ref queries stmt-key)))
		    (hash-table-keys queries))
	  
	  ;; Do a little record keeping

	  (let ((cache-size (length data)))
	    (if (> cache-size *max-cache-size*)

		(set! *max-cache-size* cache-size)))
	  #t)
	#f)))

(define *db:process-queue-mutex* (make-mutex))

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

;; The queue is a list of vectors where the zeroth slot indicates the type of query to
;; apply and the second slot is the time of the query and the third entry is a list of 
;; values to be applied
;;

(define (db:queue-write-and-wait db qry-sig query params)
  (let ((queue-len  0)
	(res        #f)
	(got-it     #f)
	(qry-pkt    (vector qry-sig query params))
	(start-time (current-milliseconds))
	(timeout    (+ 10 (current-seconds)))) ;; set the time out to 10 secs in future

    ;; Put the item in the queue *incoming-writes* 
    (mutex-lock! *incoming-mutex*)




    (set! *incoming-writes* (cons qry-pkt *incoming-writes*))
    (set! queue-len (length *incoming-writes*))
    (mutex-unlock! *incoming-mutex*)

    (debug:print-info 7 "Current write queue length is " queue-len)

    ;; poll for the write to complete, timeout after 10 seconds
    ;; periodic flushing of the queue is taken care of by 


    ;; db:flush-queue
    (let loop ()
      (thread-sleep! 0.001)
      (mutex-lock! *completed-mutex*)


      (if (hash-table-ref/default *completed-writes* qry-sig #f)
	  (begin
	    (hash-table-delete! *completed-writes* qry-sig)
	    (set! got-it #t)))
      (mutex-unlock! *completed-mutex*)
      (if (and (not got-it)
	       (< (current-seconds) timeout))
	  (begin

	    (thread-sleep! 0.01)
	    (loop))))
    (set! *number-of-writes*   (+ *number-of-writes*   1))
    (set! *writes-total-delay* (+ *writes-total-delay* (- (current-milliseconds) start-time)))
    got-it))

(define (db:delay-if-busy #!key (count 6))
  (let ((dbfj (conc *toppath* "/megatest.db-journal")))
    (if (file-exists? dbfj)
	(case count
	  ((6)
	   (thread-sleep! 0.2)
	   (db:delay-if-busy count: 5))
	  ((5)
	   (thread-sleep! 0.4)
	   (db:delay-if-busy count: 4))
	  ((4)
	   (thread-sleep! 0.8)
	   (db:delay-if-busy count: 3))
	  ((3)
	   (thread-sleep! 1.6)
	   (db:delay-if-busy count: 2))
	  ((2)
	   (thread-sleep! 3.2)
	   (db:delay-if-busy count: 1))
	  ((1)
	   (thread-sleep! 6.4)
	   (db:delay-if-busy count: 0))
	  (else
	   (debug:print-info 0 "delaying db access due to high database load.")
	   (thread-sleep! 12.8))))))

(define (db:process-queue-item db item)
  (let* ((stmt-key       (cdb:packet-get-qtype item))
	 (qry-sig        (cdb:packet-get-query-sig item))
	 (return-address (cdb:packet-get-client-sig item))
	 (params         (cdb:packet-get-params item))
	 (query          (let ((q (alist-ref stmt-key db:queries)))
			   (if q (car q) #f))))
    (debug:print-info 11 "Special queries/requests stmt-key=" stmt-key ", return-address=" return-address ", query=" query ", params=" params)
    (if query
	;; hand queries off to the write queue
	(let ((response (case *transport-type*
			  ((http)
			   (debug:print-info 7 "Queuing item " item " for wrapped write")
			   (db:queue-write-and-wait db qry-sig query params))
			  (else 
			   (let* ((remtries 10)
				  (proc     #f))
			     (set! proc (lambda (remtries)
					  (if (> remtries 0)
					      (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)
						    (proc 10)) ;; we never give up on busy
						   (else
						    (debug:print 0 "EXCEPTION: database probably overloaded or unreadable.")
						    (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
						    (debug:print 0 " status:  " ((condition-property-accessor 'sqlite3 'status)  exn))
						    (print-call-chain)
						    (debug:print 0 "Sleeping for " sleep-time)
						    (thread-sleep! sleep-time)
						    (debug:print-info 0 "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up")
						    (proc (- remtries 1)))))
					       (begin
						 (db:delay-if-busy)
						 (apply sqlite3:execute db query params)))
					      (debug:print 0 "ERROR: too many attempts to access db were made and no sucess. query: "
							   query ", params: " params))))
			     (proc remtries))
			   #t))))
	  (debug:print-info 7 "Received " response " from wrapped write")
	  (server:reply return-address qry-sig response response))
	;; otherwise if appropriate flush the queue (this is a read or complex query)
	(begin
	  (cond
	   ((member stmt-key db:special-queries)
	    (let ((starttime (current-milliseconds)))
	      (debug:print-info 9 "Handling special statement " stmt-key)
	      (case stmt-key
		((immediate)
		 ;; This is a read or mixed read-write query, must clear the cache
		 (case *transport-type*
		   ((http)
		    (mutex-lock! *db:process-queue-mutex*)
		    (db:process-cached-writes db)
		    (mutex-unlock! *db:process-queue-mutex*)))
		 (let* ((proc      (car params))
			(remparams (cdr params))
			;; we are being handed a procedure so call it
			;; (debug:print-info 11 "Running (apply " proc " " remparams ")")
			(result (server:reply return-address qry-sig #t (apply proc remparams))))
		   (set! *total-non-write-delay* (+ *total-non-write-delay* (- (current-milliseconds) starttime))) 
		   (set! *number-non-write-queries* (+ *number-non-write-queries* 1))
		   result))
		((login)
		 (if (< (length params) 3) ;; should get toppath, version and signature
		     (server:reply return-address qry-sig '(#f "login failed due to missing params")) ;; missing params
		     (let ((calling-path (car   params))
			   (calling-vers (cadr  params))
			   (client-key   (caddr params)))
		       (if (and (equal? calling-path *toppath*)
				(equal? megatest-version calling-vers))
			   (begin
			     (hash-table-set! *logged-in-clients* client-key (current-seconds))
			     (server:reply return-address qry-sig #t '(#t "successful login")))      ;; path matches - pass! Should vet the caller at this time ...
			   (server:reply return-address qry-sig #f (list #f (conc "Login failed due to mismatch paths: " calling-path ", " *toppath*)))))))
		((flush sync)
		 (server:reply return-address qry-sig #t 1)) ;; (length data)))
		((set-verbosity)
		 (set! *verbosity* (car params))
		 (server:reply return-address qry-sig #t (list #t *verbosity*)))
		((killserver)
		 (let ((hostname (car  *runremote*))
		       (port     (cadr *runremote*))
		       (pid      (car params)))
		   (debug:print 0 "WARNING: Server on " hostname ":" port " going down by user request!")
		   (debug:print-info 1 "current pid=" (current-process-id))
		   (open-run-close tasks:server-deregister tasks:open-db 
				   hostname
				   port: port)
		   (set! *server-run* #f)
		   (thread-sleep! 3)
		   (process-signal pid signal/kill)
		   (server:reply return-address qry-sig #t '(#t "exit process started"))))
		(else ;; not a command, i.e. is a query
		 (debug:print 0 "ERROR: Unrecognised query/command " stmt-key)
		 (server:reply return-address qry-sig #f 'failed)))))
	   (else
	    (debug:print-info 11 "Executing " stmt-key " for " params)
	    (db:delay-if-busy)
	    (apply sqlite3:execute (hash-table-ref queries stmt-key) params)
	    (server:reply return-address qry-sig #t #t)))))))

(define (db:test-get-records-for-index-file db run-id test-name)
  (let ((res '()))





    (sqlite3:for-each-row 
     (lambda (id itempath state status run_duration logf comment)
       (set! res (cons (vector id itempath state status run_duration logf comment) res)))
     db
     "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE run_id=? AND testname=? AND item_path != '';"
     run-id test-name)
    res))

;;======================================================================
;; Tests meta data
;;======================================================================

;; read the record given a testname
(define (db:testmeta-get-record db testname)
  (let ((res #f))





    (sqlite3:for-each-row
     (lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup)
       (set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup)))

     db "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE testname=?;"
     testname)
    res))

;; create a new record for a given testname
(define (db:testmeta-add-record db testname)

  (db:delay-if-busy)


  (sqlite3:execute db "INSERT OR IGNORE INTO test_meta (testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags) VALUES (?,'','','','','','','','');" testname))

;; update one of the testmeta fields
(define (db:testmeta-update-field db testname field value)
  (db:delay-if-busy)
  (sqlite3:execute db (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname))

;;======================================================================
;; T E S T   D A T A 
;;======================================================================

(define (db:csv->test-data db test-id csvdata #!key (work-area #f))
  (debug:print 4 "test-id " test-id ", csvdata: " csvdata)
  (let ((tdb     (db:open-test-db-by-test-id db test-id work-area: work-area)))
    (if (sqlite3:database? tdb)
	(let ((csvlist (csv->list (make-csv-reader
				   (open-input-string csvdata)
				   '((strip-leading-whitespace? #t)
				     (strip-trailing-whitespace? #t)) )))) ;; (csv->list csvdata)))
	  (for-each 
	   (lambda (csvrow)
	     (let* ((padded-row  (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9))
		    (category    (list-ref padded-row 0))
		    (variable    (list-ref padded-row 1))
		    (value       (any->number-if-possible (list-ref padded-row 2)))
		    (expected    (any->number-if-possible (list-ref padded-row 3)))
		    (tol         (any->number-if-possible (list-ref padded-row 4))) ;; >, <, >=, <=, or a number
		    (units       (list-ref padded-row 5))
		    (comment     (list-ref padded-row 6))
		    (status      (let ((s (list-ref padded-row 7)))
				   (if (and (string? s)(or (string-match (regexp "^\\s*$") s)
							   (string-match (regexp "^n/a$") s)))
				       #f
				       s))) ;; if specified on the input then use, else calculate
		    (type        (list-ref padded-row 8)))
	       ;; look up expected,tol,units from previous best fit test if they are all either #f or ''
	       (debug:print 4 "BEFORE: category: " category " variable: " variable " value: " value 
			    ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment " type: " type)

	       (if (and (or (not expected)(equal? expected ""))
			(or (not tol)     (equal? expected ""))
			(or (not units)   (equal? expected "")))
		   (let-values (((new-expected new-tol new-units)(db:get-prev-tol-for-test db test-id category variable)))
			       (set! expected new-expected)
			       (set! tol      new-tol)
			       (set! units    new-units)))

	       (debug:print 4 "AFTER:  category: " category " variable: " variable " value: " value 
			    ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment)
	       ;; calculate status if NOT specified
	       (if (and (not status)(number? expected)(number? value)) ;; need expected and value to be numbers
		   (if (number? tol) ;; if tol is a number then we do the standard comparison
		       (let* ((max-val (+ expected tol))
			      (min-val (- expected tol))
			      (result  (and (>=  value min-val)(<= value max-val))))
			 (debug:print 4 "max-val: " max-val " min-val: " min-val " result: " result)
			 (set! status (if result "pass" "fail")))
		       (set! status ;; NB// need to assess each one (i.e. not return operator since need to act if not valid op.
			     (case (string->symbol tol) ;; tol should be >, <, >=, <=
			       ((>)  (if (>  value expected) "pass" "fail"))
			       ((<)  (if (<  value expected) "pass" "fail"))
			       ((>=) (if (>= value expected) "pass" "fail"))
			       ((<=) (if (<= value expected) "pass" "fail"))
			       (else (conc "ERROR: bad tol comparator " tol))))))
	       (debug:print 4 "AFTER2: category: " category " variable: " variable " value: " value 
			    ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment)
	       (sqlite3:execute tdb "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);"
				test-id category variable value expected tol units (if comment comment "") status type)))
	   csvlist)
	  (sqlite3:finalize! tdb)))))

;; get a list of test_data records matching categorypatt
(define (db:read-test-data db test-id categorypatt #!key (work-area #f))
  (let ((tdb  (db:open-test-db-by-test-id db test-id work-area: work-area)))
    (if (sqlite3:database? tdb)
	(let ((res '()))
	  (sqlite3:for-each-row 
	   (lambda (id test_id category variable value expected tol units comment status type)
	     (set! res (cons (vector id test_id category variable value expected tol units comment status type) res)))
	   tdb
	   "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt)
	  (sqlite3:finalize! tdb)
	  (reverse res))
	'())))

;; NOTE: Run this local with #f for db !!!
(define (db:load-test-data db test-id #!key (work-area #f))
  (let loop ((lin (read-line)))
    (if (not (eof-object? lin))
	(begin
	  (debug:print 4 lin)
	  (db:csv->test-data db test-id lin work-area: work-area)
	  (loop (read-line)))))
  ;; roll up the current results.
  ;; FIXME: Add the status to 
  (db:test-data-rollup db test-id #f work-area: work-area))

;; WARNING: Do NOT call this for the parent test on an iterated test
;; Roll up test_data pass/fail results
;; look at the test_data status field, 
;;    if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS.
;;    if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored
(define (db:test-data-rollup db test-id status #!key (work-area #f))
  (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))
	(fail-count 0)
	(pass-count 0))
    (if (sqlite3:database? tdb)
	(begin
	  (sqlite3:for-each-row
	   (lambda (fcount pcount)
	     (set! fail-count fcount)
	     (set! pass-count pcount))
	   tdb 
	   "SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count,
                   (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'pass') AS pass_count;"
	   test-id test-id)
	  (sqlite3:finalize! tdb)

	  ;; Now rollup the counts to the central megatest.db
	  (cdb:pass-fail-counts *runremote* test-id fail-count pass-count)
	  ;; (sqlite3:execute db "UPDATE tests SET fail_count=?,pass_count=? WHERE id=?;" 
	  ;;                     fail-count pass-count test-id)

	  ;; The flush is not needed with the transaction based write agregation enabled. Remove these commented lines
	  ;; next time you read this!
	  ;;
	  ;; (cdb:flush-queue *runremote*)
	  ;; (thread-sleep! 1) ;; play nice with the queue by ensuring the rollup is at least 10ms later than the set
	  
	  ;; if the test is not FAIL then set status based on the fail and pass counts.
	  (cdb:test-rollup-test_data-pass-fail *runremote* test-id)
	  ;; (sqlite3:execute
	  ;;  db   ;;; NOTE: Should this be WARN,FAIL? A WARN is not a FAIL????? BUG FIXME
	  ;;  "UPDATE tests
	  ;;             SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 
	  ;;                THEN 'FAIL'
	  ;;             WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND 
	  ;;                  (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL')
	  ;;             THEN 'PASS'
	  ;;             ELSE status
	  ;;         END WHERE id=?;"
	  ;;  test-id test-id test-id test-id)
	  ))))

(define (db:get-prev-tol-for-test db test-id category variable)
  ;; Finish me?
  (values #f #f #f))

;;======================================================================
;; S T E P S 
;;======================================================================

(define (db:step-get-time-as-string vec)
  (seconds->time-string (db:step-get-event_time vec)))

;; db-get-test-steps-for-run
(define (db:get-steps-for-test db test-id #!key (work-area #f))
  (let* ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))
	 (res '()))
    (if (sqlite3:database? tdb)
	(handle-exceptions
	 exn
	 (begin
	   (debug:print 0 "ERROR: error on access to testdat for test with id " test-id)
	   '())
	 (begin
	   (sqlite3:for-each-row 
	    (lambda (id test-id stepname state status event-time logfile)
	      (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res)))
	    tdb
	    "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
	    test-id)
	   (sqlite3:finalize! tdb)
	   (reverse res)))
	'())))

;; get a pretty table to summarize steps
;;
(define (db:get-steps-table db test-id #!key (work-area #f))
  (let ((steps   (db:get-steps-for-test db test-id work-area: work-area)))
    ;; organise the steps for better readability
    (let ((res (make-hash-table)))
      (for-each 

       (lambda (step)
	 (debug:print 6 "step=" step)
	 (let ((record (hash-table-ref/default 
			res 
			(db:step-get-stepname step) 
			;;        stepname                start end status Duration  Logfile 
			(vector (db:step-get-stepname step) ""   "" ""     ""        ""))))
	   (debug:print 6 "record(before) = " record 
			"\nid:       " (db:step-get-id step)
			"\nstepname: " (db:step-get-stepname step)
			"\nstate:    " (db:step-get-state step)
			"\nstatus:   " (db:step-get-status step)
			"\ntime:     " (db:step-get-event_time step))
	   (case (string->symbol (db:step-get-state step))
	     ((start)(vector-set! record 1 (db:step-get-event_time step))
	      (vector-set! record 3 (if (equal? (vector-ref record 3) "")
					(db:step-get-status step)))
	      (if (> (string-length (db:step-get-logfile step))
		     0)
		  (vector-set! record 5 (db:step-get-logfile step))))
	     ((end)  
	      (vector-set! record 2 (any->number (db:step-get-event_time step)))
	      (vector-set! record 3 (db:step-get-status step))
	      (vector-set! record 4 (let ((startt (any->number (vector-ref record 1)))
					  (endt   (any->number (vector-ref record 2))))
				      (debug:print 4 "record[1]=" (vector-ref record 1) 
						   ", startt=" startt ", endt=" endt
						   ", get-status: " (db:step-get-status step))
				      (if (and (number? startt)(number? endt))
					  (seconds->hr-min-sec (- endt startt)) "-1")))
	      (if (> (string-length (db:step-get-logfile step))
		     0)
		  (vector-set! record 5 (db:step-get-logfile step))))
	     (else
	      (vector-set! record 2 (db:step-get-state step))
	      (vector-set! record 3 (db:step-get-status step))
	      (vector-set! record 4 (db:step-get-event_time step))))
	   (hash-table-set! res (db:step-get-stepname step) record)
	   (debug:print 6 "record(after)  = " record 
			"\nid:       " (db:step-get-id step)
			"\nstepname: " (db:step-get-stepname step)
			"\nstate:    " (db:step-get-state step)
			"\nstatus:   " (db:step-get-status step)
			"\ntime:     " (db:step-get-event_time step))))
       ;; (else   (vector-set! record 1 (db:step-get-event_time step)))
       (sort steps (lambda (a b)
		     (cond
		      ((<   (db:step-get-event_time a)(db:step-get-event_time b)) #t)
		      ((eq? (db:step-get-event_time a)(db:step-get-event_time b)) 
		       (<   (db:step-get-id a)        (db:step-get-id b)))
		      (else #f)))))
      res)))

;; get a pretty table to summarize steps
;;
(define (db:get-steps-table-list db test-id #!key (work-area #f))
  (let ((steps   (db:get-steps-for-test db test-id work-area: work-area)))
    ;; organise the steps for better readability
    (let ((res (make-hash-table)))
      (for-each 
       (lambda (step)
	 (debug:print 6 "step=" step)
	 (let ((record (hash-table-ref/default 
			res 
			(db:step-get-stepname step) 
			;;        stepname                start end status    
			(vector (db:step-get-stepname step) ""   "" ""     "" ""))))
	   (debug:print 6 "record(before) = " record 
			"\nid:       " (db:step-get-id step)
			"\nstepname: " (db:step-get-stepname step)
			"\nstate:    " (db:step-get-state step)
			"\nstatus:   " (db:step-get-status step)
			"\ntime:     " (db:step-get-event_time step))
	   (case (string->symbol (db:step-get-state step))
	     ((start)(vector-set! record 1 (db:step-get-event_time step))
	      (vector-set! record 3 (if (equal? (vector-ref record 3) "")
					(db:step-get-status step)))
	      (if (> (string-length (db:step-get-logfile step))
		     0)
		  (vector-set! record 5 (db:step-get-logfile step))))
	     ((end)  
	      (vector-set! record 2 (any->number (db:step-get-event_time step)))
	      (vector-set! record 3 (db:step-get-status step))
	      (vector-set! record 4 (let ((startt (any->number (vector-ref record 1)))
					  (endt   (any->number (vector-ref record 2))))
				      (debug:print 4 "record[1]=" (vector-ref record 1) 
						   ", startt=" startt ", endt=" endt
						   ", get-status: " (db:step-get-status step))
				      (if (and (number? startt)(number? endt))
					  (seconds->hr-min-sec (- endt startt)) "-1")))
	      (if (> (string-length (db:step-get-logfile step))
		     0)
		  (vector-set! record 5 (db:step-get-logfile step))))
	     (else
	      (vector-set! record 2 (db:step-get-state step))
	      (vector-set! record 3 (db:step-get-status step))
	      (vector-set! record 4 (db:step-get-event_time step))))
	   (hash-table-set! res (db:step-get-stepname step) record)
	   (debug:print 6 "record(after)  = " record 
			"\nid:       " (db:step-get-id step)
			"\nstepname: " (db:step-get-stepname step)
			"\nstate:    " (db:step-get-state step)
			"\nstatus:   " (db:step-get-status step)
			"\ntime:     " (db:step-get-event_time step))))
       ;; (else   (vector-set! record 1 (db:step-get-event_time step)))
       (sort steps (lambda (a b)
		     (cond
		      ((<   (db:step-get-event_time a)(db:step-get-event_time b)) #t)
		      ((eq? (db:step-get-event_time a)(db:step-get-event_time b)) 
		       (<   (db:step-get-id a)        (db:step-get-id b)))
		      (else #f)))))

      res)))

(define (db:get-compressed-steps test-id #!key (work-area #f)(tdb #f))
  (if (or (not work-area)
	  (file-exists? (conc work-area "/testdat.db")))
      (let* ((comprsteps (open-run-close db:get-steps-table tdb test-id work-area: work-area)))
	(map (lambda (x)
	       ;; take advantage of the \n on time->string
	       (vector
		(vector-ref x 0)
		(let ((s (vector-ref x 1)))
		  (if (number? s)(seconds->time-string s) s))
		(let ((s (vector-ref x 2)))
		  (if (number? s)(seconds->time-string s) s))
		(vector-ref x 3)    ;; status
		(vector-ref x 4)
		(vector-ref x 5)))  ;; time delta
	     (sort (hash-table-values comprsteps)
		   (lambda (a b)
		     (let ((time-a (vector-ref a 1))
			   (time-b (vector-ref b 1)))
		       (if (and (number? time-a)(number? time-b))
			   (if (< time-a time-b)
			       #t
			       (if (eq? time-a time-b)
				   (string<? (conc (vector-ref a 2))
					     (conc (vector-ref b 2)))
				   #f))
			   (string<? (conc time-a)(conc time-b))))))))
      '()))

;;======================================================================
;; M I S C   M A N A G E M E N T   I T E M S 
;;======================================================================

;; A routine to map itempaths using a itemmap
(define (db:compare-itempaths patha pathb itemmap)
  (debug:print-info 3 "ITEMMAP is " itemmap)
  (if itemmap
      (let* ((mapparts    (string-split itemmap))
	     (pattern     (car mapparts))
	     (replacement (if (> (length mapparts) 1) (cadr mapparts) "")))
	(if replacement
	    (equal? (string-substitute pattern replacement patha)
		    (string-substitute pattern replacement pathb))
	    (equal? (string-substitute pattern "" patha)
		    (string-substitute pattern "" pathb))))
      (equal? patha pathb)))

;; the new prereqs calculation, looks also at itempath if specified
;; all prereqs must be met:
;;    if prereq test with itempath='' is COMPLETED and PASS, WARN, CHECK, or WAIVED then prereq is met
;;    if prereq test with itempath=ref-item-path and COMPLETED with PASS, WARN, CHECK, or WAIVED then prereq is met
;;
;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK, SKIP or WAIVED)
;;       mode 'toplevel means that tests must be COMPLETED only
;;       mode 'itemmatch or 'itemwait means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]]
;; 

(define (db:get-prereqs-not-met run-id waitons ref-item-path #!key (mode '(normal))(itemmap #f))
  (if (or (not waitons)
	  (null? waitons))
      '()
      (let* ((unmet-pre-reqs '())
	     (result         '()))
	(for-each 
	 (lambda (waitontest-name)
	   ;; by getting the tests with matching name we are looking only at the matching test 
	   ;; and related sub items

	   (let ((tests             (cdb:remote-run db:get-tests-for-run-state-status #f run-id waitontest-name)) ;; (mt:get-tests-for-run run-id waitontest-name '() '()))
		 (ever-seen         #f)
		 (parent-waiton-met #f)
		 (item-waiton-met   #f))
	     (for-each 
	      (lambda (test)
		;; (if (equal? waitontest-name (db:test-get-testname test)) ;; by defintion this had better be true ...
		(let* ((state             (db:test-get-state test))







|
>
>
|
<
>
>
|











|


>








|





<






|

|




|

|
|
|







|
|
|
|
|
|
|

>
>
|
|
|
|
|
|



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


|

|


|

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


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

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




|
>
>
|
>
|
>
>
>

|
<
<
<
|

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









|


|



















|




>
>
|
|
|
|
|
|


|
|


>
>
|
|





>



|







|
<
|
>
>
>
>
|
|


|
<

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

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

|
>
>
|
|
|
|

|

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







|
|
|
|
>



|





<



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


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









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














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


|

>
>
|
|
|
|
|
|
|




>
|
>
|
|

>
>
>
>
|
>

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


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

|
<
>
>
>
|
>
|

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





>
>
>
>
|




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




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

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

|

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

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

|
>
>


|
>
>

|
|

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



|
|
|
>
>
|
|
<
>
|
<


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

|
>
>
|
>
>
>
>
|
>

|
>
|
>
|
|
|

<
<

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

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


>

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

<
<
>
>
>

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

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





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






|
|
<
>




<
<
<
<
<
<
<

|

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

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






|
|
|
|


|
>
>
>

|


|
|
|
|


>
|
|
|

>
>
|
|


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

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






>
>
>
|



|
|


|
|








|
|
|
|
>
|
>

|
<
|



|
|
|
|
>
|



|












|



|
>
>
>
>

>
>
>
>












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

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

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

|

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






|

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


|
>
|
>
>
|


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

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







|




















>
|









>
|







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
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782

2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837

2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852

2853
2854








2855
2856
2857
2858
2859
2860
2861
2862

2863
2864
2865
2866
2867
2868
2869
2870


2871
2872
2873
2874
2875
2876












2877















2878
2879
2880
2881
2882
2883


2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894

2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909



2910

2911


2912
2913
2914
2915


2916
2917
2918
2919





2920
2921
2922





2923

2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947





































2948



































































2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994


2995













2996























































2997


2998




2999


























































































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
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
				 (conc fieldname " " wildtype " '" patt "'")))
			     (if (null? patts)
				 '("")
				 patts))
			comparator)))


;; register a test run with the db, this accesses the main.db and does NOT
;; use server api
;;
(define (db:register-run dbstruct keyvals runname state status user)

  (let* ((dbdat     (db:get-db dbstruct #f))
	 (db        (db:dbdat-get-db dbdat))
	 (keys      (map car keyvals))
	 (keystr    (keys->keystr keys))	 
	 (comma     (if (> (length keys) 0) "," ""))
	 (andstr    (if (> (length keys) 0) " AND " ""))
	 (valslots  (keys->valslots keys)) ;; ?,?,? ...
	 (allvals   (append (list runname state status user) (map cadr keyvals)))
	 (qryvals   (append (list runname) (map cadr keyvals)))
	 (key=?str  (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND ")))
    (debug:print 3 "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str)
    (debug:print 2 "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run")
    (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and"
	(let ((res #f))
	  (db:delay-if-busy dbdat)
	  (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");")
		 allvals)
	  (db:delay-if-busy dbdat)
	  (apply sqlite3:for-each-row 
		 (lambda (id)
		   (set! res id))
		 db
		 (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");")))
					;(debug:print 4 "qry: " qry) 
		   qry)
		 qryvals)
	  (db:delay-if-busy dbdat)
	  (sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res)
	  res) 
	(begin
	  (debug:print 0 "ERROR: Called without all necessary keys")
	  #f))))


;; replace header and keystr with a call to runs:get-std-run-fields
;;
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
;; runpatts: patt1,patt2 ...
;;
(define (db:get-runs dbstruct runpatt count offset keypatts)
  (let* ((res       '())
	 (keys       (db:get-keys dbstruct))
	 (runpattstr (db:patt->like "runname" runpatt))
	 (remfields  (list "id" "runname" "state" "status" "owner" "event_time"))
	 (header     (append keys remfields))
	 (keystr     (conc (keys->keystr keys) ","
			   (string-intersperse remfields ",")))
	 (qrystr     (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? "
			   ;; Generate: " AND x LIKE 'keypatt' ..."
			   (if (null? keypatts) ""
			       (conc " AND "
				     (string-join 
				      (map (lambda (keypatt)
					     (let ((key  (car keypatt))
						   (patt (cadr keypatt)))
					       (db:patt->like key patt)))
					   keypatts)
				      " AND ")))
			   " AND state != 'deleted' ORDER BY event_time DESC "
			   (if (number? count)
			       (conc " LIMIT " count)
			       "")
			   (if (number? offset)
			       (conc " OFFSET " offset)
			       ""))))
    (debug:print-info 11 "db:get-runs START qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count)
    (db:with-db dbstruct #f #f
		(lambda (db)		
		  (sqlite3:for-each-row
		   (lambda (a . x)
		     (set! res (cons (apply vector a x) res)))
		   db
		   qrystr
		   )))
    (debug:print-info 11 "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count)
    (vector header res)))

;; db:get-runs-by-patt
;; get runs by list of criteria
;; register a test run with the db
;;
;; Use: (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
;;  to extract info from the structure returned
;;
;; NOTE: THIS IS COMPLETELY UNFINISHED. IT GOES WITH rmt:get-get-paths-matching-keynames
;;
(define (db:get-run-ids-matching dbstruct keynames target res)
;; (define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit) ;; test-name)
  (let* ((tmp      (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time")))
	 (keystr   (car tmp))
	 (header   (cadr tmp))
	 (res     '())
	 (key-patt "")
	 (runwildtype (if (substring-index "%" runnamepatt) "like" "glob"))
	 (qry-str  #f)
	 (keyvals  (if targpatt (keys:target->keyval keys targpatt) '())))
    (for-each (lambda (keyval)
		(let* ((key    (car keyval))
		       (patt   (cadr keyval))
		       (fulkey (conc ":" key))
		       (wildtype (if (substring-index "%" patt) "like" "glob")))
		  (if patt
		      (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'"))
		      (begin
			(debug:print 0 "ERROR: searching for runs with no pattern set for " fulkey)
			(exit 6)))))
	      keyvals)
    (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt " ORDER BY event_time "
			(if limit  (conc " LIMIT " limit)   "")
			(if offset (conc " OFFSET " offset) "")
			";"))
    (debug:print-info 4 "runs:get-runs-by-patt qry=" qry-str " " runnamepatt)
    (db:with-db dbstruct #f #f ;; reads db, does not write to it.
		(lambda (db)
		  (sqlite3:for-each-row
		   (lambda (a . r)
		     (set! res (cons (list->vector (cons a r)) res)))
		   (db:get-db dbstruct #f)
		   qry-str
		   runnamepatt)))
    (vector header res)))

;; Get all targets from the db
;;
(define (db:get-targets dbstruct)
  (let* ((res       '())
	 (keys       (db:get-keys dbstruct))
	 (header     keys) ;; (map key:get-fieldname keys))
	 (keystr     (keys->keystr keys))
	 (qrystr     (conc "SELECT " keystr " FROM runs WHERE state != 'deleted';"))
	 (seen       (make-hash-table)))
    (db:with-db
     dbstruct
     #f
     #f
     (lambda (db)
       (sqlite3:for-each-row
	(lambda (a . x)
	  (let ((targ (cons a x)))
	    (if (not (hash-table-ref/default seen targ #f))
		(begin
		  (hash-table-set! seen targ #t)
		  (set! res (cons (apply vector targ) res))))))
	db
	qrystr)
       (debug:print-info 11 "db:get-targets END qrystr: " qrystr )
       (vector header res)))))

;; just get count of runs
(define (db:get-num-runs dbstruct runpatt)
  (db:with-db
   dbstruct
   #f
   #f
   (lambda (db)
     (let ((numruns 0))
       (debug:print-info 11 "db:get-num-runs START " runpatt)
       (sqlite3:for-each-row 
	(lambda (count)
	  (set! numruns count))
	db
	"SELECT COUNT(id) FROM runs WHERE runname LIKE ? AND state != 'deleted';" runpatt)
       (debug:print-info 11 "db:get-num-runs END " runpatt)
       numruns))))

(define (db:get-all-run-ids dbstruct)
  (db:with-db
   dbstruct
   #f
   #f
   (lambda (db)
     (let ((run-ids '()))
       (sqlite3:for-each-row
	(lambda (run-id)
	  (set! run-ids (cons run-id run-ids)))
	db
	"SELECT id FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;")
    (reverse run-ids)))))

;; get some basic run stats
;;
;; ( (runname (( state  count ) ... ))
;;   (   ...  
(define (db:get-run-stats dbstruct)
  (let* ((dbdat        (db:get-db dbstruct #f))
	 (db           (db:dbdat-get-db dbdat))
	 (totals       (make-hash-table))
	 (curr         (make-hash-table))
	 (res          '())
	 (runs-info    '()))
    ;; First get all the runname/run-ids
    (db:delay-if-busy dbdat)
    (sqlite3:for-each-row
     (lambda (run-id runname)



       (set! runs-info (cons (list run-id runname) runs-info)))
     db
     "SELECT id,runname FROM runs WHERE state != 'deleted';")
    ;; for each run get stats data
    (for-each
     (lambda (run-info)
       ;; get the net state/status counts for this run
       (let* ((run-id   (car  run-info))
	      (run-name (cadr run-info)))
	 (db:with-db
	  dbstruct
	  run-id
	  #f
	  (lambda (db)
	    (sqlite3:for-each-row
	     (lambda (state status count)
	       (let ((netstate (if (equal? state "COMPLETED") status state)))
		 (if (string? netstate)
		     (begin
		       (hash-table-set! totals netstate (+ (hash-table-ref/default totals netstate 0) count))
		       (hash-table-set! curr   netstate (+ (hash-table-ref/default curr   netstate 0) count))))))
	     db
	     "SELECT state,status,count(id) FROM tests AS t GROUP BY state,status ORDER BY state,status DESC;")
	    ;; add the per run counts to res
	    (for-each (lambda (state)
			(set! res (cons (list run-name state (hash-table-ref curr state)) res)))
		      (sort (hash-table-keys curr) string>=))
	    (set! curr (make-hash-table))))))
     runs-info)
    (for-each (lambda (state)
		(set! res (cons (list "Totals" state (hash-table-ref totals state)) res)))
	      (sort (hash-table-keys totals) string>=))
    res))

;; db:get-runs-by-patt
;; get runs by list of criteria
;; register a test run with the db
;;
;; Use: (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
;;  to extract info from the structure returned
;;
(define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit) ;; test-name)
  (let* ((tmp      (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time")))
	 (keystr   (car tmp))
	 (header   (cadr tmp))
	 (res     '())
	 (key-patt "")
	 (runwildtype (if (substring-index "%" runnamepatt) "like" "glob"))
	 (qry-str  #f)
	 (keyvals  (if targpatt (keys:target->keyval keys targpatt) '())))
    (for-each (lambda (keyval)
		(let* ((key    (car keyval))
		       (patt   (cadr keyval))
		       (fulkey (conc ":" key))
		       (wildtype (if (substring-index "%" patt) "like" "glob")))
		  (if patt
		      (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'"))
		      (begin
			(debug:print 0 "ERROR: searching for runs with no pattern set for " fulkey)
			(exit 6)))))
	      keyvals)
    (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt " ORDER BY event_time "
			(if limit  (conc " LIMIT " limit)   "")
			(if offset (conc " OFFSET " offset) "")
			";"))
    (debug:print-info 4 "runs:get-runs-by-patt qry=" qry-str " " runnamepatt)
    (db:with-db dbstruct #f #f ;; reads db, does not write to it.
		(lambda (db)
		  (sqlite3:for-each-row
		   (lambda (a . r)
		     (set! res (cons (list->vector (cons a r)) res)))
		   db
		   qry-str
		   runnamepatt)))
    (vector header res)))

;; use (get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
(define (db:get-run-info dbstruct run-id)
  ;;(if (hash-table-ref/default *run-info-cache* run-id #f)
  ;;    (hash-table-ref *run-info-cache* run-id)
  (let* ((dbdat     (db:get-db dbstruct #f))
	 (db        (db:dbdat-get-db dbdat))
	 (res       (vector #f #f #f #f))
	 (keys      (db:get-keys dbstruct))
	 (remfields (list "id" "runname" "state" "status" "owner" "event_time"))
	 (header    (append keys remfields))
	 (keystr    (conc (keys->keystr keys) ","
			  (string-intersperse remfields ","))))
    (debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)
    (db:delay-if-busy dbdat)
    (sqlite3:for-each-row
     (lambda (a . x)
       (set! res (apply vector a x)))
     db 
     (conc "SELECT " keystr " FROM runs WHERE id=? AND state != 'deleted';")
     run-id)
    (debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)
    (let ((finalres (vector header res)))
      ;; (hash-table-set! *run-info-cache* run-id finalres)
      finalres)))

(define (db:set-comment-for-run dbstruct run-id comment)

  (db:with-db
   dbstruct
   #f
   #f
   (lambda (db)
     (sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment ;; (sdb:qry 'getid comment)
		      run-id))))

;; does not (obviously!) removed dependent data. But why not!!?
(define (db:delete-run dbstruct run-id)

  ;; First set any related tests to DELETED
  (let* ((rdbdat (db:get-db dbstruct run-id))
	 (rdb    (db:dbdat-get-db rdbdat))
	 (dbdat  (db:get-db dbstruct #f))
	 (db     (db:dbdat-get-db dbdat)))
    (db:delay-if-busy rdbdat)
    (sqlite3:execute rdb "UPDATE tests SET state='DELETED',comment='';")



    (sqlite3:execute rdb "DELETE FROM test_steps;")
    (sqlite3:execute rdb "DELETE FROM test_data;")

    (db:delay-if-busy dbdat)
    (sqlite3:execute db "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id)))

(define (db:update-run-event_time dbstruct run-id)

  (db:with-db
   dbstruct
   #f
   #t
   (lambda (db)
     (sqlite3:execute db "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id))))

(define (db:lock/unlock-run dbstruct run-id lock unlock user)
  (db:with-db
   dbstruct
   #f
   #t
   (lambda (db)
     (let ((newlockval (if lock "locked"
			   (if unlock
			       "unlocked"
			       "locked")))) ;; semi-failsafe

       (sqlite3:execute db "UPDATE runs SET state=? WHERE id=?;" newlockval run-id)
       (sqlite3:execute db "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);"
			user (conc newlockval " " run-id))
       (debug:print-info 1 "" newlockval " run number " run-id)))))

(define (db:set-run-status dbstruct run-id status msg)
  (let* ((dbdat (db:get-db dbstruct #f))
	 (db    (db:dbdat-get-db dbdat)))
    (db:delay-if-busy dbdat)
    (if msg
	(sqlite3:execute db "UPDATE runs SET status=?,comment=? WHERE id=?;" status msg run-id)
	(sqlite3:execute db "UPDATE runs SET status=? WHERE id=?;" status run-id))))

(define (db:get-run-status dbstruct run-id)
  (let ((res "n/a"))
    (db:with-db
     dbstruct
     #f
     #f
     (lambda (db)
       (sqlite3:for-each-row 
	(lambda (status)
	  (set! res status))
	db
	"SELECT status FROM runs WHERE id=?;" 
	run-id)
       res))))









;;======================================================================
;; K E Y S
;;======================================================================

;; get key val pairs for a given run-id
;; ( (FIELDNAME1 keyval1) (FIELDNAME2 keyval2) ... )
(define (db:get-key-val-pairs dbstruct run-id)
  (let* ((keys (db:get-keys dbstruct))
	 (res  '())
	 (dbdat  (db:get-db dbstruct #f))
	 (db     (db:dbdat-get-db dbdat)))
    (for-each 
     (lambda (key)
       (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
	 (db:delay-if-busy dbdat)
	 (sqlite3:for-each-row 
	  (lambda (key-val)
	    (set! res (cons (list key key-val) res)))
	  db qry run-id)))
     keys)

    (reverse res)))

;; get key vals for a given run-id
(define (db:get-key-vals dbstruct run-id)



  (let* ((keys (db:get-keys dbstruct))
	 (res  '())

	 (dbdat  (db:get-db dbstruct #f))
	 (db     (db:dbdat-get-db dbdat)))
    (for-each 
     (lambda (key)
       (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))

	 (db:delay-if-busy dbdat)
	 (sqlite3:for-each-row 
	  (lambda (key-val)
	    (set! res (cons key-val res)))
	  db qry run-id)))
     keys)

    (let ((final-res (reverse res)))
      (hash-table-set! *keyvals* run-id final-res)
      final-res)))

;; The target is keyval1/keyval2..., cached in *target* as it is used often
(define (db:get-target dbstruct run-id)



  (let* ((keyvals (db:get-key-vals dbstruct run-id))
	 (thekey  (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/")))

    thekey))

;; Get run-ids for runs with same target but different runnames and NOT run-id
;;
(define (db:get-prev-run-ids dbstruct run-id)
  (let* ((keyvals (rmt:get-key-val-pairs run-id))
	 (kvalues (map cadr keyvals))
	 (keys    (rmt:get-keys))
	 (qrystr  (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")))
    (let ((prev-run-ids '()))
      (db:with-db dbstruct #f #f ;; #f means work with the zeroth db - i.e. the runs db
       (lambda (db)
	 (apply sqlite3:for-each-row
		(lambda (id)
		  (set! prev-run-ids (cons id prev-run-ids)))
		db
		(conc "SELECT id FROM runs WHERE " qrystr " AND state != 'deleted' AND id != ?;") (append kvalues (list run-id)))))
      prev-run-ids)))

;;======================================================================
;;  T E S T S
;;======================================================================

;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN
;; i.e. these lists define what to NOT show.
;; states and statuses are required to be lists, empty is ok
;; not-in #t = above behaviour, #f = must match
(define (db:get-tests-for-run dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals)
  (if (not (number? run-id))
      (begin ;; no need to treat this as an error by default
	(debug:print 4 "WARNING: call to db:get-tests-for-run with bad run-id=" run-id)
	;; (print-call-chain (current-error-port))
	'())
      (let* ((qryvalstr       (case qryvals
				((shortlist) "id,run_id,testname,item_path,state,status")
				((#f)        db:test-record-qry-selector) ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")
				(else        qryvals)))
	     (res            '())
	     ;; if states or statuses are null then assume match all when not-in is false
	     (states-qry      (if (null? states) 
				  #f
				  (conc " state "  
					(if not-in
					    " NOT IN ('"
					    " IN ('") 
					(string-intersperse states   "','")
					"')")))
	     (statuses-qry    (if (null? statuses)
				  #f
				  (conc " status "
					(if not-in 
					    " NOT IN ('"
					    " IN ('") 
					(string-intersperse statuses "','")
					"')")))
	     (states-statuses-qry 
	      (cond 
	       ((and states-qry statuses-qry)
		(conc " AND ( " states-qry " AND " statuses-qry " ) "))
	       (states-qry  
		(conc " AND " states-qry))
	       (statuses-qry 
		(conc " AND " statuses-qry))
	       (else "")))
	     (tests-match-qry (tests:match->sqlqry testpatt))
	     (qry             (conc "SELECT " qryvalstr
				    " FROM tests WHERE run_id=? AND state != 'DELETED' "
				    states-statuses-qry
				    (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")
				    (case sort-by
				      ((rundir)      " ORDER BY length(rundir) ")
				      ((testname)    (conc " ORDER BY testname " (if sort-order (conc sort-order ",") "") " item_path "))
				      ((statestatus) (conc " ORDER BY state " (if  sort-order (conc sort-order ",") "") " status "))
				      ((event_time)  " ORDER BY event_time ")
				      (else          (if (string? sort-by)
							 (conc " ORDER BY " sort-by " ")
							 " ")))
				    (if sort-order sort-order " ")
				    (if limit  (conc " LIMIT " limit)   " ")
				    (if offset (conc " OFFSET " offset) " ")
				    ";"
				    )))
	(debug:print-info 8 "db:get-tests-for-run run-id=" run-id ", qry=" qry)
	(db:with-db dbstruct run-id #f
		    (lambda (db)
		      (sqlite3:for-each-row 
		       (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment)
			 (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res)))
		       db
		       qry
		       run-id
		       )))
	(case qryvals
	  ((shortlist)(map db:test-short-record->norm res))
	  ((#f)       res)
	  (else       res)))))

(define (db:test-short-record->norm inrec)
  ;;  "id,run_id,testname,item_path,state,status"
  ;;  "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
  (vector (vector-ref inrec 0) ;; id
	  (vector-ref inrec 1) ;; run_id
	  (vector-ref inrec 2) ;; testname
	  (vector-ref inrec 4) ;; state
	  (vector-ref inrec 5) ;; status
	  -1 "" -1 -1 "" "-" 
	  (vector-ref inrec 3) ;; item-path
	  -1 "-" "-"))


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


		   qry
		   run-id)))
    res))

(define (db:get-testinfo-state-status dbstruct run-id test-id)
  (let ((res            #f))
    (db:with-db dbstruct run-id #f
		(lambda (db)
		  (sqlite3:for-each-row
		   (lambda (run-id testname item-path state status)
		     ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
		     (set! res (vector test-id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-")))
		   db 
		   "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=?;" 
		   test-id)))
    res))

;; get a useful subset of the tests data (used in dashboard
;; use db:mintests-get-{id ,run_id,testname ...}
;; 
(define (db:get-tests-for-runs-mindata dbstruct run-ids testpatt states statuses not-in)
  (debug:print 0 "ERROR: BROKN!")
  ;; (db:get-tests-for-runs dbstruct run-ids testpatt states statuses not-in: not-in qryvals: "id,run_id,testname,state,status,event_time,item_path"))
)

;; get a useful subset of the tests data (used in dashboard
;;
(define (db:get-tests-for-run-mindata dbstruct run-id testpatt states statuses not-in)
  (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f "id,run_id,testname,state,status,event_time,item_path"))

;; do not use.
;;





(define (db:get-tests-for-runs dbstruct run-ids testpatt states statuses #!key (not-in #f)(qryvals #f))

  ;; (db:delay-if-busy)

  (let ((res '()))


    (for-each 

     (lambda (run-id)
       (set! res (append 


		  res 


		  (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f qryvals))))






     (if run-ids
	 run-ids

	 (db:get-all-run-ids dbstruct)))
















    res))











;; Convert calling routines to get list of run-ids and loop, do not use the get-tests-for-runs
;;
















(define (db:delete-test-records dbstruct run-id test-id)

  (let* ((dbdat (db:get-db dbstruct run-id))
	 (db    (db:dbdat-get-db dbdat)))
    (db:general-call dbdat 'delete-test-step-records (list test-id))
    ;; (db:delay-if-busy)
    (db:general-call dbdat 'delete-test-data-records (list test-id))
    (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id)))

(define (db:delete-old-deleted-test-records dbstruct)

  (let ((run-ids  (db:get-all-run-ids dbstruct))
	(targtime (- (current-seconds)(* 30 24 60 60)))) ;; one month in the past
    (for-each
     (lambda (run-id)
       (db:with-db
	dbstruct
	run-id
	#t
	(lambda (db)
	  (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED' AND event_time<?;" targtime))))
     run-ids)))

;; set tests with state currstate and status currstatus to newstate and newstatus
;; use currstate = #f and or currstatus = #f to apply to any state or status respectively
;; WARNING: SQL injection risk. NB// See new but not yet used "faster" version below
;;
		;;  AND NOT (item_path='' AND testname in (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")))
		;;(debug:print 0 "QRY: " qry)
		;; (db:delay-if-busy)

(define (db:set-tests-state-status dbstruct run-id testnames currstate currstatus newstate newstatus)
  (for-each (lambda (testname)
	      (let ((qry (conc "UPDATE tests SET state=?,status=? WHERE "
			       (if currstate  (conc "state='" currstate "' AND ") "")
			       (if currstatus (conc "status='" currstatus "' AND ") "")
			       " run_id=? AND testname LIKE ?;")))

		(db:with-db

		 dbstruct
		 run-id



		 #t


		 (lambda (db)


		   (sqlite3:execute db qry newstate newstatus run-id testname)))))
	    testnames))


;; speed up for common cases with a little logic
;; NB// Ultimately this will be deprecated in deference to mt:test-set-state-status-by-id
;;
(define (db:test-set-state-status-by-id dbstruct run-id test-id newstate newstatus newcomment)
  (db:with-db
   dbstruct
   run-id
   #t
   (lambda (db)
     (cond
      ((and newstate newstatus newcomment)
       (sqlite3:execute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus newcomment ;; (sdb:qry 'getid newcomment)
			test-id))
      ((and newstate newstatus)
       (sqlite3:execute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id))
      (else
       (if newstate   (sqlite3:execute db "UPDATE tests SET state=?   WHERE id=?;" newstate   test-id))
       (if newstatus  (sqlite3:execute db "UPDATE tests SET status=?  WHERE id=?;" newstatus  test-id))
       (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment ;; (sdb:qry 'getid newcomment)
				       test-id))))
     (mt:process-triggers run-id test-id newstate newstatus))))

;; NEW BEHAVIOR: Count tests running in only one run!




;;
(define (db:get-count-tests-running dbstruct run-id)

  (db:with-db
   dbstruct
   run-id
   #f
   (lambda (db)
     (sqlite3:first-result 
      db
      ;; WARNING BUG EDIT ME - merged from v1.55 - not sure what is right here ...
      ;; AND run_id NOT IN (SELECT id FROM runs WHERE state='deleted')
      "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND NOT (uname = 'n/a' AND item_path = '');"
      ;; "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=?;" 
      ))))

;; NEW BEHAVIOR: Count tests running in only one run!
;;
(define (db:get-count-tests-actually-running dbstruct run-id)
  (db:with-db
   dbstruct
   run-id
   #f
   (lambda (db)
     (sqlite3:first-result
      db
      ;; WARNING BUG EDIT ME - merged from v1.55 - not sure what is right here ...
      ;; "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id NOT IN (SELECT id FROM runs WHERE state='deleted') AND NOT (uname = 'n/a' AND item_path = '');")
      "SELECT count(id) FROM tests WHERE state in ('RUNNING','REMOTEHOSTSTART') AND run_id=?;" 
      run-id)))) ;; NOT IN (SELECT id FROM runs WHERE state='deleted');")



;; NEW BEHAVIOR: Look only at single run with run-id
;; 
;; (define (db:get-running-stats dbstruct run-id)
(define (db:get-count-tests-running-for-run-id dbstruct run-id)
  (db:with-db
   dbstruct
   run-id
   #f
   (lambda (db)

     (sqlite3:first-result
      db

      "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=? AND NOT (uname = 'n/a' AND item_path = '');" run-id))))


;; For a given testname how many items are running? Used to determine
;; probability for regenerating html
;; 
(define (db:get-count-tests-running-for-testname dbstruct run-id testname)

  (db:with-db
   dbstruct
   run-id
   #f
   (lambda (db)

     (sqlite3:first-result
      db
      "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=? AND NOT (uname = 'n/a' AND item_path = '') AND testname=?;" run-id testname))))


(define (db:get-count-tests-running-in-jobgroup dbstruct run-id jobgroup)
  (let* ((dbdat (db:get-db dbstruct #f))
	 (db    (db:dbdat-get-db dbdat)))
  (if (not jobgroup)
      0 ;; 
      (let ((testnames '()))
	;; get the testnames
	(db:delay-if-busy dbdat)
	(sqlite3:for-each-row
	 (lambda (testname)
	   (set! testnames (cons testname testnames)))
	 db
	 "SELECT testname FROM test_meta WHERE jobgroup=?"
	 jobgroup)
	;; get the jobcount NB// EXTEND THIS TO OPPERATE OVER ALL RUNS?
	(if (not (null? testnames))
	    (db:with-db
	     dbstruct
	     run-id
	     #f
	     (lambda (db)
	       (sqlite3:first-result
		db
		(conc "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND testname in ('"
		      (string-intersperse testnames "','")
		      "') AND NOT (uname = 'n/a' AND item_path='');")) ;; should this include the (uname = 'n/a' ...) ???
	       0)))))))
             ;; DEBUG FIXME - need to merge this v.155 query correctly   
             ;; AND testname in (SELECT testname FROM test_meta WHERE jobgroup=?)
             ;; AND NOT (uname = 'n/a' AND item_path = '');"



;; done with run when:
;;   0 tests in LAUNCHED, NOT_STARTED, REMOTEHOSTSTART, RUNNING
(define (db:estimated-tests-remaining dbstruct run-id)
  (db:with-db
   dbstruct
   run-id
   #f
   (lambda (db)
     (sqlite3:first-result

      db
      "SELECT count(id) FROM tests WHERE state in ('LAUNCHED','NOT_STARTED','REMOTEHOSTSTART','RUNNING','KILLREQ');"))))


;; map run-id, testname item-path to test-id
(define (db:get-test-id dbstruct run-id testname item-path)
  (db:with-db
   dbstruct
   run-id
   #f
   (lambda (db)
     (db:first-result-default
      db
      "SELECT id FROM tests WHERE testname=? AND item_path=?;"
      #f ;; the default
      testname item-path))))

;; overload the unused attemptnum field for the process id of the runscript or 
;; ezsteps step script in progress
;;
(define (db:test-set-top-process-pid dbstruct run-id test-id pid)
  (db:with-db
   dbstruct
   run-id
   #f
   (lambda (db)
     (sqlite3:execute db "UPDATE tests SET attemptnum=? WHERE id=?;"
		      pid test-id))))


(define (db:test-get-top-process-pid dbstruct run-id test-id)
  (db:with-db
   dbstruct
   run-id
   #f
   (lambda (db)
     (db:first-result-default 
      db
      "SELECT attemptnum FROM tests WHERE id=?;"
      #f
      test-id))))

(define db:test-record-fields '("id"           "run_id"        "testname"  "state"      "status"      "event_time"
				"host"         "cpuload"       "diskfree"  "uname"      "rundir"      "item_path"
                                "run_duration" "final_logf"    "comment"   "shortdir"   "attemptnum"  "archived"))

;; fields *must* be a non-empty list
;;
(define (db:field->number fieldname fields)
  (if (null? fields)
      #f
      (let loop ((hed  (car fields))
		 (tal  (cdr fields))
		 (indx 0))
	(if (equal? fieldname hed)
	    indx
	    (if (null? tal)
		#f
		(loop (car tal)(cdr tal)(+ indx 1)))))))

(define db:test-record-qry-selector (string-intersperse db:test-record-fields ","))


;; NOTE: Use db:test-get* to access records
;; NOTE: This needs rundir decoding? Decide, decode here or where used? For the moment decode where used.
(define (db:get-all-tests-info-by-run-id dbstruct run-id)
  (let* ((dbdat (if (vector? dbstruct)
		    (db:get-db dbstruct run-id)
		    dbstruct)) ;; still settling on when to use dbstruct or dbdat
	 (db    (db:dbdat-get-db dbdat))
	 (res '()))
    (db:delay-if-busy dbdat)
    (sqlite3:for-each-row
     (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived)
       ;;                 0    1       2      3      4        5       6      7        8     9     10      11          12          13       14     15        16
       (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived)
		       res)))
     db
     (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE state != 'DELETED' AND run_id=?;")
     run-id)
    res))



(define (db:replace-test-records dbstruct run-id testrecs)
  (db:with-db dbstruct run-id #t 
	      (lambda (db)
		(let* ((qmarks (string-intersperse (make-list (length db:test-record-fields) "?") ","))
		       (qrystr (conc "INSERT OR REPLACE INTO tests (" db:test-record-qry-selector ") VALUES (" qmarks ");"))
		       (qry    (sqlite3:prepare db qrystr)))
		  (debug:print 0 "INFO: migrating test records for run with id " run-id)
		  (sqlite3:with-transaction
		   db
		   (lambda ()
		     (for-each 
		      (lambda (rec)
			;; (debug:print 0 "INFO: Inserting values: " (string-intersperse (map conc (vector->list rec)) ",") "\n")
			(apply sqlite3:execute qry (vector->list rec)))
		      testrecs)))
		  (sqlite3:finalize! qry)))))

;; map a test-id into the proper range
;;
(define (db:adj-test-id mtdb min-test-id test-id)
  (if (>= test-id min-test-id)
      test-id

      (let loop ((new-id min-test-id))
	(let ((test-id-found #f))


	  (sqlite3:for-each-row 
	   (lambda (id)
	     (set! test-id-found id))


	   (db:dbdat-get-db mtdb)
	   "SELECT id FROM tests WHERE id=?;"
	   new-id)
	  ;; if test-id-found then need to try again
	  (if test-id-found
	      (loop (+ new-id 1))
	      (begin
		(debug:print-info 0 "New test id " new-id " selected for test with id " test-id)
		(sqlite3:execute mtdb "UPDATE tests SET id=? WHERE id=?;" new-id test-id)))))))

;; move test ids into the 30k * run_id range
;;
(define (db:prep-megatest.db-adj-test-ids mtdb run-id testrecs)
  (debug:print-info 0 "Adjusting test ids in megatest.db for run " run-id)
  (let ((min-test-id (* run-id 30000)))
    (for-each 
     (lambda (testrec)
       (let* ((test-id (vector-ref testrec (db:field->number "id" db:test-record-fields))))
	 (db:adj-test-id (db:dbdat-get-db mtdb) min-test-id test-id)))
     testrecs)))
	


;; 1. move test ids into the 30k * run_id range
;; 2. move step ids into the 30k * run_id range
;;
(define (db:prep-megatest.db-for-migration mtdb)
  (let* ((run-ids (db:get-all-run-ids mtdb)))
    (for-each 
     (lambda (run-id)
       (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id)))
	 (db:prep-megatest.db-adj-test-ids (db:dbdat-get-db mtdb) run-id testrecs)))
     run-ids)))

;; Get test data using test_id
(define (db:get-test-info-by-id dbstruct run-id test-id)
  (db:with-db
   dbstruct
   run-id

   #f
   (lambda (db)
     (let ((res #f))
       (sqlite3:for-each-row ;; attemptnum added to hold pid of top process (not Megatest) controlling a test
	(lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived)
	  ;;             0    1       2      3      4        5       6      7        8     9     10      11          12          13           14         15          16
	  (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived)))
	db
	(conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=?;")
	test-id)
       res))))

;; Use db:test-get* to access
;; Get test data using test_ids. NB// Only works within a single run!!
;;

(define (db:get-test-info-by-ids dbstruct run-id test-ids)
  (db:with-db
   dbstruct
   run-id

   #f
   (lambda (db)
     (let ((res '()))
       (sqlite3:for-each-row
	(lambda (a . b)
	  ;;                 0    1       2      3      4        5       6      7        8     9     10      11          12          13       14
	  (set! res (cons (apply vector a b) res)))
	db
	(conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id in ("
	      (string-intersperse (map conc test-ids) ",") ");"))
       res))))

(define (db:get-test-info dbstruct run-id testname item-path)
  (db:with-db
   dbstruct
   run-id
   #f
   (lambda (db)
     (let ((res #f))
       (sqlite3:for-each-row
	(lambda (a . b)
	  (set! res (apply vector a b)))
	db
	(conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=?;")
	test-name item-path)
       res))))

(define (db:test-get-rundir-from-test-id dbstruct run-id test-id)
  (db:with-db
   dbstruct
   run-id
   #f
   (lambda (db)
     (db:first-result-default
      db
      "SELECT rundir FROM tests WHERE id=?;"
      #f ;; default result
      test-id))))

;;======================================================================
;; S T E P S
;;======================================================================

(define (db:teststep-set-status! dbstruct run-id test-id teststep-name state-in status-in comment logfile)
  (db:with-db
   dbstruct
   run-id
   #t
   (lambda (db)
     (sqlite3:execute 
      db
      "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);"
      test-id teststep-name state-in status-in (current-seconds)
      (if comment comment "")
      (if logfile logfile "")))))
   
;; db-get-test-steps-for-run


(define (db:get-steps-for-test dbstruct run-id test-id)
  (db:with-db
   dbstruct
   run-id
   #f
   (lambda (db)
     (let* ((res '()))
       (sqlite3:for-each-row 
	(lambda (id test-id stepname state status event-time logfile)
	  (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res)))
	db
	"SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
	test-id)
       (reverse res)))))


(define (db:get-steps-data dbstruct run-id test-id)
  (db:with-db
   dbstruct
   run-id
   #f
   (lambda (db)
     (let ((res '()))
       (sqlite3:for-each-row 
	(lambda (id test-id stepname state status event-time logfile)

	  (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res)))

	db
	"SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
	test-id)
       (reverse res)))))



;;======================================================================
;; T E S T  D A T A 
;;======================================================================

;; WARNING: Do NOT call this for the parent test on an iterated test
;; Roll up test_data pass/fail results
;; look at the test_data status field, 
;;    if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS.
;;    if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored
(define (db:test-data-rollup dbstruct run-id test-id status)
  (let* ((dbdat      (db:get-db dbstruct run-id))
	 (db         (db:dbdat-get-db dbdat))
	 (fail-count 0)
	 (pass-count 0))
    (db:delay-if-busy dbdat)
    (sqlite3:for-each-row
     (lambda (fcount pcount)
       (set! fail-count fcount)
       (set! pass-count pcount))
     db 

     "SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count,
             (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'pass') AS pass_count;"
     test-id test-id)
    ;; Now rollup the counts to the central megatest.db


    (db:general-call dbdat 'pass-fail-counts (list pass-count fail-count test-id))
    ;; if the test is not FAIL then set status based on the fail and pass counts.
    (db:general-call dbdat 'test_data-pf-rollup (list test-id test-id test-id test-id))))

(define (db:csv->test-data dbstruct run-id test-id csvdata)

  (debug:print 4 "test-id " test-id ", csvdata: " csvdata)
  (let* ((dbdat   (db:get-db dbstruct run-id))
	 (db      (db:dbdat-get-db dbdat))
	 (csvlist (csv->list (make-csv-reader
			      (open-input-string csvdata)
			      '((strip-leading-whitespace? #t)
				(strip-trailing-whitespace? #t)))))) ;; (csv->list csvdata)))
    (for-each 
     (lambda (csvrow)
       (let* ((padded-row  (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9))
	      (category    (list-ref padded-row 0))
	      (variable    (list-ref padded-row 1))
	      (value       (any->number-if-possible (list-ref padded-row 2)))
	      (expected    (any->number-if-possible (list-ref padded-row 3)))
	      (tol         (any->number-if-possible (list-ref padded-row 4))) ;; >, <, >=, <=, or a number
	      (units       (list-ref padded-row 5))
	      (comment     (list-ref padded-row 6))
	      (status      (let ((s (list-ref padded-row 7)))
			     (if (and (string? s)(or (string-match (regexp "^\\s*$") s)
						     (string-match (regexp "^n/a$") s)))
				 #f
				 s))) ;; if specified on the input then use, else calculate
	      (type        (list-ref padded-row 8)))
	 ;; look up expected,tol,units from previous best fit test if they are all either #f or ''
	 (debug:print 4 "BEFORE: category: " category " variable: " variable " value: " value 
		      ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment " type: " type)
	 


	 (if (and (or (not expected)(equal? expected ""))
		  (or (not tol)     (equal? expected ""))
		  (or (not units)   (equal? expected "")))


	     (let-values (((new-expected new-tol new-units)(tdb:get-prev-tol-for-test tdb test-id category variable)))
			 (set! expected new-expected)



			 (set! tol      new-tol)
			 (set! units    new-units)))
	 
	 (debug:print 4 "AFTER:  category: " category " variable: " variable " value: " value 
		      ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment)
	 ;; calculate status if NOT specified
	 (if (and (not status)(number? expected)(number? value)) ;; need expected and value to be numbers
	     (if (number? tol) ;; if tol is a number then we do the standard comparison
		 (let* ((max-val (+ expected tol))
			(min-val (- expected tol))
			(result  (and (>=  value min-val)(<= value max-val))))
		   (debug:print 4 "max-val: " max-val " min-val: " min-val " result: " result)
		   (set! status (if result "pass" "fail")))
		 (set! status ;; NB// need to assess each one (i.e. not return operator since need to act if not valid op.
		       (case (string->symbol tol) ;; tol should be >, <, >=, <=
			 ((>)  (if (>  value expected) "pass" "fail"))
			 ((<)  (if (<  value expected) "pass" "fail"))
			 ((>=) (if (>= value expected) "pass" "fail"))
			 ((<=) (if (<= value expected) "pass" "fail"))
			 (else (conc "ERROR: bad tol comparator " tol))))))
	 (debug:print 4 "AFTER2: category: " category " variable: " variable " value: " value 
		      ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment)
	 (db:delay-if-busy dbdat)
	 (sqlite3:execute db "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);"
			  test-id category variable value expected tol units (if comment comment "") status type)))

     csvlist)))

;;======================================================================
;; Misc. test related queries
;;======================================================================





















(define (db:get-run-ids-matching-target dbstruct keynames target res runname testpatt statepatt statuspatt)






  (let* ((dbdat    (db:get-db dbstruct #f))
















	 (db       (db:dbdat-get-db dbdat))






	 (row-ids '())
	 (keystr (string-intersperse 
		  (map (lambda (key val)
			 (conc key " like '" val "'"))
		       keynames 
		       (string-split target "/"))
		  " AND "))
	 ;; (testqry (tests:match->sqlqry testpatt))
	 (runsqry (sqlite3:prepare db (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';"))))

    ;; (debug:print 8 "db:test-get-paths-matching-keynames-target-new\n  runsqry=" runsqry "\n  tstsqry=" testqry)
    (sqlite3:for-each-row
     (lambda (rid)
       (set! row-ids (cons rid row-ids)))
     runsqry)







    (sqlite3:finalize! runsqry)
    row-ids))





(define (db:test-get-paths-matching-keynames-target-new dbstruct run-id keynames target res testpatt statepatt statuspatt runname)





  (let* ((testqry (tests:match->sqlqry testpatt))








	 (tstsqry (conc "SELECT rundir FROM tests WHERE " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;")))



    (db:with-db

     dbstruct

     run-id
     #f
     (lambda (db)
       (sqlite3:for-each-row 
	(lambda (p)
	  (set! res (cons p res)))
	db
	tstsqry)
       res))))

(define (db:test-toplevel-num-items dbstruct run-id testname)
  (db:with-db
   dbstruct
   run-id
   #f
   (lambda (db)
     (let ((res 0))
       (sqlite3:for-each-row
	(lambda (num-items)
	  (set! res num-items))
	db
	"SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND state NOT IN ('DELETED');"
	run-id
	testname)
       res))))

;;======================================================================
;; QUEUE UP META, TEST STATUS AND STEPS REMOTE ACCESS
;;======================================================================

;; NOTE: Can remove the regex and base64 encoding for zmq
(define (db:obj->string obj #!key (transport 'http))
  (case transport
    ;; ((fs) obj)
    ((http fs)
     (string-substitute
      (regexp "=") "_"
      (base64:base64-encode 
       (z3:encode-buffer
	(with-output-to-string
	  (lambda ()(serialize obj)))))
      #t))
    ((zmq nmsg)(with-output-to-string (lambda ()(serialize obj))))
    (else obj)))

(define (db:string->obj msg #!key (transport 'http))
  (case transport
    ;; ((fs) msg)
    ((http fs)
     (if (string? msg)
	 (with-input-from-string 
	     (z3:decode-buffer
	      (base64:base64-decode
	       (string-substitute 
		(regexp "_") "=" msg #t)))
	   (lambda ()(deserialize)))
	 (begin
	   (debug:print 0 "ERROR: reception failed. Received " msg " but cannot translate it.")
	   msg))) ;; crude reply for when things go awry
    ((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize))))
    (else msg)))

(define (db:test-set-status-state dbstruct run-id test-id status state msg)

  (let ((dbdat  (db:get-db dbstruct run-id)))


    (if (member state '("LAUNCHED" "REMOTEHOSTSTART"))

























	(db:general-call dbdat 'set-test-start-time (list test-id)))
    (if msg





	(db:general-call dbdat 'state-status-msg (list state status msg test-id))
	(db:general-call dbdat 'state-status     (list state status test-id)))))














































(define (db:roll-up-pass-fail-counts dbstruct run-id test-name item-path status)
  (if (and (not (equal? item-path ""))
	   (member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK" "SKIP" "LAUNCHED")))
      (let ((dbdat (db:get-db dbstruct run-id)))
	(db:general-call dbdat 'update-pass-fail-counts (list test-name test-name test-name))
	(if (equal? status "RUNNING")
	    (db:general-call dbdat 'top-test-set-running (list test-name))
	    (if (equal? status "LAUNCHED")

		(db:general-call dbdat 'top-test-set (list "LAUNCHED" test-name))

		(db:general-call dbdat 'top-test-set-per-pf-counts (list test-name run-id test-name test-name test-name))))
	#f)
      #f))

















































(define (db:test-get-logfile-info dbstruct run-id test-name)


  (db:with-db




   dbstruct





   run-id











   #f
   (lambda (db)

     (let ((res #f))
       (sqlite3:for-each-row 
	(lambda (path final_logf)
	  ;; (let ((path       (sdb:qry 'getstr path-id))
	  ;;       (final_logf (sdb:qry 'getstr final_logf-id)))
	  (set! logf final_logf)
	  (set! res (list path final_logf))
	  (if (directory? path)
	      (debug:print 2 "Found path: " path)
	      (debug:print 2 "No such path: " path))) ;; )
	db
	"SELECT rundir,final_logf FROM tests WHERE testname=? AND item_path='';"
	test-name)
       res))))

;;======================================================================
;; A G R E G A T E D   T R A N S A C T I O N   D B   W R I T E S 
;;======================================================================

(define db:queries 
  (list '(update-run-duration     "UPDATE tests SET run_duration=? WHERE id=?;")

	;; TESTS
	'(register-test          "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');")
	;; Test state and status
	'(set-test-state         "UPDATE tests SET state=?   WHERE id=?;")
	'(set-test-status        "UPDATE tests SET state=?   WHERE id=?;")
	'(state-status           "UPDATE tests SET state=?,status=? WHERE id=?;") ;; DONE
	'(state-status-msg       "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;") ;; DONE
	;; Test comment
	'(set-test-comment       "UPDATE tests SET comment=? WHERE id=?;")
	'(set-test-start-time    "UPDATE tests SET event_time=strftime('%s','now') WHERE id=?;") ;; DONE
	'(pass-fail-counts       "UPDATE tests SET pass_count=?,fail_count=? WHERE id=?;")
	;; test_data-pf-rollup is used to set a tests PASS/FAIL based on the pass/fail info from the steps
	'(test_data-pf-rollup    "UPDATE tests
                                    SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 
                                      THEN 'FAIL'
                                    WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND 
                                      (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL')
                                    THEN 'PASS'
                                    ELSE status
                                    END WHERE id=?;") ;; DONE
	'(test-set-log            "UPDATE tests SET final_logf=? WHERE id=?;")      ;; DONE
	;; '(test-set-rundir-by-test-id "UPDATE tests SET rundir=? WHERE id=?")        ;; DONE
	;; '(test-set-rundir         "UPDATE tests SET rundir=? AND testname=? AND item_path=?;") ;; DONE
	'(test-set-rundir-shortdir "UPDATE tests SET rundir=?,shortdir=? WHERE testname=? AND item_path=?;")
	'(delete-tests-in-state   ;; "DELETE FROM tests WHERE state=?;")                  ;; DONE
	  "UPDATE tests SET state='DELETED' WHERE state=?")
	'(tests:test-set-toplog   "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';")
	'(update-cpuload-diskfree "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;") ;; DONE

	'(update-uname-host       "UPDATE tests SET uname=?,host=? WHERE id=?;")       ;; DONE
	'(update-test-state       "UPDATE tests SET state=? WHERE state=? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")
	'(update-test-status      "UPDATE tests SET status=? WHERE status like ? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")
	;; stuff for roll-up-pass-fail-counts
	'(update-pass-fail-counts "UPDATE tests 
             SET fail_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('FAIL','CHECK')),
                 pass_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED'))
             WHERE testname=? AND item_path='';") ;; DONE
	'(top-test-set          "UPDATE tests SET state=? WHERE testname=? AND item_path='';") ;; DONE
	'(top-test-set-running  "UPDATE tests SET state='RUNNING' WHERE testname=? AND item_path='';") ;; DONE
	'(top-test-set-per-pf-counts "UPDATE tests
                       SET state=CASE 
                                   WHEN (SELECT count(id) FROM tests 
                                                WHERE testname=?
                                                     AND item_path != '' 
                                                     AND status NOT IN ('TEN_STRIKES','BLOCKED')
                                                     AND state in ('RUNNING','NOT_STARTED','LAUNCHED','REMOTEHOSTSTART')) > 0 THEN 'RUNNING'
                                   ELSE 'COMPLETED' END,
                            status=CASE 
                                  WHEN (SELECT count(id) FROM tests
                                         WHERE run_id=? AND testname=?
                                              AND item_path != ''
                                              AND state IN ('NOT_STARTED','BLOCKED')) > 0 THEN 'FAIL'
                                  WHEN fail_count > 0 THEN 'FAIL' 
                                  WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' 
                                  WHEN (SELECT count(id) FROM tests
                                         WHERE testname=?
                                              AND item_path != ''
                                              AND status = 'SKIP') > 0 THEN 'SKIP'
                                  ELSE 'UNKNOWN' END
                       WHERE testname=? AND item_path='';") ;; DONE

	;; STEPS
	'(delete-test-step-records "UPDATE test_steps SET status='DELETED' WHERE test_id=?;")
	'(delete-test-data-records "UPDATE test_data  SET status='DELETED' WHERE test_id=?;") ;; using status since no state field
	))

(define (db:lookup-query qry-name)
  (let ((q (alist-ref qry-name db:queries)))
    (if q (car q) #f)))

;; do not run these as part of the transaction
(define db:special-queries   '(rollup-tests-pass-fail
			       ;; db:roll-up-pass-fail-counts  ;; WHY NOT!?
			       login
			       immediate
			       flush
			       sync
			       set-verbosity
			       killserver
			       ))

(define (db:login dbstruct calling-path calling-version run-id client-signature)
  (cond 
   ((not (equal? calling-path *toppath*))

    (list #f "Login failed due to mismatch paths: " calling-path ", " *toppath*))
   ((not (equal? *run-id* run-id))
    (list #f "Login failed due to mismatch run-id: " run-id ", " *run-id*))
   ((not (equal? megatest-version calling-version))
    (list #f "Login failed due to mismatch megatest version: " calling-version ", " megatest-version))
   (else
    (hash-table-set! *logged-in-clients* client-signature (current-seconds))
    '(#t "successful login"))))

(define (db:general-call dbdat stmtname params)
  (let ((query (let ((q (alist-ref (if (string? stmtname)
				       (string->symbol stmtname)
				       stmtname)
				   db:queries)))
 		 (if q (car q) #f))))

    (db:delay-if-busy dbdat)
    (apply sqlite3:execute (db:dbdat-get-db dbdat) query params)








    #t)) ;; BUG or Sillyness, why do I return #t instead of the query result?

;; get the previous records for when these tests were run where all keys match but runname
;; NB// Merge this with test:get-previous-test-run-records? This one looks for all matching tests
;; can use wildcards. Also can likely be factored in with get test paths?
;;
;; Run this remotely!!
;;

(define (db:get-matching-previous-test-run-records dbstruct run-id test-name item-path)
  (let* ((dbdat   (db:get-db dbstruct #f))
	 (db      (db:dbdat-get-db dbdat))
	 (keys    (db:get-keys db))
	 (selstr  (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ","))
	 (qrystr  (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND "))
	 (keyvals #f)
	 (tests-hash (make-hash-table)))


    ;; first look up the key values from the run selected by run-id
    (db:delay-if-busy dbdat)
    (sqlite3:for-each-row 
     (lambda (a . b)
       (set! keyvals (cons a b)))
     db












     (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id)















    (if (not keyvals)
	'()
	(let ((prev-run-ids '()))
	  (apply sqlite3:for-each-row
		 (lambda (id)
		   (set! prev-run-ids (cons id prev-run-ids)))


		 db
		 (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id)))
	  ;; collect all matching tests for the runs then
	  ;; extract the most recent test and return that.
	  (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals 
		       ", previous run ids found: " prev-run-ids)
	  (if (null? prev-run-ids) '()  ;; no previous runs? return null
	      (let loop ((hed (car prev-run-ids))
			 (tal (cdr prev-run-ids)))
		(let ((results (db:get-tests-for-run dbstruct run-id hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f)))
		  (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name 

			       ", item-path " item-path " results: " (intersperse results "\n"))
		  ;; Keep only the youngest of any test/item combination
		  (for-each 
		   (lambda (testdat)
		     (let* ((full-testname (conc (db:test-get-testname testdat) "/" (db:test-get-item-path testdat)))
			    (stored-test   (hash-table-ref/default tests-hash full-testname #f)))
		       (if (or (not stored-test)
			       (and stored-test
				    (> (db:test-get-event_time testdat)(db:test-get-event_time stored-test))))
			   ;; this test is younger, store it in the hash
			   (hash-table-set! tests-hash full-testname testdat))))
		   results)
		  (if (null? tal)
		      (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests
		      (loop (car tal)(cdr tal))))))))))





(define (db:delay-if-busy dbdat #!key (count 6))


  (if (not (configf:lookup *configdat* "server" "delay-on-busy"))
      (and dbdat (db:dbdat-get-db dbdat))
      (if dbdat
	  (let* ((dbpath (db:dbdat-get-path dbdat))


		 (db     (db:dbdat-get-db   dbdat)) ;; we'll return this so (db:delay--if-busy can be called inline
		 (dbfj   (conc dbpath "-journal")))
	    (if (handle-exceptions
		 exn





		 (begin
		   (debug:print-info 0 "WARNING: failed to test for existance of " dbfj)
		   (thread-sleep! 1)





		   (db:delay-if-busy count (- count 1)))

		 (file-exists? dbfj))
		(case count
		  ((6)
		   (thread-sleep! 0.2)
		   (db:delay-if-busy count: 5))
		  ((5)
		   (thread-sleep! 0.4)
		   (db:delay-if-busy count: 4))
		  ((4)
		   (thread-sleep! 0.8)
		   (db:delay-if-busy count: 3))
		  ((3)
		   (thread-sleep! 1.6)
		   (db:delay-if-busy count: 2))
		  ((2)
		   (thread-sleep! 3.2)
		   (db:delay-if-busy count: 1))
		  ((1)
		   (thread-sleep! 6.4)
		   (db:delay-if-busy count: 0))
		  (else
		   (debug:print-info 0 "delaying db access due to high database load.")
		   (thread-sleep! 12.8))))
	    db)





































	  "bogus result from db:delay-if-busy")))




































































(define (db:test-get-records-for-index-file dbstruct run-id test-name)
  (let ((res '()))
    (db:with-db
     dbstruct
     run-id
     #f
     (lambda (db)
       (sqlite3:for-each-row 
	(lambda (id itempath state status run_duration logf comment)
	  (set! res (cons (vector id itempath state status run_duration logf comment) res)))
	db
	"SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE testname=? AND item_path != '';"
	test-name)
       res))))

;;======================================================================
;; Tests meta data
;;======================================================================

;; read the record given a testname
(define (db:testmeta-get-record dbstruct testname)
  (let ((res #f))
    (db:with-db
     dbstruct
     #f
     #f
     (lambda (db)
       (sqlite3:for-each-row
	(lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup)
	  (set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup)))
	db
	"SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE testname=?;"
	testname)
       res))))

;; create a new record for a given testname
(define (db:testmeta-add-record dbstruct testname)
  (db:with-db dbstruct #f #f 
	      (lambda (db)
		(sqlite3:execute 
		 db
		 "INSERT OR IGNORE INTO test_meta (testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags) VALUES (?,'','','','','','','','');" testname))))

;; update one of the testmeta fields
(define (db:testmeta-update-field dbstruct testname field value)


  (db:with-db dbstruct #f #f 













	      (lambda (db)























































		(sqlite3:execute 


		 db




		 (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname))))





























































































(define (db:testmeta-get-all dbstruct)




  (db:with-db dbstruct #f #f 
	      (lambda (db)

























































		(let ((res '()))
		  (sqlite3:for-each-row
		   (lambda (a . b)




































		     (set! res (cons (apply vector a b) res)))








		   db




		   "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta;")
		  res))))






























;;======================================================================
;; M I S C   M A N A G E M E N T   I T E M S 
;;======================================================================

;; A routine to map itempaths using a itemmap
(define (db:compare-itempaths patha pathb itemmap)
  (debug:print-info 6 "ITEMMAP is " itemmap)
  (if itemmap
      (let* ((mapparts    (string-split itemmap))
	     (pattern     (car mapparts))
	     (replacement (if (> (length mapparts) 1) (cadr mapparts) "")))
	(if replacement
	    (equal? (string-substitute pattern replacement patha)
		    (string-substitute pattern replacement pathb))
	    (equal? (string-substitute pattern "" patha)
		    (string-substitute pattern "" pathb))))
      (equal? patha pathb)))

;; the new prereqs calculation, looks also at itempath if specified
;; all prereqs must be met:
;;    if prereq test with itempath='' is COMPLETED and PASS, WARN, CHECK, or WAIVED then prereq is met
;;    if prereq test with itempath=ref-item-path and COMPLETED with PASS, WARN, CHECK, or WAIVED then prereq is met
;;
;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK, SKIP or WAIVED)
;;       mode 'toplevel means that tests must be COMPLETED only
;;       mode 'itemmatch or 'itemwait means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]]
;; 
;; (define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path mode)
(define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path #!key (mode '(normal))(itemmap #f))
  (if (or (not waitons)
	  (null? waitons))
      '()
      (let* ((unmet-pre-reqs '())
	     (result         '()))
	(for-each 
	 (lambda (waitontest-name)
	   ;; by getting the tests with matching name we are looking only at the matching test 
	   ;; and related sub items
	   ;; next should be using mt:get-tests-for-run?
	   (let ((tests             (db:get-tests-for-run-state-status dbstruct run-id waitontest-name))
		 (ever-seen         #f)
		 (parent-waiton-met #f)
		 (item-waiton-met   #f))
	     (for-each 
	      (lambda (test)
		;; (if (equal? waitontest-name (db:test-get-testname test)) ;; by defintion this had better be true ...
		(let* ((state             (db:test-get-state test))
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
	     ;; if the test is not found then clearly the waiton is not met...
	     ;; (if (not ever-seen)(set! result (cons waitontest-name result)))))
	     (if (not ever-seen)
		 (set! result (append (if (null? tests)(list waitontest-name) tests) result)))))
	 waitons)
	(delete-duplicates result))))

(define (db:teststep-set-status! db test-id teststep-name state-in status-in comment logfile #!key (work-area #f))
  ;;                 db:open-test-db-by-test-id does cdb:remote-run
  (let* ((tdb       (db:open-test-db-by-test-id db test-id work-area: work-area))
	 (state     (items:check-valid-items "state" state-in))
	 (status    (items:check-valid-items "status" status-in)))
    (if (or (not state)(not status))
	(debug:print 3 "WARNING: Invalid " (if status "status" "state")
		     " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config"))
    (if (sqlite3:database? tdb)
	(begin
	  (sqlite3:execute 
	   tdb
	   "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);"
	   test-id teststep-name state-in status-in (current-seconds) (if comment comment "") (if logfile logfile ""))
	  (sqlite3:finalize! tdb)
	  #t)
	#f)))

;;======================================================================
;; Extract ods file from the db
;;======================================================================



;; runspatt is a comma delimited list of run patterns
;; keypatt-alist must contain *all* keys with an associated pattern: '( ("KEY1" "%") .. )
(define (db:extract-ods-file db outputfile keypatt-alist runspatt pathmod)
  (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 '())
	 (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







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



>
>



|







3098
3099
3100
3101
3102
3103
3104


















3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
	     ;; if the test is not found then clearly the waiton is not met...
	     ;; (if (not ever-seen)(set! result (cons waitontest-name result)))))
	     (if (not ever-seen)
		 (set! result (append (if (null? tests)(list waitontest-name) tests) result)))))
	 waitons)
	(delete-duplicates result))))



















;;======================================================================
;; Extract ods file from the db
;;======================================================================

;; NOT REWRITTEN YET!!!!!

;; runspatt is a comma delimited list of run patterns
;; keypatt-alist must contain *all* keys with an associated pattern: '( ("KEY1" "%") .. )
(define (db:extract-ods-file dbstruct outputfile keypatt-alist runspatt pathmod)
  (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 '())
	 (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
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
    ;; brutal clean up
    (system "rm -rf tempdir")))

;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%")

;; This is a list of all procs that write to the db
;;
(define *db:all-write-procs*
  (list 
   db:set-var 
   db:del-var
   db:register-run
   db:set-comment-for-run
   db:delete-run
   db:update-run-event_time
   db:lock/unlock-run 
   db:delete-test-step-records
   db:delete-test-records
   db:delete-tests-for-run
   db:delete-old-deleted-test-records
   db:set-tests-state-status
   db:test-set-state-status-by-id
   db:test-set-state-status-by-run-id-testname
   db:test-set-comment
   db:testmeta-add-record
   db:csv->test-data
   db:test-data-rollup
   db:teststep-set-status! ))








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

3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249

3250
3251

3252
3253
    ;; brutal clean up
    (system "rm -rf tempdir")))

;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%")

;; This is a list of all procs that write to the db
;;
;; (define *db:all-write-procs*
;;   (list 
;;    db:set-var 
;;    db:del-var
;;    db:register-run
;;    db:set-comment-for-run
;;    db:delete-run
;;    db:update-run-event_time
;;    db:lock/unlock-run 
;;    db:delete-test-step-records
;;    db:delete-test-records
;;    db:delete-tests-for-run
;;    db:delete-old-deleted-test-records
;;    db:set-tests-state-status
;;    db:test-set-state-status-by-id
;;    db:test-set-state-status-by-run-id-testname

;;    db:testmeta-add-record
;;    db:csv->test-data

;;    ))

Modified db_records.scm from [02b88af351] to [de0d03e562].




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



;; Test record accessors
;;































































(define (make-db:test)(make-vector 20))
(define-inline (db:test-get-id           vec) (vector-ref vec 0))
(define-inline (db:test-get-run_id       vec) (vector-ref vec 1))
(define-inline (db:test-get-testname     vec) (vector-ref vec 2))
(define-inline (db:test-get-state        vec) (vector-ref vec 3))
(define-inline (db:test-get-status       vec) (vector-ref vec 4))
(define-inline (db:test-get-event_time   vec) (vector-ref vec 5))
(define-inline (db:test-get-host         vec) (vector-ref vec 6))
(define-inline (db:test-get-cpuload      vec) (vector-ref vec 7))
(define-inline (db:test-get-diskfree     vec) (vector-ref vec 8))
(define-inline (db:test-get-uname        vec) (vector-ref vec 9))

(define-inline (db:test-get-rundir       vec) (vector-ref vec 10))
(define-inline (db:test-get-item-path    vec) (vector-ref vec 11))
(define-inline (db:test-get-run_duration vec) (vector-ref vec 12))
(define-inline (db:test-get-final_logf   vec) (vector-ref vec 13))
(define-inline (db:test-get-comment      vec) (vector-ref vec 14))





(define-inline (db:test-get-fullname     vec)
  (conc (db:test-get-testname vec) "/" (db:test-get-item-path vec)))





(define-inline (db:test-get-first_err    vec) (printable (vector-ref vec 15)))
(define-inline (db:test-get-first_warn   vec) (printable (vector-ref vec 16)))

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

;; Test record utility functions

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

;; get rows and header from 
(define-inline (db:get-header vec)(vector-ref vec 0))
(define-inline (db:get-rows   vec)(vector-ref vec 1))

;; make-vector-record "" db mintest id run_id testname state status event_time item_path
;;
(define (make-db:mintest)(make-vector 7))
(define-inline (db:mintest-get-id           vec)    (vector-ref  vec 0))
(define-inline (db:mintest-get-run_id       vec)    (vector-ref  vec 1))
(define-inline (db:mintest-get-testname     vec)    (vector-ref  vec 2))
(define-inline (db:mintest-get-state        vec)    (vector-ref  vec 3))
>
>
>
|

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











>





>
>
>
>
>



>
>
>
>



















<
<
<
<







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

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

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

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

; (define-inline (dbr:dbstruct-set-run-id! vec val)(vector-set! vec 13 val))

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

(define (dbr:dbstruct-get-localdb v run-id)
  (hash-table-ref/default (dbr:dbstruct-get-locdbs v) run-id #f))

(define (dbr:dbstruct-set-localdb! v run-id db)
  (hash-table-set! (dbr:dbstruct-get-locdbs v) run-id db))


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

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

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

(define-inline (db:test-get-first_err    vec) (printable (vector-ref vec 15)))
(define-inline (db:test-get-first_warn   vec) (printable (vector-ref vec 16)))

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

;; Test record utility functions

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





;; make-vector-record "" db mintest id run_id testname state status event_time item_path
;;
(define (make-db:mintest)(make-vector 7))
(define-inline (db:mintest-get-id           vec)    (vector-ref  vec 0))
(define-inline (db:mintest-get-run_id       vec)    (vector-ref  vec 1))
(define-inline (db:mintest-get-testname     vec)    (vector-ref  vec 2))
(define-inline (db:mintest-get-state        vec)    (vector-ref  vec 3))
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

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


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


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

;; use this one for db-get-run-info
(define-inline (db:get-row    vec)(vector-ref vec 1))

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







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




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







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

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


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

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




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

Added dbwars/NOTES version [8f8ee6c6d0].































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
Before using prepare:

matt@xena:/tmp/megatest/dbwars$ ./sqlite3-test insert
Adding 1047 test3 item/39 host0-0.3-200000-240-this one sucks eh? (added 51886 records so far)
Adding 1122 test5 item/52 host2-0.2-200000-120-this is a good one eh? (added 78889 records so far)
Adding 1050 test7 item/31 host1-0.1-100000-120-this is a good one eh? (added 110641 records so far)
create-tests ran register-test 144000 times in 41.0 seconds

After using prepare:

matt@xena:/tmp/megatest/dbwars$ csc sqlite3-test.scm && ./sqlite3-test insert
Adding 1082 test4 item/74 host1-0.3-100000-120-this is a good one eh? (added 61281 records so far)
Adding 1138 test7 item/43 host2-0.3-200000-120-this is a good one eh? (added 109001 records so far)
Adding 1023 test9 item/00 host0-0.2-100000-240-this one sucks eh? (added 143878 records so far)
create-tests ran register-test 144000 times in 38.0 seconds

After moving the prepare outside the call (so it isn't done each time):

matt@xena:/tmp/megatest/dbwars$ ./sqlite3-test insert
Adding 1042 test4 item/59 host0-0.3-200000-120-this is a good one eh? (added 63401 records so far)
Adding 1011 test6 item/40 host0-0.1-200000-120-this one sucks eh? (added 94906 records so far)
Adding 1076 test9 item/34 host1-0.2-200000-120-just eh, eh? (added 139035 records so far)
create-tests ran register-test 144000 times in 33.0 seconds

Using sql-de-lite with very similar code:

matt@xena:/tmp/megatest/dbwars$ ./sql-de-lite-test insert
Adding 1029 test4 item/53 host0-0.2-200000-240- (added 64252 records so far)
Adding 1134 test7 item/64 host2-0.3-100000-240-this is a good one eh? (added 105973 records so far)
create-tests ran register-test 144000 times in 31.0 seconds

Added dbwars/sql-de-lite-test.scm version [004f7cb8d7].







































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19

(use sql-de-lite)
(include "test-common.scm")

(define db (open-database "test.db"))

(exec (sql db test-table-defn))
(exec (sql db syncsetup))

(define (register-test stmth  run-id testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time)
    (exec 
     stmth ;; (sql db test-insert)
     run-id
     testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time))

(let ((stmth (sql db test-insert)))
  (create-tests stmth))

(close-database db)

Added dbwars/sqlite3-test.scm version [338a298923].









































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20

(use sqlite3)
(include "test-common.scm")

(define db (open-database "test.db"))

(execute db test-table-defn)
(execute db syncsetup)


(define (register-test stmth run-id testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time)
  (execute stmth
	   run-id
	   testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time))

(let ((stmth (prepare db test-insert)))
  (create-tests stmth)
  (finalize! stmth))

(finalize! db)

Added dbwars/test-common.scm version [02dcd9f2da].



































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
(use srfi-18 srfi-69 apropos)

(define args (argv))

(if (not (eq? (length args) 2))
    (begin
      (print "Usage: sqlitecompare [insert|update]")
      (exit 0)))

(define action (string->symbol (cadr args)))

(system "rm -f test.db")

(define test-table-defn
		 "CREATE TABLE IF NOT EXISTS tests 
                    (id INTEGER PRIMARY KEY,
                     run_id     INTEGER,
                     testname   TEXT,
                     host       TEXT DEFAULT 'n/a',
                     cpuload    REAL DEFAULT -1,
                     diskfree   INTEGER DEFAULT -1,
                     uname      TEXT DEFAULT 'n/a', 
                     rundir     TEXT DEFAULT 'n/a',
                     shortdir   TEXT DEFAULT '',
                     item_path  TEXT DEFAULT '',
                     state      TEXT DEFAULT 'NOT_STARTED',
                     status     TEXT DEFAULT 'FAIL',
                     attemptnum INTEGER DEFAULT 0,
                     final_logf TEXT DEFAULT 'logs/final.log',
                     logdat     BLOB, 
                     run_duration INTEGER DEFAULT 0,
                     comment    TEXT DEFAULT '',
                     event_time TIMESTAMP,
                     fail_count INTEGER DEFAULT 0,
                     pass_count INTEGER DEFAULT 0,
                     archived   INTEGER DEFAULT 0, -- 0=no, 1=in progress, 2=yes
                     CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path)
          );")

(define test-insert "INSERT INTO tests  (run_id,testname,host,cpuload,diskfree,uname,rundir,shortdir,item_path,state,status,final_logf,run_duration,comment,event_time)
                                values (?,     ?,       ?,   ?,      ?,       ?,    ?,     ?,       ?,        ?,    ?,     ?,         ?,           ?,      ?        );")
(define syncsetup "PRAGMA synchronous = OFF;")

(define tests '("test0" "test1" "test2" "test3" "test4" "test5" "test6" "test7" "test8" "test9"))
(define items '())
(for-each 
 (lambda (n)
   (for-each 
    (lambda (m)
      (set! items (cons (conc "item/" n m) items)))
    '(0 1 2 3 4 5 6 7 8 9)))
 '(0 1 2 3 4 5 6 7 8 9))
(define hosts '("host0" "host1" "host2")) ;;  "host3" "host4" "host5" "host6" "host7" "host8" "host9"))
(define cpuloads '(0.1 0.2 0.3))    ;; 0.4 0.5 0.6 0.7 0.8 0.9))
(define diskfrees '(100000 200000)) ;; 300000 400000 500000 600000 700000 800000 900000))
(define uname "Linux xena 3.5.0-40-generic #62~precise1-Ubuntu SMP Fri Aug 23 17:59:10 UTC 2013 i686 i686 i386 GNU/Linux")
(define basedir "/mfs/matt/data/megatest/runs/testing")
(define final-logf "finallog.html")
(define run-durations (list 120 240)) ;;  260))
(define comments '("" "this is a good one eh?" "this one sucks eh?" "just eh, eh?"))

(define run-ids (make-hash-table))
(define max-run-id 1000)

(define (test-factors->run-id host cpuload diskfree run-duration comment)
  (let* ((factor (conc host "-" cpuload "-" diskfree "-" run-duration "-" comment))
	 (run-id (hash-table-ref/default run-ids factor #f)))
    (if run-id 
	(list run-id factor)
	(let ((new-id (+ max-run-id 1)))
	  (set! max-run-id new-id)
	  (hash-table-set! run-ids factor new-id)
	  (list new-id factor)))))
	  

(define (create-tests stmth)
  (let ((num-created 0)
	(last-print  (current-seconds))
	(start-time  (current-seconds)))
    (for-each 
     (lambda (test)
       (for-each 
	(lambda (item)
	  (for-each 
	   (lambda (host)
	     (for-each 
	      (lambda (cpuload)
		(for-each
		 (lambda (diskfree)
		   (for-each 
		    (lambda (run-duration)
		      (for-each 
		       (lambda (comment)
			 (let* ((run-id-dat (test-factors->run-id host cpuload diskfree run-duration comment))
				(run-id (car run-id-dat))
				(factor (cadr run-id-dat))
				(curr-time (current-seconds)))
			   (if (> (- curr-time last-print) 10)
			       (begin
				 (print "Adding " run-id " " test " " item " " factor " (added " num-created " records so far)")
				 (set! last-print curr-time)))
			   (set! num-created (+ num-created 1))
			   (register-test stmth ;; db  
					  run-id
					  test  ;; testname
					  host
					  cpuload
					  diskfree
					  uname
					  (conc basedir "/" test "/" item) ;; rundir
					  (conc test "/" item) ;; shortdir
					  item   ;; item-path
					  "NOT_STARTED" ;; state
					  "NA"          ;; status
					  final-logf
					  run-duration
					  comment
					  (current-seconds))))
		       comments))
		    run-durations))
		 diskfrees))
	      cpuloads))
	   hosts))
	items))
     tests)
    (print "create-tests ran register-test " num-created " times in " (- (current-seconds) start-time) " seconds")))

				   
			 

Modified dcommon.scm from [a40d1c9411] to [9889b90aa7].

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

;; TO-DO
;;  1. Make "data" hash-table hierarchial store of all displayed data
;;  2. Update synchash to understand "get-runs", "get-tests" etc.
;;  3. Add extraction of filters to synchash calls
;;
;; Mode is 'full or 'incremental for full refresh or incremental refresh
(define (run-update keys data runname keypatts testpatt states statuses mode window-id)
  (let* (;; count and offset => #f so not used
	 ;; the synchash calls modify the "data" hash
	 (get-runs-sig    (conc (client:get-signature) " get-runs"))
	 (get-tests-sig   (conc (client:get-signature) " get-tests"))
	 (get-details-sig (conc (client:get-signature) " get-test-details"))

	 ;; test-ids to get and display are indexed on window-id in curr-test-ids hash
	 (test-ids        (hash-table-values (dboard:data-get-curr-test-ids *data*)))

 	 (run-changes     (synchash:client-get 'db:get-runs get-runs-sig (length keypatts) data runname #f #f keypatts))
	 (tests-detail-changes (if (not (null? test-ids))
				   (synchash:client-get 'db:get-test-info-by-ids get-details-sig 0  data test-ids)
				   '()))

	 ;; Now can calculate the run-ids
	 (run-hash    (hash-table-ref/default data get-runs-sig #f))
	 (run-ids     (if run-hash (filter number? (hash-table-keys run-hash)) '()))




	 (test-changes (synchash:client-get 'db:get-tests-for-runs-mindata get-tests-sig 0 data run-ids testpatt states statuses #f))


	 (runs-hash    (hash-table-ref/default data get-runs-sig #f))
	 (header       (hash-table-ref/default runs-hash "header" #f))
	 (run-ids      (sort (filter number? (hash-table-keys runs-hash))
			     (lambda (a b)
			       (let* ((record-a (hash-table-ref runs-hash a))
				      (record-b (hash-table-ref runs-hash b))
				      (time-a   (db:get-value-by-header record-a header "event_time"))







|








|
|

|






>
>
>
|
>
>







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

;; TO-DO
;;  1. Make "data" hash-table hierarchial store of all displayed data
;;  2. Update synchash to understand "get-runs", "get-tests" etc.
;;  3. Add extraction of filters to synchash calls
;;
;; Mode is 'full or 'incremental for full refresh or incremental refresh
(define (dcommon:run-update keys data runname keypatts testpatt states statuses mode window-id)
  (let* (;; count and offset => #f so not used
	 ;; the synchash calls modify the "data" hash
	 (get-runs-sig    (conc (client:get-signature) " get-runs"))
	 (get-tests-sig   (conc (client:get-signature) " get-tests"))
	 (get-details-sig (conc (client:get-signature) " get-test-details"))

	 ;; test-ids to get and display are indexed on window-id in curr-test-ids hash
	 (test-ids        (hash-table-values (dboard:data-get-curr-test-ids *data*)))
	 ;; run-id is #f in next line to send the query to server 0
 	 (run-changes     (synchash:client-get 'db:get-runs get-runs-sig (length keypatts) data #f runname #f #f keypatts))
	 (tests-detail-changes (if (not (null? test-ids))
				   (synchash:client-get 'db:get-test-info-by-ids get-details-sig 0  data #f test-ids)
				   '()))

	 ;; Now can calculate the run-ids
	 (run-hash    (hash-table-ref/default data get-runs-sig #f))
	 (run-ids     (if run-hash (filter number? (hash-table-keys run-hash)) '()))

	 (all-test-changes (let ((res (make-hash-table)))
			     (for-each (lambda (run-id)
					 (if (> run-id 0)
					     (hash-table-set! res run-id (synchash:client-get 'db:get-tests-for-run-mindata get-tests-sig 0 data run-id 1 testpatt states statuses #f))))
				       run-ids)
			     res))
	 (runs-hash    (hash-table-ref/default data get-runs-sig #f))
	 (header       (hash-table-ref/default runs-hash "header" #f))
	 (run-ids      (sort (filter number? (hash-table-keys runs-hash))
			     (lambda (a b)
			       (let* ((record-a (hash-table-ref runs-hash a))
				      (record-b (hash-table-ref runs-hash b))
				      (time-a   (db:get-value-by-header record-a header "event_time"))
190
191
192
193
194
195
196

197
198
199
200
201
202
203
		  (set! colnum (+ colnum 1))))
	      run-ids)

    ;; Scan all tests to be displayed and organise all the test names, respecting what is in the hash table
    ;; Do this analysis in the order of the run-ids, the most recent run wins
    (for-each (lambda (run-id)
		(let* ((run-path       (hash-table-ref (dboard:data-get-run-keys *data*) run-id))

		       (new-test-dat   (car test-changes))
		       (removed-tests  (cadr test-changes))
		       (tests          (sort (map cadr (filter (lambda (testrec)
								 (eq? run-id (db:mintest-get-run_id (cadr testrec))))
							       new-test-dat))
					     (lambda (a b)
					       (let ((time-a (db:mintest-get-event_time a))







>







195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
		  (set! colnum (+ colnum 1))))
	      run-ids)

    ;; Scan all tests to be displayed and organise all the test names, respecting what is in the hash table
    ;; Do this analysis in the order of the run-ids, the most recent run wins
    (for-each (lambda (run-id)
		(let* ((run-path       (hash-table-ref (dboard:data-get-run-keys *data*) run-id))
		       (test-changes   (hash-table-ref all-test-changes run-id))
		       (new-test-dat   (car test-changes))
		       (removed-tests  (cadr test-changes))
		       (tests          (sort (map cadr (filter (lambda (testrec)
								 (eq? run-id (db:mintest-get-run_id (cadr testrec))))
							       new-test-dat))
					     (lambda (a b)
					       (let ((time-a (db:mintest-get-event_time a))
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
				     (testname  (db:mintest-get-testname test))
				     (itempath  (db:mintest-get-item_path test))
				     (fullname  (conc testname "/" itempath))
				     (dispname  (if (string=? itempath "") testname (conc "   " itempath)))
				     (rownum    (hash-table-ref/default testname-to-row fullname #f))
				     (test-path (append run-path (if (equal? itempath "") 
								     (list testname)
								     (list testname itempath)))))


				(tree:add-node (dboard:data-get-tests-tree *data*) "Runs" 
					       test-path
					       userdata: (conc "test-id: " test-id))




				(hash-table-set! (dboard:data-get-path-test-ids *data*) test-path test-id)
				(if (not rownum)
				    (let ((rownums (hash-table-values testname-to-row)))
				      (set! rownum (if (null? rownums)
						       1
						       (+ 1 (apply max rownums))))
				      (hash-table-set! testname-to-row fullname rownum)
				      ;; create the label
				      (iup:attribute-set! (dboard:data-get-runs-matrix *data*)
							  (conc rownum ":" 0) dispname)
				      ))
				;; set the cell text and color
				;; (debug:print 2 "rownum:colnum=" rownum ":" colnum ", state=" status)
				(iup:attribute-set! (dboard:data-get-runs-matrix *data*)
						    (conc rownum ":" colnum)
						    (if (string=? state "COMPLETED")
							status
							state))
				(iup:attribute-set! (dboard:data-get-runs-matrix *data*)
						    (conc "BGCOLOR" rownum ":" colnum)
						    (car (gutils:get-color-for-state-status state status)))
				))
			    tests)))
	      run-ids)

    (let ((updater (hash-table-ref/default  (dboard:data-get-updaters *data*) window-id #f)))
      (if updater (updater (hash-table-ref/default data get-details-sig #f))))

    (iup:attribute-set! (dboard:data-get-runs-matrix *data*) "REDRAW" "ALL")
    ;; (debug:print 2 "run-changes: " run-changes)
    ;; (debug:print 2 "test-changes: " test-changes)
    (list run-changes test-changes)))

;;======================================================================
;; TESTS DATA
;;======================================================================

;; Produce a list of lists ready for common:sparse-list-generate-index
;;







|
>
>



>
>
>
>















|















|







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
				     (testname  (db:mintest-get-testname test))
				     (itempath  (db:mintest-get-item_path test))
				     (fullname  (conc testname "/" itempath))
				     (dispname  (if (string=? itempath "") testname (conc "   " itempath)))
				     (rownum    (hash-table-ref/default testname-to-row fullname #f))
				     (test-path (append run-path (if (equal? itempath "") 
								     (list testname)
								     (list testname itempath))))
				     (tb         (dboard:data-get-tests-tree *data*)))
				(print "INFONOTE: run-path: " run-path)
				(tree:add-node (dboard:data-get-tests-tree *data*) "Runs" 
					       test-path
					       userdata: (conc "test-id: " test-id))
				(let ((node-num (tree:find-node tb (cons "Runs" test-path)))
				      (color    (car (gutils:get-color-for-state-status state status))))
				  (debug:print 0 "node-num: " node-num ", color: " color)
				  (iup:attribute-set! tb (conc "COLOR" node-num) color))
				(hash-table-set! (dboard:data-get-path-test-ids *data*) test-path test-id)
				(if (not rownum)
				    (let ((rownums (hash-table-values testname-to-row)))
				      (set! rownum (if (null? rownums)
						       1
						       (+ 1 (apply max rownums))))
				      (hash-table-set! testname-to-row fullname rownum)
				      ;; create the label
				      (iup:attribute-set! (dboard:data-get-runs-matrix *data*)
							  (conc rownum ":" 0) dispname)
				      ))
				;; set the cell text and color
				;; (debug:print 2 "rownum:colnum=" rownum ":" colnum ", state=" status)
				(iup:attribute-set! (dboard:data-get-runs-matrix *data*)
						    (conc rownum ":" colnum)
						    (if (member state '("ARCHIVED" "COMPLETED"))
							status
							state))
				(iup:attribute-set! (dboard:data-get-runs-matrix *data*)
						    (conc "BGCOLOR" rownum ":" colnum)
						    (car (gutils:get-color-for-state-status state status)))
				))
			    tests)))
	      run-ids)

    (let ((updater (hash-table-ref/default  (dboard:data-get-updaters *data*) window-id #f)))
      (if updater (updater (hash-table-ref/default data get-details-sig #f))))

    (iup:attribute-set! (dboard:data-get-runs-matrix *data*) "REDRAW" "ALL")
    ;; (debug:print 2 "run-changes: " run-changes)
    ;; (debug:print 2 "test-changes: " test-changes)
    (list run-changes all-test-changes)))

;;======================================================================
;; TESTS DATA
;;======================================================================

;; Produce a list of lists ready for common:sparse-list-generate-index
;;
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
;; General data
;;
(define (dcommon:general-info)
  (let ((general-matrix (iup:matrix
			 #:alignment1 "ALEFT"
			 #:expand "YES" ;; "HORIZONTAL"
			 #:numcol 1
			 #:numlin 3
			 #:numcol-visible 1
			 #:numlin-visible 3)))
    (iup:attribute-set! general-matrix "WIDTH1" "200")
    (iup:attribute-set! general-matrix "0:1" "About this Megatest area") 
    ;; User (this is not always obvious - it is common to run as a different user
    (iup:attribute-set! general-matrix "1:0" "User")
    (iup:attribute-set! general-matrix "1:1" (current-user-name))
    ;; Megatest area
    (iup:attribute-set! general-matrix "2:0" "Area")
    (iup:attribute-set! general-matrix "2:1" *toppath*)
    ;; Megatest version
    (iup:attribute-set! general-matrix "3:0" "Version")
    (iup:attribute-set! general-matrix "3:1" megatest-version)

    general-matrix))

(define (dcommon:run-stats)
  (let* ((stats-matrix (iup:matrix expand: "YES"))
	 (changed      #f)
	 (updater      (lambda ()
			 (let* ((run-stats    (mt:get-run-stats))
				(indices      (common:sparse-list-generate-index run-stats)) ;;  proc: set-cell))
				(row-indices  (car indices))
				(col-indices  (cadr indices))
				(max-row      (if (null? row-indices) 1 (apply max (map cadr row-indices))))
				(max-col      (if (null? col-indices) 1 
						  (apply max (map cadr col-indices))))
				(max-visible  (max (- *num-tests* 15) 3))







|

|
|





|
|

|
|



|



|







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
;; General data
;;
(define (dcommon:general-info)
  (let ((general-matrix (iup:matrix
			 #:alignment1 "ALEFT"
			 #:expand "YES" ;; "HORIZONTAL"
			 #:numcol 1
			 #:numlin 2
			 #:numcol-visible 1
			 #:numlin-visible 2)))
    (iup:attribute-set! general-matrix "WIDTH1" "150")
    (iup:attribute-set! general-matrix "0:1" "About this Megatest area") 
    ;; User (this is not always obvious - it is common to run as a different user
    (iup:attribute-set! general-matrix "1:0" "User")
    (iup:attribute-set! general-matrix "1:1" (current-user-name))
    ;; Megatest area
    ;; (iup:attribute-set! general-matrix "2:0" "Area")
    ;; (iup:attribute-set! general-matrix "2:1" *toppath*)
    ;; Megatest version
    (iup:attribute-set! general-matrix "2:0" "Version")
    (iup:attribute-set! general-matrix "2:1" (conc megatest-version "-" (substring megatest-fossil-hash 0 4)))

    general-matrix))

(define (dcommon:run-stats dbstruct)
  (let* ((stats-matrix (iup:matrix expand: "YES"))
	 (changed      #f)
	 (updater      (lambda ()
			 (let* ((run-stats    (db:get-run-stats dbstruct))
				(indices      (common:sparse-list-generate-index run-stats)) ;;  proc: set-cell))
				(row-indices  (car indices))
				(col-indices  (cadr indices))
				(max-row      (if (null? row-indices) 1 (apply max (map cadr row-indices))))
				(max-col      (if (null? col-indices) 1 
						  (apply max (map cadr col-indices))))
				(max-visible  (max (- *num-tests* 15) 3))
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
    (set! dashboard:update-summary-tab updater)
    (iup:attribute-set! stats-matrix "WIDTHDEF" "40")
    (iup:vbox
     ;; (iup:label "Run statistics"  #:expand "HORIZONTAL")
     stats-matrix)))

(define (dcommon:servers-table)

  (let* ((colnum         0)
	 (rownum         0)
	 (servers-matrix (iup:matrix #:expand "YES"
				     #:numcol 7
				     #:numcol-visible 7
				     #:numlin-visible 3
				     ))
	 (colnames       (list "Id" "MTver" "Pid" "Host" "Interface:OutPort" "InPort" "State" "Transport"))
	 (updater        (lambda ()
			   (let ((servers (open-run-close tasks:get-all-servers tasks:open-db)))
			     (iup:attribute-set! servers-matrix "NUMLIN" (length servers))
			     ;; (set! colnum 0)
			     ;; (for-each (lambda (colname)
			     ;;    	 ;; (print "colnum: " colnum " colname: " colname)
			     ;;    	 (iup:attribute-set! servers-matrix (conc "0:" colnum) colname)
			     ;;    	 (set! colnum (+ 1 colnum)))
			     ;;           colnames)
			     (set! rownum 1)
			     (for-each 
			      (lambda (server)
				(set! colnum 0)
				(let* ((vals (list (vector-ref server 0) ;; Id
						   (vector-ref server 9) ;; MT-Ver
						   (vector-ref server 1) ;; Pid
						   (vector-ref server 2) ;; Hostname
						   (conc (vector-ref server 3) ":" (vector-ref server 4)) ;; IP:Port

						   (vector-ref server 5) ;; Pubport
						   ;; (vector-ref server 10) ;; Last beat
						   ;; (vector-ref server 6) ;; Start time
						   ;; (vector-ref server 7) ;; Priority
						   ;; (vector-ref server 8) ;; State
						   (if (< (vector-ref server 10) 20) ;; Status (Please redo this properly!)
						       "alive"
						       "dead")
						   (vector-ref server 11)  ;; Transport
						   )))
				  (for-each (lambda (val)
					      ;; (print "rownum: " rownum " colnum: " colnum " val: " val)



					      (iup:attribute-set! servers-matrix (conc rownum ":" colnum) val)
					      (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum))
					      (set! colnum (+ 1 colnum)))
					    vals)
				  (set! rownum (+ rownum 1)))
				 (iup:attribute-set! servers-matrix "REDRAW" "ALL"))
			      servers)))))
    (set! colnum 0)
    (for-each (lambda (colname)
		(iup:attribute-set! servers-matrix (conc "0:" colnum) colname)
		(iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum))
		(set! colnum (+ colnum 1)))
	      colnames)
    (set! dashboard:update-servers-table updater) 
    ;; (iup:attribute-set! servers-matrix "WIDTHDEF" "40")
    (iup:hbox
     (iup:vbox
      (iup:button "Start"
		  ;; #:size "50x"
		  #:expand "YES"
		  #:action (lambda (obj)
			     (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
					      "megatest -server - &")))
					      ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
			       (system cmd))))
      (iup:button "Stop"
		  #:expand "YES"
		  ;; #:size "50x"
		  #:action (lambda (obj)
			     (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
					      "megatest -stop-server 0 &")))
					      ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
			       (system cmd))))
      (iup:button "Restart"
		  #:expand "YES"
		  ;; #:size "50x"
		  #:action (lambda (obj)
			     (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
					      "megatest -stop-server 0;megatest -server - &")))
					      ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
			       (system cmd)))))


      servers-matrix
     )))
  
;; The main menu
(define (dcommon:main-menu)
  (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top)
   (iup:menu-item "Files" (iup:menu   ;; Note that you can use either #:action or action: for options
		       (iup:menu-item "Open"  action: (lambda (obj)
							(iup:show (iup:file-dialog))
							(print "File->open " obj)))







>
|




|

|

|
















>
|




|
<
<
|


|
>
>
>
|
|
|












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







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
    (set! dashboard:update-summary-tab updater)
    (iup:attribute-set! stats-matrix "WIDTHDEF" "40")
    (iup:vbox
     ;; (iup:label "Run statistics"  #:expand "HORIZONTAL")
     stats-matrix)))

(define (dcommon:servers-table)
  (let* ((tdbdat         (tasks:open-db))
	 (colnum         0)
	 (rownum         0)
	 (servers-matrix (iup:matrix #:expand "YES"
				     #:numcol 7
				     #:numcol-visible 7
				     #:numlin-visible 5
				     ))
	 (colnames       (list "Id" "MTver" "Pid" "Host" "Interface:OutPort" "RunTime" "State" "RunId"))
	 (updater        (lambda ()
			   (let ((servers (tasks:get-all-servers (db:delay-if-busy tdbdat))))
			     (iup:attribute-set! servers-matrix "NUMLIN" (length servers))
			     ;; (set! colnum 0)
			     ;; (for-each (lambda (colname)
			     ;;    	 ;; (print "colnum: " colnum " colname: " colname)
			     ;;    	 (iup:attribute-set! servers-matrix (conc "0:" colnum) colname)
			     ;;    	 (set! colnum (+ 1 colnum)))
			     ;;           colnames)
			     (set! rownum 1)
			     (for-each 
			      (lambda (server)
				(set! colnum 0)
				(let* ((vals (list (vector-ref server 0) ;; Id
						   (vector-ref server 9) ;; MT-Ver
						   (vector-ref server 1) ;; Pid
						   (vector-ref server 2) ;; Hostname
						   (conc (vector-ref server 3) ":" (vector-ref server 4)) ;; IP:Port
						   (seconds->hr-min-sec (- (current-seconds)(vector-ref server 6)))
						   ;; (vector-ref server 5) ;; Pubport
						   ;; (vector-ref server 10) ;; Last beat
						   ;; (vector-ref server 6) ;; Start time
						   ;; (vector-ref server 7) ;; Priority
						   ;; (vector-ref server 8) ;; State
						   (vector-ref server 8) ;; State


						   (vector-ref server 12)  ;; RunId
						   )))
				  (for-each (lambda (val)
					      (let* ((row-col (conc rownum ":" colnum))
						     (curr-val (iup:attribute servers-matrix row-col)))
						(if (not (equal? (conc val) curr-val))
						    (begin
						      (iup:attribute-set! servers-matrix row-col val)
						      (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum))))
						(set! colnum (+ 1 colnum))))
					    vals)
				  (set! rownum (+ rownum 1)))
				 (iup:attribute-set! servers-matrix "REDRAW" "ALL"))
			      servers)))))
    (set! colnum 0)
    (for-each (lambda (colname)
		(iup:attribute-set! servers-matrix (conc "0:" colnum) colname)
		(iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum))
		(set! colnum (+ colnum 1)))
	      colnames)
    (set! dashboard:update-servers-table updater) 
    ;; (iup:attribute-set! servers-matrix "WIDTHDEF" "40")
   ;;  (iup:hbox
   ;;   (iup:vbox
   ;;    (iup:button "Start"
   ;;      	  ;; #:size "50x"
   ;;      	  #:expand "YES"
   ;;      	  #:action (lambda (obj)
   ;;      		     (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
   ;;      				      "megatest -server - &")))
   ;;      				      ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
   ;;      		       (system cmd))))
   ;;    (iup:button "Stop"
   ;;      	  #:expand "YES"
   ;;      	  ;; #:size "50x"
   ;;      	  #:action (lambda (obj)
   ;;      		     (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
   ;;      				      "megatest -stop-server 0 &")))
   ;;      				      ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
   ;;      		       (system cmd))))
   ;;    (iup:button "Restart"
   ;;      	  #:expand "YES"
   ;;      	  ;; #:size "50x"
   ;;      	  #:action (lambda (obj)
   ;;      		     (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
   ;;      				      "megatest -stop-server 0;megatest -server - &")))
   ;;      				      ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
   ;;      		       (system cmd)))))
   ;;    servers-matrix
   ;;   )))
    servers-matrix
    ))

;; The main menu
(define (dcommon:main-menu)
  (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top)
   (iup:menu-item "Files" (iup:menu   ;; Note that you can use either #:action or action: for options
		       (iup:menu-item "Open"  action: (lambda (obj)
							(iup:show (iup:file-dialog))
							(print "File->open " obj)))
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









































	     (boxh   25)
	     (gapx   20)
	     (gapy   30)
	     (tests-hash     (hash-table-ref tests-draw-state 'tests-info))
	     (selected-tests (hash-table-ref tests-draw-state 'selected-tests )))
	(hash-table-set! tests-draw-state 'xtorig xtorig)
	(hash-table-set! tests-draw-state 'ytorig ytorig)
	(let ((longest-str   (car (sort sorted-testnames (lambda (a b)(>= (string-length a)(string-length b)))))))
	  (let-values (((x-max y-max) (canvas-text-size cnv longest-str)))
             (if (> x-max boxw)(set! boxw (+ 10 x-max)))))
	;; (print "sizex: " sizex " sizey: " sizey " font: " (canvas-font cnv) " originx: " originx " originy: " originy " xtorig: " xtorig " ytorig: " ytorig " xadj: " xadj " yadj: " yadj)

	(let loop ((hed (car (reverse sorted-testnames)))
		   (tal (cdr (reverse sorted-testnames)))
		   (llx xtorig)
		   (lly ytorig)
		   (urx (+ xtorig boxw))
		   (ury (+ ytorig boxh)))
	  ; (print "hed " hed " llx " llx " lly " lly " urx " urx " ury " ury)
	  (dcommon:draw-test cnv llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f))
	  ;; data used by mouse click calc. keep the wacky order for now.
	  (hash-table-set! tests-hash hed  (list llx urx (- sizey ury)(- sizey lly) lly boxw boxh)) 
	  ;; (list llx lly boxw boxh)) ;; NB// Swap ury and lly
	  (if (not (null? tal))
	      ;; leave a column of space to the right to list items
	      (let ((have-room 
		     (if #t ;; put "auto" here where some form of auto rearanging can be done
			 (> (* 3 (+ boxw gapx)) (- urx xtorig))
			 (< urx (- sizex boxw gapx boxw)))))  ;; is there room for another column?
		(loop (car tal)
		      (cdr tal)
		      (if have-room (+ llx boxw gapx) xtorig) ;; have room, 
		      (if have-room lly (+ lly boxh gapy))
		      (if have-room (+ urx boxw gapx) (+ xtorig boxw))
		      (if have-room ury (+ ury boxh gapy))))))))

(define (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames)
  (let* ((scalef (hash-table-ref/default tests-draw-state 'scalef 8))
	 (test-browse-xoffset (hash-table-ref tests-draw-state 'test-browse-xoffset))
	 (test-browse-yoffset (hash-table-ref tests-draw-state 'test-browse-yoffset))
	 (xtorig (+ test-browse-xoffset (* (/ sizex 2) scalef (- 0.5 xadj)))) ;;  (- xadj 1))))
	 (ytorig (+ test-browse-yoffset (* (/ sizey 2) scalef (- yadj 0.5))))
	 (xdelta (- (hash-table-ref tests-draw-state 'xtorig) xtorig))
	 (ydelta (- (hash-table-ref tests-draw-state 'ytorig) ytorig))
	 (tests-hash     (hash-table-ref tests-draw-state 'tests-info))
	 (selected-tests (hash-table-ref tests-draw-state 'selected-tests )))
    (hash-table-set! tests-draw-state 'xtorig xtorig)
    (hash-table-set! tests-draw-state 'ytorig ytorig)

    (let loop ((hed (car (reverse sorted-testnames)))
	       (tal (cdr (reverse sorted-testnames))))
      (let* ((tvals (hash-table-ref tests-hash hed))
	     (llx   (+ xdelta (list-ref tvals 0)))
	     (lly   (+ ydelta (list-ref tvals 4)))
	     (boxw  (list-ref tvals 5))
	     (boxh  (list-ref tvals 6))
	     (urx   (+ llx boxw))
	     (ury   (+ lly boxh)))
	(dcommon:draw-test cnv llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f))
	(hash-table-set! tests-hash hed (list llx urx (- sizey ury)(- sizey lly) lly boxw boxh))
	(if (not (null? tal))
	    ;; leave a column of space to the right to list items
	    (loop (car tal)
		  (cdr tal)))))))

















































|



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













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

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
	     (boxh   25)
	     (gapx   20)
	     (gapy   30)
	     (tests-hash     (hash-table-ref tests-draw-state 'tests-info))
	     (selected-tests (hash-table-ref tests-draw-state 'selected-tests )))
	(hash-table-set! tests-draw-state 'xtorig xtorig)
	(hash-table-set! tests-draw-state 'ytorig ytorig)
	(let ((longest-str   (if (null? sorted-testnames) "         " (car (sort sorted-testnames (lambda (a b)(>= (string-length a)(string-length b))))))))
	  (let-values (((x-max y-max) (canvas-text-size cnv longest-str)))
             (if (> x-max boxw)(set! boxw (+ 10 x-max)))))
	;; (print "sizex: " sizex " sizey: " sizey " font: " (canvas-font cnv) " originx: " originx " originy: " originy " xtorig: " xtorig " ytorig: " ytorig " xadj: " xadj " yadj: " yadj)
	(if (not (null? sorted-testnames))
	    (let loop ((hed (car (reverse sorted-testnames)))
		       (tal (cdr (reverse sorted-testnames)))
		       (llx xtorig)
		       (lly ytorig)
		       (urx (+ xtorig boxw))
		       (ury (+ ytorig boxh)))
					; (print "hed " hed " llx " llx " lly " lly " urx " urx " ury " ury)
	      (dcommon:draw-test cnv llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f))
	      ;; data used by mouse click calc. keep the wacky order for now.
	      (hash-table-set! tests-hash hed  (list llx urx (- sizey ury)(- sizey lly) lly boxw boxh)) 
	      ;; (list llx lly boxw boxh)) ;; NB// Swap ury and lly
	      (if (not (null? tal))
		  ;; leave a column of space to the right to list items
		  (let ((have-room 
			 (if #t ;; put "auto" here where some form of auto rearanging can be done
			     (> (* 3 (+ boxw gapx)) (- urx xtorig))
			     (< urx (- sizex boxw gapx boxw)))))  ;; is there room for another column?
		    (loop (car tal)
			  (cdr tal)
			  (if have-room (+ llx boxw gapx) xtorig) ;; have room, 
			  (if have-room lly (+ lly boxh gapy))
			  (if have-room (+ urx boxw gapx) (+ xtorig boxw))
			  (if have-room ury (+ ury boxh gapy)))))))))

(define (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames)
  (let* ((scalef (hash-table-ref/default tests-draw-state 'scalef 8))
	 (test-browse-xoffset (hash-table-ref tests-draw-state 'test-browse-xoffset))
	 (test-browse-yoffset (hash-table-ref tests-draw-state 'test-browse-yoffset))
	 (xtorig (+ test-browse-xoffset (* (/ sizex 2) scalef (- 0.5 xadj)))) ;;  (- xadj 1))))
	 (ytorig (+ test-browse-yoffset (* (/ sizey 2) scalef (- yadj 0.5))))
	 (xdelta (- (hash-table-ref tests-draw-state 'xtorig) xtorig))
	 (ydelta (- (hash-table-ref tests-draw-state 'ytorig) ytorig))
	 (tests-hash     (hash-table-ref tests-draw-state 'tests-info))
	 (selected-tests (hash-table-ref tests-draw-state 'selected-tests )))
    (hash-table-set! tests-draw-state 'xtorig xtorig)
    (hash-table-set! tests-draw-state 'ytorig ytorig)
    (if (not (null? sorted-testnames))
	(let loop ((hed (car (reverse sorted-testnames)))
		   (tal (cdr (reverse sorted-testnames))))
	  (let* ((tvals (hash-table-ref tests-hash hed))
		 (llx   (+ xdelta (list-ref tvals 0)))
		 (lly   (+ ydelta (list-ref tvals 4)))
		 (boxw  (list-ref tvals 5))
		 (boxh  (list-ref tvals 6))
		 (urx   (+ llx boxw))
		 (ury   (+ lly boxh)))
	    (dcommon:draw-test cnv llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f))
	    (hash-table-set! tests-hash hed (list llx urx (- sizey ury)(- sizey lly) lly boxw boxh))
	    (if (not (null? tal))
		;; leave a column of space to the right to list items
		(loop (car tal)
		      (cdr tal))))))))

;;======================================================================
;;  S T E P S
;;======================================================================

(define (dcommon:populate-steps teststeps steps-matrix)
  (let ((max-row 0))
    (if (null? teststeps)
	(iup:attribute-set! steps-matrix "CLEARVALUE" "CONTENTS")
	(let loop ((hed    (car teststeps))
		   (tal    (cdr teststeps))
		   (rownum 1)
		   (colnum 1))
	  (if (> rownum max-row)(set! max-row rownum))
	  (let ((val     (vector-ref hed (- colnum 1)))
		(mtrx-rc (conc rownum ":" colnum)))
	    (iup:attribute-set! steps-matrix  mtrx-rc (if val (conc val) ""))
	    (if (< colnum 6)
		(loop hed tal rownum (+ colnum 1))
		(if (not (null? tal))
		    (loop (car tal)(cdr tal)(+ rownum 1) 1))))))
    (if (> max-row 0)
	(begin
	  ;; we are going to speculatively clear rows until we find a row that is already cleared
	  (let loop ((rownum  (+ max-row 1))
		     (colnum  0)
		     (deleted #f))
	    ;; (debug:print-info 0 "cleaning " rownum ":" colnum)
	    (let* ((next-row (if (eq? colnum 6) (+ rownum 1) rownum))
		   (next-col (if (eq? colnum 6) 1 (+ colnum 1)))
		   (mtrx-rc  (conc rownum ":" colnum))
		   (curr-val (iup:attribute steps-matrix mtrx-rc)))
	      ;; (debug:print-info 0 "cleaning " rownum ":" colnum " currval= " curr-val)
	      (if (and (string? curr-val)
		       (not (equal? curr-val "")))
		  (begin
		    (iup:attribute-set! steps-matrix mtrx-rc "")
		    (loop next-row next-col #t))
		  (if (eq? colnum 6) ;; not done, didn't get a full blank row
		      (if deleted (loop next-row next-col #f)) ;; exit on this not met
		      (loop next-row next-col deleted)))))
	  (iup:attribute-set! steps-matrix "REDRAW" "ALL")))))

Modified docs/html/megatest.html from [637f8cb216] to [d407d07366].

1
2
3
4
5
6
7
8
9
10
11
12
13
14
<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
<head>
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8"/>
<meta name="generator" content="http://www.nongnu.org/elyxer/"/>
<meta name="create-date" content="2012-01-29"/>
<link rel="stylesheet" href="http://elyxer.nongnu.org/lyx.css" type="text/css" media="all"/>
<title>Megatest User Manual</title>
</head>
<body>
<div id="globalWrapper">
<div class="Standard">







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
<head>
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8"/>
<meta name="generator" content="http://www.nongnu.org/elyxer/"/>
<meta name="create-date" content="2014-01-25"/>
<link rel="stylesheet" href="http://elyxer.nongnu.org/lyx.css" type="text/css" media="all"/>
<title>Megatest User Manual</title>
</head>
<body>
<div id="globalWrapper">
<div class="Standard">

780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
<h2 class="Subsection">
<a class="toc" name="toc-Subsection-13.1">13.1</a> Monitor logic
</h2>
<div class="Standard">
Note: The monitor is usable but incomplete as of Megatest v1.31. Click on the &ldquo;Monitor&rdquo; button on the dashboard to start the monitor and give it a try.
</div>
<div class="Standard">
<img class="embedded" src="monitor-state-diagram.png" alt="figure monitor-state-diagram.png" style="max-width: 383px; max-height: 335px;"/>

</div>
<h1 class="Section">
<a class="toc" name="toc-Section-14">14</a> Reference
</h1>
<h2 class="Subsection">
<a class="toc" name="toc-Subsection-14.1">14.1</a> Configuration file Syntax







|







780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
<h2 class="Subsection">
<a class="toc" name="toc-Subsection-13.1">13.1</a> Monitor logic
</h2>
<div class="Standard">
Note: The monitor is usable but incomplete as of Megatest v1.31. Click on the &ldquo;Monitor&rdquo; button on the dashboard to start the monitor and give it a try.
</div>
<div class="Standard">
<img class="embedded" src="monitor-state-diagram.png" alt="figure monitor-state-diagram.png" style="max-width: 531px; max-height: 465px;"/>

</div>
<h1 class="Section">
<a class="toc" name="toc-Section-14">14</a> Reference
</h1>
<h2 class="Subsection">
<a class="toc" name="toc-Subsection-14.1">14.1</a> Configuration file Syntax
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
</h1>
<h1 class="Section">
<a class="toc" name="toc-Appendix-B">B</a> References
</h1>

<hr class="footer"/>
<div class="footer" id="generated-by">
Document generated by <a href="http://elyxer.nongnu.org/">eLyXer 1.2.2 (2011-06-12)</a> on <span class="create-date">2012-01-29T19:15:57.445316</span>
</div>
</div>
</body>
</html>







|




1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
</h1>
<h1 class="Section">
<a class="toc" name="toc-Appendix-B">B</a> References
</h1>

<hr class="footer"/>
<div class="footer" id="generated-by">
Document generated by <a href="http://elyxer.nongnu.org/">eLyXer 1.2.3 (2011-08-31)</a> on <span class="create-date">2014-01-25T22:27:14.268137</span>
</div>
</div>
</body>
</html>

Modified docs/html/monitor-state-diagram.png from [14f1bb59f3] to [83e4cb1ce3].

cannot compute difference between binary files

Modified docs/manual/Makefile from [c10ea440f6] to [038153bc89].


1
2
3
4
5






6
7


megatest_manual.html : megatest_manual.txt getting_started.txt writing_tests.txt reference.txt ../plan.txt
	asciidoc megatest_manual.txt
	dos2unix megatest_manual.html







clean:
	rm -f megatest_manual.html
>





>
>
>
>
>
>


1
2
3
4
5
6
7
8
9
10
11
12
13
14
all : server.pdf megatest_manual.html client.pdf

megatest_manual.html : megatest_manual.txt getting_started.txt writing_tests.txt reference.txt ../plan.txt
	asciidoc megatest_manual.txt
	dos2unix megatest_manual.html

server.pdf : server.dot
	dot -Tpdf server.dot > server.pdf
	
client.pdf : client.dot
	dot -Tpdf client.dot > client.pdf

clean:
	rm -f megatest_manual.html

Added docs/manual/client.dot version [23d472e170].







































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
digraph G {

    // put client after server so server_start node is visible
    //
    subgraph cluster_2 {
        node [style=filled,shape=box];
	
	"client:setup start"     -> runremote_lookup_server;
	runremote_lookup_server  -> login_attempt [label="have server"];
	runremote_lookup_server  -> monitordb_lookup_server [label="no server"];

	monitordb_lookup_server  -> login_attempt [label="have server"];
	monitordb_lookup_server  -> server_start_remote [label="no server"];

	server_start_remote      -> delay_2_sec;
	delay_2_sec              -> runremote_lookup_server;

	login_attempt            -> "rmt:send-receive_start" [label="login sucessful"];
	"rmt:send-receive_start" -> "rmt:send-receive_start";

	"rmt:send-receive_start" -> runremote_lookup_server [label=exception];
	login_attempt            -> clear_runremote [label="login failed"];

	"remove_running > 5s"    -> runremote_lookup_server;

	subgraph cluster_3 {
		node [style=filled];
		clear_runremote          -> "remove_running > 5s";
	}

        label = "client:setup";
        color=green;
    }

}

Modified docs/manual/howto.txt from [ad8e0484e1] to [b28c4b0da6].

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



How To Do Things
================

Tricks
------

This section is a compendium of a various useful tricks for debugging,
configuring and generally getting the most out of Megatest.
























Debugging Tricks
----------------

Examining The Environment
~~~~~~~~~~~~~~~~~~~~~~~~~

During Config File Processing
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

Organising Your Tests and Tasks
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
/nfs/ch/disks/ch_unienv_disk005/qa_mrwellan/interim/src/megatest/tests/fdktestqa/testqa
----------------------------
[tests-paths]
1 #{get misc parent}/simplerun/tests
----------------------------

-------------------
[setup]
-------------------

The runscript method is a brute force way to run scripts where the
user is responsible for setting STATE and STATUS

-------------------
runscript main.csh
-------------------


ww30.2
cellname/LVS/cellname.LAYOUT_ERRORS

Error: text open

ww31.3
cellname/LVS/cellname.LAYOUT_ERRORS


Error: text open











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












|
















|
<
<
|
<

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

How To Do Things
================

Tricks
------

This section is a compendium of a various useful tricks for debugging,
configuring and generally getting the most out of Megatest.

Limiting your running jobs
--------------------------

The following example will limit a test in the jobgroup "group1" to no more than 10 tests simultaneously.

In your testconfig:

----------------
[test_meta]
jobgroup group1
----------------

In your megatest.config:

---------------
[jobgroups]
group1 10
custdes 4
---------------




Debugging Tricks
----------------

Examining The Environment
~~~~~~~~~~~~~~~~~~~~~~~~~

During Config File Processing
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

Organising Your Tests and Tasks
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

----------------------------
[tests-paths]
1 #{get misc parent}/simplerun/tests
----------------------------

-------------------
[setup]
-------------------

The runscript method is a brute force way to run scripts where the
user is responsible for setting STATE and STATUS

-------------------
runscript main.csh
-------------------

Debugging Server Problems


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




----------------
sudo lsof -i
sudo netstat -lptu
sudo netstat -tulpn
----------------

Modified docs/manual/megatest_manual.html from [25f641c57e] to [151c9a3dda].

1
2
3
4
5
6
7
8
9
10
11
12
13
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN"
    "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en">
<head>
<meta http-equiv="Content-Type" content="application/xhtml+xml; charset=UTF-8" />
<meta name="generator" content="AsciiDoc 8.6.7" />
<title>The Megatest Users Manual</title>
<style type="text/css">
/* Shared CSS for AsciiDoc xhtml11 and html5 backends */

/* Default font. */
body {
  font-family: Georgia,serif;





|







1
2
3
4
5
6
7
8
9
10
11
12
13
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN"
    "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en">
<head>
<meta http-equiv="Content-Type" content="application/xhtml+xml; charset=UTF-8" />
<meta name="generator" content="AsciiDoc 8.6.9" />
<title>The Megatest Users Manual</title>
<style type="text/css">
/* Shared CSS for AsciiDoc xhtml11 and html5 backends */

/* Default font. */
body {
  font-family: Georgia,serif;
83
84
85
86
87
88
89
90



91
92
93



94
95
96
97
98
99
100

ul, ol, li > p {
  margin-top: 0;
}
ul > li     { color: #aaa; }
ul > li > * { color: black; }

pre {



  padding: 0;
  margin: 0;
}




#author {
  color: #527bbd;
  font-weight: bold;
  font-size: 1.1em;
}
#email {







|
>
>
>



>
>
>







83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106

ul, ol, li > p {
  margin-top: 0;
}
ul > li     { color: #aaa; }
ul > li > * { color: black; }

.monospaced, code, pre {
  font-family: "Courier New", Courier, monospace;
  font-size: inherit;
  color: navy;
  padding: 0;
  margin: 0;
}
pre {
  white-space: pre-wrap;
}

#author {
  color: #527bbd;
  font-weight: bold;
  font-size: 1.1em;
}
#email {
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229

div.exampleblock > div.content {
  border-left: 3px solid #dddddd;
  padding-left: 0.5em;
}

div.imageblock div.content { padding-left: 0; }
span.image img { border-style: none; }
a.image:visited { color: white; }

dl {
  margin-top: 0.8em;
  margin-bottom: 0.8em;
}
dt {







|







221
222
223
224
225
226
227
228
229
230
231
232
233
234
235

div.exampleblock > div.content {
  border-left: 3px solid #dddddd;
  padding-left: 0.5em;
}

div.imageblock div.content { padding-left: 0; }
span.image img { border-style: none; vertical-align: text-bottom; }
a.image:visited { color: white; }

dl {
  margin-top: 0.8em;
  margin-bottom: 0.8em;
}
dt {
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430


/*
 * xhtml11 specific
 *
 * */

tt {
  font-family: "Courier New", Courier, monospace;
  font-size: inherit;
  color: navy;
}

div.tableblock {
  margin-top: 1.0em;
  margin-bottom: 1.5em;
}
div.tableblock > table {
  border: 3px solid #527bbd;
}







<
<
<
<
<
<







417
418
419
420
421
422
423






424
425
426
427
428
429
430


/*
 * xhtml11 specific
 *
 * */







div.tableblock {
  margin-top: 1.0em;
  margin-bottom: 1.5em;
}
div.tableblock > table {
  border: 3px solid #527bbd;
}
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469


/*
 * html5 specific
 *
 * */

.monospaced {
  font-family: "Courier New", Courier, monospace;
  font-size: inherit;
  color: navy;
}

table.tableblock {
  margin-top: 1.0em;
  margin-bottom: 1.5em;
}
thead, p.tableblock.header {
  font-weight: bold;
  color: #527bbd;







<
<
<
<
<
<







450
451
452
453
454
455
456






457
458
459
460
461
462
463


/*
 * html5 specific
 *
 * */







table.tableblock {
  margin-top: 1.0em;
  margin-bottom: 1.5em;
}
thead, p.tableblock.header {
  font-weight: bold;
  color: #527bbd;
535
536
537
538
539
540
541


542
543
544
545
546
547
548
body.manpage div.sectionbody {
  margin-left: 3em;
}

@media print {
  body.manpage div#toc { display: none; }
}


</style>
<script type="text/javascript">
/*<![CDATA[*/
var asciidoc = {  // Namespace.

/////////////////////////////////////////////////////////////////////
// Table Of Contents generator







>
>







529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
body.manpage div.sectionbody {
  margin-left: 3em;
}

@media print {
  body.manpage div#toc { display: none; }
}


</style>
<script type="text/javascript">
/*<![CDATA[*/
var asciidoc = {  // Namespace.

/////////////////////////////////////////////////////////////////////
// Table Of Contents generator
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
/*]]>*/
</script>
</head>
<body class="book">
<div id="header">
<h1>The Megatest Users Manual</h1>
<span id="author">Matt Welland</span><br />
<span id="email"><tt>&lt;<a href="mailto:matt@kiatoa.com">matt@kiatoa.com</a>&gt;</tt></span><br />
<span id="revnumber">version 1.0,</span>
<span id="revdate">April 2012</span>
</div>
<div id="content">
<div class="sect1">
<h2 id="_preface">Preface</h2>
<div class="sectionbody">







|







731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
/*]]>*/
</script>
</head>
<body class="book">
<div id="header">
<h1>The Megatest Users Manual</h1>
<span id="author">Matt Welland</span><br />
<span id="email"><code>&lt;<a href="mailto:matt@kiatoa.com">matt@kiatoa.com</a>&gt;</code></span><br />
<span id="revnumber">version 1.0,</span>
<span id="revdate">April 2012</span>
</div>
<div id="content">
<div class="sect1">
<h2 id="_preface">Preface</h2>
<div class="sectionbody">
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
which can launch jobs on local and remote Linux hosts. Currently
megatest uses the network filesystem to call home to your master
sqlite3 database.</p></div>
</div>
</div>
</div>
<h1 id="_road_map">Road Map</h1>
<div class="paragraph"><p>Note: This road-map is tentative and subject to change without notice.</p></div>




<div class="sect2">
<h3 id="_ww32">ww32</h3>


<div class="olist arabic"><ol class="arabic">
<li>
<p>
Rerun step and or subsequent steps from gui
</p>
</li>
<li>
<p>
Refresh test area files from gui
</p>
</li>
<li>
<p>
Clean and re-run button
</p>
</li>
<li>
<p>
Clean up STATE and STATUS handling.
</p>
<div class="olist loweralpha"><ol class="loweralpha">
<li>
<p>
Dashboard and Test control panel are reverse order - choose and fix
</p>
</li>
<li>
<p>
Move seldom used states and status to drop down selector
</p>
</li>
</ol></div>
</li>
<li>
<p>
Access test control panel when clicking on Run Summary tests

</p>
</li>
<li>
<p>
Feature: -generate-index-tree
</p>
</li>
<li>
<p>
Change specifing of state and status to use STATE1/STATUS1,STATE2/STATUS2
</p>
</li>
</ol></div>
</div>
<div class="sect2">
<h3 id="_ww33">ww33</h3>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
http api available for use with Perl, Ruby etc. scripts
</p>
</li>
<li>
<p>
megatest.config setup entries for:
</p>
<div class="olist loweralpha"><ol class="loweralpha">
<li>
<p>
run launching (e.g. /bin/sh %CMD% &gt; /dev/null)
</p>
</li>
<li>
<p>
browser "konqueror %FNAME%
</p>
</li>
</ol></div>
</li>
</ol></div>
</div>
<div class="sect2">
<h3 id="_ww34">ww34</h3>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
Mark dependent tests for clean/rerun -rerun-downstream
</p>
</li>
<li>
<p>
On run start check for defunct tests in RUNNING, LAUNCHED or REMOTEHOSTSTART and correct or notify
</p>
</li>
<li>
<p>
Fix: refresh of gui sometimes fails on last item (race condition?)
</p>
</li>
</ol></div>
</div>
<div class="sect2">
<h3 id="_ww35">ww35</h3>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
refdb: Add export of csv, json and sexp
</p>
</li>
<li>
<p>
Convert to using call-with-environment-variables where possible. Should allow handling of parallel runs in same process.
</p>
</li>
<li>
<p>
Re-work text interface wizards. Several bugs on record. Possibly convert to gui based.
</p>
</li>
<li>
<p>
Add to testconfig requirements section; launchlimiter scriptname, calls scriptname to check if ok to launch test
</p>
</li>
<li>
<p>
Refactor Run Summary view, currently very clumsy
</p>
</li>
<li>
<p>
Add option to show steps in Run Summary view
</p>
</li>
</ol></div>
</div>
<div class="sect2">
<h3 id="_ww36">ww36</h3>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
Refactor guis for resizeablity
</p>
</li>
<li>
<p>
Add filters to Run Summary view and Run Control view
</p>
</li>
<li>
<p>
Add to megatest.config or testconfig; rerunok STATE/STATUS,STATE/STATUS&#8230;
</p>
</li>
<li>
<p>
Launch gates for diskspace; /path/one&gt;1G,/path/two&gt;200M,/tmp&gt;5G,#{scheme <strong>toppath</strong>}&gt;1G

</p>
</li>
</ol></div>
</div>
<div class="sect2">
<h3 id="_bin_list">Bin List</h3>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
Quality improvements
</p>
<div class="olist loweralpha"><ol class="loweralpha">
<li>
<p>
Server stutters occasionally
</p>
</li>
<li>
<p>
Large number of items or tests still has some issues.
</p>
</li>
<li>
<p>
Code refactoring
</p>
</li>
<li>
<p>
Replace remote process with true API using json (supports Web app also)
</p>
</li>
</ol></div>
</li>
<li>
<p>
Streamline the gui
</p>
<div class="olist loweralpha"><ol class="loweralpha">
<li>
<p>
Everything resizable
</p>
</li>
<li>
<p>
Less clutter
</p>
</li>
<li>
<p>
Tool tips
</p>
</li>
<li>
<p>
Filters on Run Summary, Summary and Run Control panel

</p>
</li>
<li>
<p>
Built in log viewer (partially implemented)
</p>
</li>
<li>
<p>
Refactor the test control panel
</p>
</li>
</ol></div>
</li>
<li>
<p>
Help and documentation
</p>
<div class="olist loweralpha"><ol class="loweralpha">
<li>
<p>
Complete the user manual (I’ve been working on this lately).
</p>
</li>
<li>
<p>
Online help in the gui

</p>
</li>
</ol></div>
</li>
<li>
<p>
Streamlined install
</p>
<div class="olist loweralpha"><ol class="loweralpha">
<li>
<p>
Deployed version (download a location independent ready to run binary bundle)
</p>
</li>
<li>
<p>
Install Makefile (in progress, needed for Mike to install on VMs)
</p>
</li>
<li>
<p>
Added option to compile IUP (needed for VMs)
</p>
</li>
</ol></div>
</li>
<li>
<p>
Server side run launching
</p>
</li>
<li>
<p>
Support for re-running, cleaning etc. of individual steps (ezsteps makes this very easy to implement).
</p>
</li>
<li>
<p>
Launch process needs built in daemonizing (easy to do, just need to test it thoroughly).
</p>
</li>
<li>
<p>
Wizards for creating tests, regression areas (current ones are text only and limited).
</p>
</li>
<li>
<p>
Fully functional built in web service (currently you can browse runs but it is very simplistic).
</p>
</li>
<li>
<p>
Wildcards in runconfigs: e.g. [p1271/9/%/%]
</p>
</li>
<li>
<p>
Gui panels for editing megatest.config and runconfigs.config
</p>
</li>
<li>
<p>
Fully isolated tests (no use of NFS to see regression area files)
</p>
</li>
<li>
<p>
Windows version
</p>
</li>
</ol></div>
</div>
<h1 id="_getting_started">Getting Started</h1>
<div class="openblock">
<div class="title">Getting started with Megatest</div>
<div class="content">
<div class="paragraph"><p>How to install Megatest and set it up for running your regressions and continuous integration process.</p></div>
</div></div>







|
>
>
>
>

|
>
>



<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
>




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

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


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




<
<
<
<
<
|




<
>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






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




<
>




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

<
<
<
<
<



<
>


<
<


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




|


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







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
which can launch jobs on local and remote Linux hosts. Currently
megatest uses the network filesystem to call home to your master
sqlite3 database.</p></div>
</div>
</div>
</div>
<h1 id="_road_map">Road Map</h1>
<div class="paragraph"><p>Note 1: This road-map is tentative and subject to change without notice.</p></div>
<div class="paragraph"><p>Note 2: Starting over. Old plan is commented out.</p></div>
<div class="sect1">
<h2 id="_current_items">Current Items</h2>
<div class="sectionbody">
<div class="sect2">
<h3 id="_ww05_migrate_to_inmem_db">ww05 - migrate to inmem-db</h3>
<div class="paragraph"><p>Keep as much the same as possible. Add internal reference to almost
eliminate contention on db(s).</p></div>
<div class="olist arabic"><ol class="arabic">
<li>
<p>

































Add internal reference db
</p>
</li>
<li>
<p>
Verify that actions are accessing correct db










































</p>













<div class="olist loweralpha"><ol class="loweralpha">


<li>
<p>































-runtests  - inmem




</p>
</li>
<li>
<p>





-list-runs - local (but not megatest.db)
</p>
</li>
<li>
<p>

dashboard  - local (but not megatest.db)






























</p>
</li>
</ol></div>
</li>
<li>
<p>















Mirror db to /var/tmp&#8230;
</p>
</li>
<li>
<p>

Dashboard read db from per-run db.
</p>
</li>
<li>
<p>












Dashboard read db from /var/tmp
</p>





</li>
<li>
<p>

Runs register in tasks table in monitor.db
</p>
</li>


<li>
<p>



























Server polls tasks table for next action (in addition?)
</p>
</li>
<li>
<p>
Change run loop to execute in server, triggered by call to polling of tasks table
</p>
</li>



</ol></div>
</div>

























</div>
</div>
<h1 id="_getting_started">Getting Started</h1>
<div class="openblock">
<div class="title">Getting started with Megatest</div>
<div class="content">
<div class="paragraph"><p>How to install Megatest and set it up for running your regressions and continuous integration process.</p></div>
</div></div>
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
<h1 id="_how_to_do_things">How To Do Things</h1>
<div class="sect1">
<h2 id="_tricks">Tricks</h2>
<div class="sectionbody">
<div class="paragraph"><p>This section is a compendium of a various useful tricks for debugging,
configuring and generally getting the most out of Megatest.</p></div>
</div>



















</div>
<div class="sect1">
<h2 id="_debugging_tricks">Debugging Tricks</h2>
<div class="sectionbody">
<div class="sect2">
<h3 id="_examining_the_environment">Examining The Environment</h3>
<div class="sect3">
<h4 id="_during_config_file_processing">During Config File Processing</h4>
</div>
<div class="sect3">
<h4 id="_organising_your_tests_and_tasks">Organising Your Tests and Tasks</h4>
<div class="paragraph"><p>/nfs/ch/disks/ch_unienv_disk005/qa_mrwellan/interim/src/megatest/tests/fdktestqa/testqa</p></div>
<div class="listingblock">
<div class="content">
<pre><tt>[tests-paths]
1 #{get misc parent}/simplerun/tests</tt></pre>
</div></div>
<div class="listingblock">
<div class="content">
<pre><tt>[setup]</tt></pre>
</div></div>
<div class="paragraph"><p>The runscript method is a brute force way to run scripts where the
user is responsible for setting STATE and STATUS</p></div>
<div class="listingblock">
<div class="content">
<pre><tt>runscript main.csh</tt></pre>
</div></div>


<div class="paragraph"><p>ww30.2
cellname/LVS/cellname.LAYOUT_ERRORS</p></div>

<div class="paragraph"><p>Error: text open</p></div>
<div class="paragraph"><p>ww31.3



cellname/LVS/cellname.LAYOUT_ERRORS</p></div>
<div class="paragraph"><p>Error: text open
Reference</p></div>


<div class="exampleblock">

<div class="content">
<div class="paragraph"><p>Chapters grouped into book parts are at level 1 and can contain
sub-sections.</p></div>


<div class="listingblock">
<div class="content">
<pre><tt>[setup]</tt></pre>
</div></div>
<div class="paragraph"><p>The runscript method is a brute force way to run scripts where the
user is responsible for setting STATE and STATUS</p></div>
<div class="listingblock">
<div class="content">
<pre><tt>runscript main.csh</tt></pre>
</div></div>






<div class="listingblock">
<div class="content">
<pre><tt>[requirements]</tt></pre>
</div></div>



<div class="listingblock">
<div class="content">
<pre><tt># A normal waiton waits for the prior tests to be COMPLETED
# and PASS, CHECK or WAIVED
waiton test1 test2</tt></pre>
</div></div>



<div class="paragraph"><p>The default (i.e. if mode is not specified) is normal. All pre-dependent tests
must be COMPLETED and PASS, CHECK or WAIVED before the test will start</p></div>
<div class="listingblock">
<div class="content">
<pre><tt>mode   normal</tt></pre>
</div></div>
<div class="paragraph"><p>The toplevel mode requires only that the prior tests are COMPLETED.</p></div>
<div class="listingblock">
<div class="content">
<pre><tt>mode toplevel</tt></pre>
</div></div>
<div class="paragraph"><p>A item based waiton will start items in a test when the
same-named item is COMPLETED and PASS, CHECK or WAIVED
in the prior test</p></div>
<div class="listingblock">
<div class="content">
<pre><tt>mode itemmatch</tt></pre>
</div></div>
<div class="listingblock">
<div class="content">
<pre><tt># With a toplevel test you may wish to generate your list
# of tests to run dynamically
#
# waiton #{shell get-valid-tests-to-run.sh}</tt></pre>
</div></div>



<div class="listingblock">
<div class="content">
<pre><tt>runtimelim 1h 2m 3s  # this will automatically kill the test if it runs for more than 1h 2m and 3s</tt></pre>
</div></div>






<div class="listingblock">
<div class="content">
<pre><tt>[skip]</tt></pre>
</div></div>



<div class="listingblock">
<div class="content">
<pre><tt># NB// If the prevrunning line exists with *any* value the test will
# automatically SKIP if the same-named test is currently RUNNING

prevrunning x</tt></pre>
</div></div>



<div class="listingblock">
<div class="content">
<pre><tt>fileexists /path/to/a/file # skip if /path/to/a/file exists</tt></pre>
</div></div>



<div class="paragraph"><p>If test is FAIL and previous test in run with same MT_TARGET is WAIVED then apply the following rules from the testconfig:
If a waiver check is specified in the testconfig apply the check and if it passes then set this FAIL to WAIVED</p></div>
<div class="paragraph"><p>Waiver check has two parts, 1) a list of waiver, rulename, filepatterns and 2) the rulename script spec (note that "diff" and "logpro" are predefined)</p></div>
<div class="listingblock">
<div class="content">
<pre><tt>###### EXAMPLE FROM testconfig #########
# matching file(s) will be diff'd with previous run and logpro applied
# if PASS or WARN result from logpro then WAIVER state is set
#
[waivers]
# logpro_file    rulename      input_glob
waiver_1         logpro        lookittmp.log

[waiver_rules]

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

# This builtin rule is applied if a &lt;waivername&gt;.logpro file exists
# logpro diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html</tt></pre>
</div></div>




<div class="paragraph"><p>To transfer the environment to the next step you can do the following:</p></div>
<div class="listingblock">
<div class="content">
<pre><tt>$MT_MEGATEST -env2file .ezsteps/${stepname}</tt></pre>
</div></div>



































































































































<div class="paragraph"><p>One or more optional appendixes go here at section level zero.</p></div>


<div class="admonitionblock">
<table><tr>
<td class="icon">
<div class="title">Note</div>
</td>
<td class="content">Preface and appendix subsections start out of sequence at level
2 (level 1 is skipped).  This only applies to multi-part book
documents.</td>
</tr></table>
</div>






<div class="paragraph"><p>The bibliography list is a style of AsciiDoc bulleted list.</p></div>
<div class="ulist bibliography"><ul>
<li>
<p>
<a id="taoup"></a>[taoup] Eric Steven Raymond. <em>The Art of Unix
  Programming</em>. Addison-Wesley. ISBN 0-13-142901-9.
</p>
</li>
<li>
<p>
<a id="walsh-muellner"></a>[walsh-muellner] Norman Walsh &amp; Leonard Muellner.
  <em>DocBook - The Definitive Guide</em>. O&#8217;Reilly &amp; Associates. 1999.
  ISBN 1-56592-580-7.
</p>
</li>
</ul></div>





<div class="paragraph"><p>Glossaries are optional. Glossaries entries are an example of a style
of AsciiDoc labeled lists.</p></div>
<div class="dlist glossary"><dl>
<dt>
A glossary term
</dt>
<dd>
<p>
  The corresponding (indented) definition.
</p>
</dd>
<dt>
A second glossary term
</dt>
<dd>
<p>
  The corresponding (indented) definition.
</p>
</dd>
</dl></div>





<div class="paragraph"><p>Text at the end of a book describing facts about its production.</p></div>
</div></div>
</div>
</div>



</div>
</div>
</div>
<div id="footnotes"><hr /></div>
<div id="footer">
<div id="footer-text">
Version 1.0<br />
Last updated 2014-02-13 21:27:42 MST
</div>
</div>
</body>
</html>







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











<


|
|



|





|

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


|





|

>
>
>
>
>
>


|

>
>
>


|

|

>
>
>




|




|






|



|


|

>
>
>


|

>
>
>
>
>
>


|

>
>
>


|


|

>
>
>


|

>
>
>





|













|

>
>
>
>



|

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

>
>










>
>
>
>
>
>
















>
>
>
>
>




















>
>
>
>
>

<


>
>
>







|




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
<h1 id="_how_to_do_things">How To Do Things</h1>
<div class="sect1">
<h2 id="_tricks">Tricks</h2>
<div class="sectionbody">
<div class="paragraph"><p>This section is a compendium of a various useful tricks for debugging,
configuring and generally getting the most out of Megatest.</p></div>
</div>
</div>
<div class="sect1">
<h2 id="_limiting_your_running_jobs">Limiting your running jobs</h2>
<div class="sectionbody">
<div class="paragraph"><p>The following example will limit a test in the jobgroup "group1" to no more than 10 tests simultaneously.</p></div>
<div class="paragraph"><p>In your testconfig:</p></div>
<div class="listingblock">
<div class="content">
<pre><code>[test_meta]
jobgroup group1</code></pre>
</div></div>
<div class="paragraph"><p>In your megatest.config:</p></div>
<div class="listingblock">
<div class="content">
<pre><code>[jobgroups]
group1 10
custdes 4</code></pre>
</div></div>
</div>
</div>
<div class="sect1">
<h2 id="_debugging_tricks">Debugging Tricks</h2>
<div class="sectionbody">
<div class="sect2">
<h3 id="_examining_the_environment">Examining The Environment</h3>
<div class="sect3">
<h4 id="_during_config_file_processing">During Config File Processing</h4>
</div>
<div class="sect3">
<h4 id="_organising_your_tests_and_tasks">Organising Your Tests and Tasks</h4>

<div class="listingblock">
<div class="content">
<pre><code>[tests-paths]
1 #{get misc parent}/simplerun/tests</code></pre>
</div></div>
<div class="listingblock">
<div class="content">
<pre><code>[setup]</code></pre>
</div></div>
<div class="paragraph"><p>The runscript method is a brute force way to run scripts where the
user is responsible for setting STATE and STATUS</p></div>
<div class="listingblock">
<div class="content">
<pre><code>runscript main.csh</code></pre>
</div></div>
</div>
</div>
<div class="sect2">

<h3 id="_debugging_server_problems">Debugging Server Problems</h3>
<div class="listingblock">
<div class="content">
<pre><code>sudo lsof -i
sudo netstat -lptu
sudo netstat -tulpn</code></pre>
</div></div>
</div>
</div>
</div>
<h1 id="_reference">Reference</h1>
<div class="sect1">
<h2 id="_the_testconfig_file">The testconfig File</h2>
<div class="sectionbody">
<div class="sect2">
<h3 id="_setup_section">Setup section</h3>
<div class="sect3">
<h4 id="_header">Header</h4>
<div class="listingblock">
<div class="content">
<pre><code>[setup]</code></pre>
</div></div>
<div class="paragraph"><p>The runscript method is a brute force way to run scripts where the
user is responsible for setting STATE and STATUS</p></div>
<div class="listingblock">
<div class="content">
<pre><code>runscript main.csh</code></pre>
</div></div>
</div>
</div>
<div class="sect2">
<h3 id="_requirements_section">Requirements section</h3>
<div class="sect3">
<h4 id="_header_2">Header</h4>
<div class="listingblock">
<div class="content">
<pre><code>[requirements]</code></pre>
</div></div>
</div>
<div class="sect3">
<h4 id="_wait_on_other_tests">Wait on Other Tests</h4>
<div class="listingblock">
<div class="content">
<pre><code># A normal waiton waits for the prior tests to be COMPLETED
# and PASS, CHECK or WAIVED
waiton test1 test2</code></pre>
</div></div>
</div>
<div class="sect3">
<h4 id="_mode">Mode</h4>
<div class="paragraph"><p>The default (i.e. if mode is not specified) is normal. All pre-dependent tests
must be COMPLETED and PASS, CHECK or WAIVED before the test will start</p></div>
<div class="listingblock">
<div class="content">
<pre><code>mode   normal</code></pre>
</div></div>
<div class="paragraph"><p>The toplevel mode requires only that the prior tests are COMPLETED.</p></div>
<div class="listingblock">
<div class="content">
<pre><code>mode toplevel</code></pre>
</div></div>
<div class="paragraph"><p>A item based waiton will start items in a test when the
same-named item is COMPLETED and PASS, CHECK or WAIVED
in the prior test</p></div>
<div class="listingblock">
<div class="content">
<pre><code>mode itemmatch</code></pre>
</div></div>
<div class="listingblock">
<div class="content">
<pre><code># With a toplevel test you may wish to generate your list
# of tests to run dynamically
#
# waiton #{shell get-valid-tests-to-run.sh}</code></pre>
</div></div>
</div>
<div class="sect3">
<h4 id="_run_time_limit">Run time limit</h4>
<div class="listingblock">
<div class="content">
<pre><code>runtimelim 1h 2m 3s  # this will automatically kill the test if it runs for more than 1h 2m and 3s</code></pre>
</div></div>
</div>
<div class="sect3">
<h4 id="_skip">Skip</h4>
</div>
<div class="sect3">
<h4 id="_header_3">Header</h4>
<div class="listingblock">
<div class="content">
<pre><code>[skip]</code></pre>
</div></div>
</div>
<div class="sect3">
<h4 id="_skip_on_still_running_tests">Skip on Still-running Tests</h4>
<div class="listingblock">
<div class="content">
<pre><code># NB// If the prevrunning line exists with *any* value the test will
# automatically SKIP if the same-named test is currently RUNNING

prevrunning x</code></pre>
</div></div>
</div>
<div class="sect3">
<h4 id="_skip_if_a_file_exists">Skip if a File Exists</h4>
<div class="listingblock">
<div class="content">
<pre><code>fileexists /path/to/a/file # skip if /path/to/a/file exists</code></pre>
</div></div>
</div>
<div class="sect3">
<h4 id="_controlled_waiver_propagation">Controlled waiver propagation</h4>
<div class="paragraph"><p>If test is FAIL and previous test in run with same MT_TARGET is WAIVED then apply the following rules from the testconfig:
If a waiver check is specified in the testconfig apply the check and if it passes then set this FAIL to WAIVED</p></div>
<div class="paragraph"><p>Waiver check has two parts, 1) a list of waiver, rulename, filepatterns and 2) the rulename script spec (note that "diff" and "logpro" are predefined)</p></div>
<div class="listingblock">
<div class="content">
<pre><code>###### EXAMPLE FROM testconfig #########
# matching file(s) will be diff'd with previous run and logpro applied
# if PASS or WARN result from logpro then WAIVER state is set
#
[waivers]
# logpro_file    rulename      input_glob
waiver_1         logpro        lookittmp.log

[waiver_rules]

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

# This builtin rule is applied if a &lt;waivername&gt;.logpro file exists
# logpro diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html</code></pre>
</div></div>
</div>
</div>
<div class="sect2">
<h3 id="_ezsteps">Ezsteps</h3>
<div class="paragraph"><p>To transfer the environment to the next step you can do the following:</p></div>
<div class="listingblock">
<div class="content">
<pre><code>$MT_MEGATEST -env2file .ezsteps/${stepname}</code></pre>
</div></div>
</div>
<div class="sect2">
<h3 id="_triggers">Triggers</h3>
<div class="paragraph"><p>In your testconfig triggers can be specified</p></div>
<div class="listingblock">
<div class="content">
<pre><code>[triggers]

# Call script running.sh when test goes to state=RUNNING, status=PASS
RUNNING/PASS running.sh

# Call script running.sh any time state goes to RUNNING
RUNNING/ running.sh

# Call script onpass.sh any time status goes to PASS
PASS/ onpass.sh</code></pre>
</div></div>
<div class="paragraph"><p>Scripts called will have; test-id test-rundir trigger, added to the commandline.</p></div>
<div class="paragraph"><p>HINT</p></div>
<div class="paragraph"><p>To start an xterm (useful for debugging), use a command line like the following:</p></div>
<div class="listingblock">
<div class="content">
<pre><code>[triggers]
COMPLETED/ xterm -e bash -s --</code></pre>
</div></div>
<div class="admonitionblock">
<table><tr>
<td class="icon">
<div class="title">Note</div>
</td>
<td class="content">There is a trailing space after the --</td>
</tr></table>
</div>
</div>
</div>
</div>
<div class="sect1">
<h2 id="_programming_api">Programming API</h2>
<div class="sectionbody">
<div class="paragraph"><p>These routines can be called from the megatest repl.</p></div>
<div class="tableblock">
<table rules="all"
width="70%"
frame="hsides"
cellspacing="0" cellpadding="4">
<caption class="title">Table 2. API Server Management Calls</caption>
<col width="14%" />
<col width="28%" />
<col width="28%" />
<col width="28%" />
<thead>
<tr>
<th align="center" valign="top">API Call                  </th>
<th align="left" valign="top"> Purpose comments   </th>
<th align="left" valign="top"> Returns                 </th>
<th align="left" valign="top"> Comments</th>
</tr>
</thead>
<tfoot>
<tr>
<td align="center" valign="top"><p class="table">(rmt:login        run-id)</p></td>
<td align="left" valign="top"><p class="table"><code>Verify the the version, testsuite area etc. are correct.</code></p></td>
<td align="left" valign="top"><p class="table"><code>#( #t "successful login" )</code></p></td>
<td align="left" valign="top"><p class="table"><code></code></p></td>
</tr>
</tfoot>
<tbody>
<tr>
<td align="center" valign="top"><p class="table">(rmt:start-server run-id)</p></td>
<td align="left" valign="top"><p class="table"><code></code></p></td>
<td align="left" valign="top"><p class="table"><code>#( success/fail   n/a )</code></p></td>
<td align="left" valign="top"><p class="table"><code></code></p></td>
</tr>
<tr>
<td align="center" valign="top"><p class="table">(rmt:kill-server  run-id)</p></td>
<td align="left" valign="top"><p class="table"><code></code></p></td>
<td align="left" valign="top"><p class="table"><code>#( success/fail   n/a )</code></p></td>
<td align="left" valign="top"><p class="table"><code>Works only if the server is still reachable</code></p></td>
</tr>
</tbody>
</table>
</div>
<div class="tableblock">
<table rules="all"
width="70%"
frame="hsides"
cellspacing="0" cellpadding="4">
<caption class="title">Table 3. API Keys Related Calls</caption>
<col width="14%" />
<col width="28%" />
<col width="28%" />
<col width="28%" />
<thead>
<tr>
<th align="center" valign="top">API Call                        </th>
<th align="left" valign="top"> Purpose comments   </th>
<th align="left" valign="top"> Returns                 </th>
<th align="left" valign="top"> Comments</th>
</tr>
</thead>
<tfoot>
<tr>
<td align="center" valign="top"><p class="table">(rmt:get-key-val-pairs run-id)</p></td>
<td align="left" valign="top"><p class="table"><code></code></p></td>
<td align="left" valign="top"><p class="table"><code>#t=success/#f=fail</code></p></td>
<td align="left" valign="top"><p class="table"><code>Works only if the server is still reachable</code></p></td>
</tr>
</tfoot>
<tbody>
<tr>
<td align="center" valign="top"><p class="table">(rmt:get-keys run-id)</p></td>
<td align="left" valign="top"><p class="table"><code></code></p></td>
<td align="left" valign="top"><p class="table"><code>( key1 key2 &#8230; )</code></p></td>
<td align="left" valign="top"><p class="table"><code></code></p></td>
</tr>
</tbody>
</table>
</div>
<div class="sect2">
<h3 id="_megatest_internals">Megatest Internals</h3>
<div class="imageblock graphviz">
<div class="content">
<img src="server.png" alt="server.png" />
</div>
</div>
</div>
</div>
</div>
<div class="sect1">
<h2 id="_example_appendix">Appendix A: Example Appendix</h2>
<div class="sectionbody">
<div class="paragraph"><p>One or more optional appendixes go here at section level zero.</p></div>
<div class="sect2">
<h3 id="_appendix_sub_section">Appendix Sub-section</h3>
<div class="admonitionblock">
<table><tr>
<td class="icon">
<div class="title">Note</div>
</td>
<td class="content">Preface and appendix subsections start out of sequence at level
2 (level 1 is skipped).  This only applies to multi-part book
documents.</td>
</tr></table>
</div>
</div>
</div>
</div>
<div class="sect1">
<h2 id="_example_bibliography">Example Bibliography</h2>
<div class="sectionbody">
<div class="paragraph"><p>The bibliography list is a style of AsciiDoc bulleted list.</p></div>
<div class="ulist bibliography"><ul>
<li>
<p>
<a id="taoup"></a>[taoup] Eric Steven Raymond. <em>The Art of Unix
  Programming</em>. Addison-Wesley. ISBN 0-13-142901-9.
</p>
</li>
<li>
<p>
<a id="walsh-muellner"></a>[walsh-muellner] Norman Walsh &amp; Leonard Muellner.
  <em>DocBook - The Definitive Guide</em>. O&#8217;Reilly &amp; Associates. 1999.
  ISBN 1-56592-580-7.
</p>
</li>
</ul></div>
</div>
</div>
<div class="sect1">
<h2 id="_example_glossary">Example Glossary</h2>
<div class="sectionbody">
<div class="paragraph"><p>Glossaries are optional. Glossaries entries are an example of a style
of AsciiDoc labeled lists.</p></div>
<div class="dlist glossary"><dl>
<dt>
A glossary term
</dt>
<dd>
<p>
  The corresponding (indented) definition.
</p>
</dd>
<dt>
A second glossary term
</dt>
<dd>
<p>
  The corresponding (indented) definition.
</p>
</dd>
</dl></div>
</div>
</div>
<div class="sect1">
<h2 id="_example_colophon">Example Colophon</h2>
<div class="sectionbody">
<div class="paragraph"><p>Text at the end of a book describing facts about its production.</p></div>

</div>
</div>
<div class="sect1">
<h2 id="_example_index">Example Index</h2>
<div class="sectionbody">
</div>
</div>
</div>
<div id="footnotes"><hr /></div>
<div id="footer">
<div id="footer-text">
Version 1.0<br />
Last updated 2014-11-25 21:11:28 MST
</div>
</div>
</body>
</html>

Modified docs/manual/megatest_manual.txt from [20ce759875] to [38919c0414].

46
47
48
49
50
51
52









53
54
55
56
57
58
59
sqlite3 database.

include::../plan.txt[]
include::getting_started.txt[]
include::writing_tests.txt[]
include::howto.txt[]
include::reference.txt[]










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

Appendix Sub-section







>
>
>
>
>
>
>
>
>







46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
sqlite3 database.

include::../plan.txt[]
include::getting_started.txt[]
include::writing_tests.txt[]
include::howto.txt[]
include::reference.txt[]

Megatest Internals
~~~~~~~~~~~~~~~~~~

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


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

Appendix Sub-section

Modified docs/manual/reference.txt from [6d8b51499a] to [ddb57ef21a].

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16

Reference
=========

The First Chapter of the Second Part
------------------------------------
Chapters grouped into book parts are at level 1 and can contain
sub-sections.

The testconfig File
-------------------

Setup section
~~~~~~~~~~~~~

Header




<
<
<
<
<







1
2
3
4





5
6
7
8
9
10
11

Reference
=========






The testconfig File
-------------------

Setup section
~~~~~~~~~~~~~

Header
144
145
146
147
148
149
150
151






















































152
153
~~~~~~~

To transfer the environment to the next step you can do the following:

----------------------------
$MT_MEGATEST -env2file .ezsteps/${stepname}	  
----------------------------























































:numbered!:









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


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

To transfer the environment to the next step you can do the following:

----------------------------
$MT_MEGATEST -env2file .ezsteps/${stepname}	  
----------------------------

Triggers
~~~~~~~~

In your testconfig triggers can be specified 

-----------------
[triggers]

# Call script running.sh when test goes to state=RUNNING, status=PASS
RUNNING/PASS running.sh

# Call script running.sh any time state goes to RUNNING
RUNNING/ running.sh

# Call script onpass.sh any time status goes to PASS
PASS/ onpass.sh
-----------------

Scripts called will have; test-id test-rundir trigger, added to the commandline.

HINT

To start an xterm (useful for debugging), use a command line like the following:

-----------------
[triggers]
COMPLETED/ xterm -e bash -s -- 
-----------------

NOTE: There is a trailing space after the --

Programming API
---------------

These routines can be called from the megatest repl. 

.API Server Management Calls
[width="70%",cols="^,2m,2m,2m",frame="topbot",options="header,footer"]
|======================
|API Call                  | Purpose comments   | Returns                 | Comments
|(rmt:start-server run-id) |                    | #( success/fail   n/a ) | 
|(rmt:kill-server  run-id) |                    | #( success/fail   n/a ) | Works only if the server is still reachable
|(rmt:login        run-id) | Verify the the version, testsuite area etc. are correct. | #( #t "successful login" ) |
|======================

.API Keys Related Calls
[width="70%",cols="^,2m,2m,2m",frame="topbot",options="header,footer"]
|======================
|API Call                        | Purpose comments   | Returns                 | Comments
|(rmt:get-keys run-id)           |                    | ( key1 key2 ... )       | 
| (rmt:get-key-val-pairs run-id) |                    | #t=success/#f=fail      | Works only if the server is still reachable
|======================


:numbered!:

Added docs/manual/server.dot version [5b6f6b599f].





























































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
digraph G {

    subgraph cluster_1 {
        node [style=filled,shape=box];

	check_available_queue       -> remove_entries_over_10s_old;
	remove_entries_over_10s_old -> set_available [label="num_avail < 3"];
	remove_entries_over_10s_old -> exit [label="num_avail > 2"];

	set_available               -> delay_2s;
	delay_2s          -> check_place_in_queue;

	check_place_in_queue        -> "http:transport-launch" [label="at head"];
	check_place_in_queue        -> exit [label="not at head"];

	"client:login"              -> "server:shutdown" [label="login failed"];
	"server:shutdown"           -> exit;	

	subgraph cluster_2 {
		"http:transport-launch"       -> "http:transport-run";
		"http:transport-launch"       -> "http:transport-keep-running";

		"http:transport-keep-running" -> "tests running?";
		"tests running?"              -> "client:login" [label=yes];
		"tests running?"              -> "server:shutdown" [label=no];
		"client:login"                -> delay_5s [label="login ok"];
		delay_5s                      -> "http:transport-keep-running";
	}

	// start_server -> "server_running?";
	// "server_running?" -> set_available [label="no"];
	// "server_running?" -> delay_2s [label="yes"];
	// delay_2s -> "still_running?";
	// "still_running?" -> ping_server [label=yes];
	// "still_running?" -> set_available [label=no];
	// ping_server -> exit [label=alive];
	// ping_server -> remove_server_record [label=dead];
	// remove_server_record -> set_available;
	// set_available -> avail_delay [label="delay 3s"];
	// avail_delay -> "first_in_queue?";
	// 
	// "first_in_queue?" -> set_running [label=yes];
	// set_running -> get_next_port -> handle_requests;
	// "first_in_queue?" -> "dead_entry_in_queue?" [label=no];
	// "dead_entry_in_queue?" -> "server_running?" [label=no];
	// "dead_entry_in_queue?" -> "remove_dead_entries" [label=yes];
	// remove_dead_entries -> "server_running?";
	// 
	// handle_requests -> start_shutdown [label="no traffic\nno running tests"];
	// handle_requests -> shutdown_request;
	// start_shutdown -> shutdown_delay;
	// shutdown_request -> shutdown_delay;
	// shutdown_delay -> exit;
	
        label = "server:launch";
        color=brown;
    }

//     client_start_server -> start_server;
//     handle_requests -> read_write;
//     read_write -> handle_requests;
}

Added docs/manual/server.pdf version [710fc5512e].

cannot compute difference between binary files

Added docs/manual/server.png version [a508d3edd1].

cannot compute difference between binary files

Modified docs/plan.txt from [a80831142b] to [0ead7d4df0].

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
Road Map
========

Note: This road-map is tentative and subject to change without notice.


ww32


~~~~





. Rerun step and or subsequent steps from gui


. Refresh test area files from gui



. Clean and re-run button
. Clean up STATE and STATUS handling.
.. Dashboard and Test control panel are reverse order - choose and fix



.. Move seldom used states and status to drop down selector
. Access test control panel when clicking on Run Summary tests
. Feature: -generate-index-tree
. Change specifing of state and status to use STATE1/STATUS1,STATE2/STATUS2














ww33
~~~~

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

ww34
~~~~

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

ww35
~~~~

. refdb: Add export of csv, json and sexp
. Convert to using call-with-environment-variables where possible. Should allow handling of parallel runs in same process.
. Re-work text interface wizards. Several bugs on record. Possibly convert to gui based.
. Add to testconfig requirements section; launchlimiter scriptname, calls scriptname to check if ok to launch test
. Refactor Run Summary view, currently very clumsy
. Add option to show steps in Run Summary view

ww36
~~~~

. Refactor guis for resizeablity
. Add filters to Run Summary view and Run Control view
. Add to megatest.config or testconfig; rerunok STATE/STATUS,STATE/STATUS...
. Launch gates for diskspace; /path/one>1G,/path/two>200M,/tmp>5G,#{scheme *toppath*}>1G

Bin List
~~~~~~~~

.	Quality improvements
..	Server stutters occasionally
..	Large number of items or tests still has some issues.
..	Code refactoring
..	Replace remote process with true API using json (supports Web app also)
.	Streamline the gui
..	Everything resizable
..	Less clutter
..	Tool tips
..	Filters on Run Summary, Summary and Run Control panel
..	Built in log viewer (partially implemented)
..	Refactor the test control panel
.	Help and documentation
..	Complete the user manual (I’ve been working on this lately).
..	Online help in the gui
.	Streamlined install
..	Deployed version (download a location independent ready to run binary bundle)
..	Install Makefile (in progress, needed for Mike to install on VMs)
..	Added option to compile IUP (needed for VMs)
.	Server side run launching
.	Support for re-running, cleaning etc. of individual steps (ezsteps makes this very easy to implement).
.	Launch process needs built in daemonizing (easy to do, just need to test it thoroughly).
.	Wizards for creating tests, regression areas (current ones are text only and limited).
.	Fully functional built in web service (currently you can browse runs but it is very simplistic).
.	Wildcards in runconfigs: e.g. [p1271/9/%/%]
.	Gui panels for editing megatest.config and runconfigs.config
.	Fully isolated tests (no use of NFS to see regression area files)
.	Windows version




|

>
|
>
>
|
>
>

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

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

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
Road Map
========

Note 1: This road-map is tentative and subject to change without notice.

Note 2: Starting over. Old plan is commented out.

Current Items
-------------

ww05 - migrate to inmem-db
~~~~~~~~~~~~~~~~~~~~~~~~~~

Keep as much the same as possible. Add internal reference to almost
eliminate contention on db(s). 

. Add internal reference db
. Verify that actions are accessing correct db
.. -runtests  - inmem
.. -list-runs - local (but not megatest.db)
.. dashboard  - local (but not megatest.db)
. Mirror db to /var/tmp...
. Dashboard read db from per-run db.

. Dashboard read db from /var/tmp
. Runs register in tasks table in monitor.db
. Server polls tasks table for next action (in addition?)
. Change run loop to execute in server, triggered by call to polling of tasks table





// ww32
// ~~~~
// 
// . Rerun step and or subsequent steps from gui
// . Refresh test area files from gui
// . Clean and re-run button
// . Clean up STATE and STATUS handling.
// .. Dashboard and Test control panel are reverse order - choose and fix
// .. Move seldom used states and status to drop down selector
// . Access test control panel when clicking on Run Summary tests
// . Feature: -generate-index-tree
// . Change specifing of state and status to use STATE1/STATUS1,STATE2/STATUS2
// 
// ww33
// ~~~~
// 
// . http api available for use with Perl, Ruby etc. scripts
// . megatest.config setup entries for:
// .. run launching (e.g. /bin/sh %CMD% > /dev/null)
// .. browser "konqueror %FNAME%
// 
// ww34
// ~~~~
// 
// . Mark dependent tests for clean/rerun -rerun-downstream
// . On run start check for defunct tests in RUNNING, LAUNCHED or REMOTEHOSTSTART and correct or notify
// . Fix: refresh of gui sometimes fails on last item (race condition?)
// 
// ww35
// ~~~~
// 
// . refdb: Add export of csv, json and sexp
// . Convert to using call-with-environment-variables where possible. Should allow handling of parallel runs in same process.
// . Re-work text interface wizards. Several bugs on record. Possibly convert to gui based.
// . Add to testconfig requirements section; launchlimiter scriptname, calls scriptname to check if ok to launch test
// . Refactor Run Summary view, currently very clumsy
// . Add option to show steps in Run Summary view
// 
// ww36
// ~~~~
// 
// . Refactor guis for resizeablity
// . Add filters to Run Summary view and Run Control view
// . Add to megatest.config or testconfig; rerunok STATE/STATUS,STATE/STATUS...
// . Launch gates for diskspace; /path/one>1G,/path/two>200M,/tmp>5G,#{scheme *toppath*}>1G
// 
// Bin List
// ~~~~~~~~
// 
// .	Quality improvements
// ..	Server stutters occasionally
// ..	Large number of items or tests still has some issues.
// ..	Code refactoring
// ..	Replace remote process with true API using json (supports Web app also)
// .	Streamline the gui
// ..	Everything resizable
// ..	Less clutter
// ..	Tool tips
// ..	Filters on Run Summary, Summary and Run Control panel
// ..	Built in log viewer (partially implemented)
// ..	Refactor the test control panel
// .	Help and documentation
// ..	Complete the user manual (I’ve been working on this lately).
// ..	Online help in the gui
// .	Streamlined install
// ..	Deployed version (download a location independent ready to run binary bundle)
// ..	Install Makefile (in progress, needed for Mike to install on VMs)
// ..	Added option to compile IUP (needed for VMs)
// .	Server side run launching
// .	Support for re-running, cleaning etc. of individual steps (ezsteps makes this very easy to implement).
// .	Launch process needs built in daemonizing (easy to do, just need to test it thoroughly).
// .	Wizards for creating tests, regression areas (current ones are text only and limited).
// .	Fully functional built in web service (currently you can browse runs but it is very simplistic).
// .	Wildcards in runconfigs: e.g. [p1271/9/%/%]
// .	Gui panels for editing megatest.config and runconfigs.config
// .	Fully isolated tests (no use of NFS to see regression area files)
// .	Windows version

Added docs/results.pdf version [8c482a4606].

cannot compute difference between binary files

Modified ezsteps.scm from [5bdb7484d4] to [18ab86f9c8].

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
(import (prefix sqlite3 sqlite3:))

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



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

(define (ezsteps:run-from testdat start-step-name run-one)

  (let* ((test-run-dir  (db:test-get-rundir testdat))
	 (testconfig    (read-config (conc test-run-dir "/testconfig") #f #t environ-patt: "pre-launch-env-vars"))
	 (ezstepslst    (hash-table-ref/default testconfig "ezsteps" '()))
	 (run-mutex     (make-mutex))
	 (rollup-status 0)
	 (exit-info     (vector #t #t #t))
	 (test-id       (db:test-get-id testdat))

	 (test-name     (db:test-get-testname testdat))
	 (kill-job      #f)) ;; for future use (on re-factoring with launch.scm code
    (let loop ((count 5))
      (if (file-exists? test-run-dir)
	  (push-directory test-run-dir)
	  (if (> count 0)
	      (begin







>
>







>
|






>







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
(import (prefix sqlite3 sqlite3:))

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

(define (ezsteps:run-from testdat start-step-name run-one)
  (let* ((test-run-dir  ;; (filedb:get-path *fdb* 
	  (db:test-get-rundir testdat)) ;; )
	 (testconfig    (read-config (conc test-run-dir "/testconfig") #f #t environ-patt: "pre-launch-env-vars"))
	 (ezstepslst    (hash-table-ref/default testconfig "ezsteps" '()))
	 (run-mutex     (make-mutex))
	 (rollup-status 0)
	 (exit-info     (vector #t #t #t))
	 (test-id       (db:test-get-id testdat))
	 (run-id        (db:test-get-run_id testdat))
	 (test-name     (db:test-get-testname testdat))
	 (kill-job      #f)) ;; for future use (on re-factoring with launch.scm code
    (let loop ((count 5))
      (if (file-exists? test-run-dir)
	  (push-directory test-run-dir)
	  (if (> count 0)
	      (begin
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
		  
		  (if (file-exists? (conc stepname ".logpro"))(set! logpro-used #t))
		  
		  ;; call the command using mt_ezstep
		  (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd))
		  
		  (debug:print 4 "script: " script)
		  ;; DO NOT remote
		  (db:teststep-set-status! #f test-id stepname "start" "-" #f #f work-area: test-run-dir)
		  ;; now launch
		  (let ((pid (process-run script)))
		    (let processloop ((i 0))
		      (let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
				  (mutex-lock! run-mutex)
				  (vector-set! exit-info 0 pid)
				  (vector-set! exit-info 1 exit-status)
				  (vector-set! exit-info 2 exit-code)
				  (mutex-unlock! run-mutex)
				  (if (eq? pid-val 0)
				      (begin
					(thread-sleep! 1)
					(processloop (+ i 1))))
				  ))
		    (let ((exinfo (vector-ref exit-info 2))
			  (logfna (if logpro-used (conc stepname ".html") "")))
		      ;; testing if procedures called in a remote call cause problems (ans: no or so I suspect)
		      (db:teststep-set-status! #f test-id stepname "end" exinfo #f logfna work-area: test-run-dir))
		    (if logpro-used
			(cdb:test-set-log! *runremote*  test-id (conc stepname ".html")))
		    ;; set the test final status
		    (let* ((this-step-status (cond
					      ((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn)
					      ((eq? (vector-ref exit-info 2) 0)                   'pass)
					      (else 'fail)))
			   (overall-status   (cond
					      ((eq? rollup-status 2) 'warn)







<
|
















<
|

|







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
		  
		  (if (file-exists? (conc stepname ".logpro"))(set! logpro-used #t))
		  
		  ;; call the command using mt_ezstep
		  (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd))
		  
		  (debug:print 4 "script: " script)

		  (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f)
		  ;; now launch
		  (let ((pid (process-run script)))
		    (let processloop ((i 0))
		      (let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
				  (mutex-lock! run-mutex)
				  (vector-set! exit-info 0 pid)
				  (vector-set! exit-info 1 exit-status)
				  (vector-set! exit-info 2 exit-code)
				  (mutex-unlock! run-mutex)
				  (if (eq? pid-val 0)
				      (begin
					(thread-sleep! 1)
					(processloop (+ i 1))))
				  ))
		    (let ((exinfo (vector-ref exit-info 2))
			  (logfna (if logpro-used (conc stepname ".html") "")))

		      (rmt:teststep-set-status! run-id test-id stepname "end" exinfo #f logfna))
		    (if logpro-used
			(rmt:test-set-log! test-id (conc stepname ".html")))
		    ;; set the test final status
		    (let* ((this-step-status (cond
					      ((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn)
					      ((eq? (vector-ref exit-info 2) 0)                   'pass)
					      (else 'fail)))
			   (overall-status   (cond
					      ((eq? rollup-status 2) 'warn)
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
		      (if (not run-one) ;; if we got here we completed the step, if run-one is true, stop
			  (loop (car tal) (cdr tal) stepname runflag))))
		(debug:print 4 "WARNING: a prior step failed, stopping at " ezstep)))
	  
	  ;; Once done with step/steps update the test record
	  ;;
	  (let* ((item-path (db:test-get-item-path testdat)) ;; (item-list->path itemdat))
		 (testinfo  (cdb:get-test-info-by-id *runremote* test-id))) ;; refresh the testdat, call it iteminfo in case need prev/curr
	    ;; Am I completed?
	    (if (equal? (db:test-get-state testinfo) "RUNNING") ;; (not (equal? (db:test-get-state testinfo) "COMPLETED"))
		(let ((new-state  (if kill-job "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status
				  ;; "COMPLETED"
				  ;; (db:test-get-state testinfo)))   ;; else preseve the state as set within the test
				  )
		      (new-status (cond







|







138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
		      (if (not run-one) ;; if we got here we completed the step, if run-one is true, stop
			  (loop (car tal) (cdr tal) stepname runflag))))
		(debug:print 4 "WARNING: a prior step failed, stopping at " ezstep)))
	  
	  ;; Once done with step/steps update the test record
	  ;;
	  (let* ((item-path (db:test-get-item-path testdat)) ;; (item-list->path itemdat))
		 (testinfo  (rmt:get-testinfo-by-id run-id test-id))) ;; refresh the testdat, call it iteminfo in case need prev/curr
	    ;; Am I completed?
	    (if (equal? (db:test-get-state testinfo) "RUNNING") ;; (not (equal? (db:test-get-state testinfo) "COMPLETED"))
		(let ((new-state  (if kill-job "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status
				  ;; "COMPLETED"
				  ;; (db:test-get-state testinfo)))   ;; else preseve the state as set within the test
				  )
		      (new-status (cond

Modified filedb.scm from [d77bc6ba17] to [91e90bcdc7].

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
	 (dbexists (file-exists? dbpath))
	 (db (sqlite3:open-database dbpath)))
    (filedb:fdb-set-db!        fdb db)
    (filedb:fdb-set-dbpath!    fdb dbpath)
    (filedb:fdb-set-pathcache! fdb (make-hash-table))
    (filedb:fdb-set-idcache!   fdb (make-hash-table))
    (filedb:fdb-set-partcache! fdb (make-hash-table))
    ;(sqlite3:set-busy-timeout! db 1000000)
    (if (not dbexists)
	(begin
	  (sqlite3:execute db "PRAGMA synchronous = OFF;")
	  (sqlite3:execute db "CREATE TABLE names (id INTEGER PRIMARY KEY,name TEST);") ;; for future use - change path in paths table to path_id
	  (sqlite3:execute db "CREATE INDEX name_index ON names (name);")
	  ;; NB// We store a useful subset of file attributes but do not attempt to store all
	  (sqlite3:execute db "CREATE TABLE paths (id        INTEGER PRIMARY KEY,
                                                   path      TEXT,
                                                   parent_id INTEGER,
                                                   mode      INTEGER DEFAULT -1,
                                                   uid       INTEGER DEFAULT -1,
                                                   gid       INTEGER DEFAULT -1,
                                                   size      INTEGER DEFAULT -1,
                                                   mtime     INTEGER DEFAULT -1);")
	  (sqlite3:execute db "CREATE INDEX path_index ON paths (path,parent_id);")
	  (sqlite3:execute db "CREATE TABLE bases (id INTEGER PRIMARY KEY,base TEXT,                  updated TIMESTAMP);")))



    fdb))






(define (filedb:finalize-db! fdb)
  (sqlite3:finalize! (filedb:fdb-get-db fdb)))

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

(define (filedb:get-base-id db path)







|
















>
>
>


>
>
>
>
>







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

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

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

(define (filedb:get-base-id db path)
106
107
108
109
110
111
112

113
114
115
116
117
118
119
    (sqlite3:finalize! stmt)))

(define (filedb:register-path fdb path #!key (save-stat #f))
  (let* ((db        (filedb:fdb-get-db        fdb))
	 (pathcache (filedb:fdb-get-pathcache fdb))
	 (stat      (if save-stat (file-stat path #t)))
	 (id        (hash-table-ref/default pathcache path #f)))

    (if id id 
        (let ((plist (string-split path "/")))
          (let loop ((head (car plist))
                     (tail (cdr plist))
                     (parent 0))
            (let ((id (filedb:get-path-id db head parent))
                  (done (null? tail)))







>







114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
    (sqlite3:finalize! stmt)))

(define (filedb:register-path fdb path #!key (save-stat #f))
  (let* ((db        (filedb:fdb-get-db        fdb))
	 (pathcache (filedb:fdb-get-pathcache fdb))
	 (stat      (if save-stat (file-stat path #t)))
	 (id        (hash-table-ref/default pathcache path #f)))
    (if (not db)(filedb:reopen-db fdb))
    (if id id 
        (let ((plist (string-split path "/")))
          (let loop ((head (car plist))
                     (tail (cdr plist))
                     (parent 0))
            (let ((id (filedb:get-path-id db head parent))
                  (done (null? tail)))
212
213
214
215
216
217
218

219
220
221
222
223
224
225
     parent-id search-patt)
    res))

(define (filedb:get-path fdb id)
  (let* ((db      (filedb:fdb-get-db      fdb))
	 (idcache (filedb:fdb-get-idcache fdb))
	 (path    (hash-table-ref/default idcache id #f)))

    (if path path
        (let loop ((curr-id id)
                   (path    ""))
          (let ((path-record (filedb:get-path-record fdb curr-id)))
            (if (not path-record) #f ;; this id has no path
                (let* ((parent-id (list-ref path-record 1))
                       (pname     (list-ref path-record 0))







>







221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
     parent-id search-patt)
    res))

(define (filedb:get-path fdb id)
  (let* ((db      (filedb:fdb-get-db      fdb))
	 (idcache (filedb:fdb-get-idcache fdb))
	 (path    (hash-table-ref/default idcache id #f)))
    (if (not db)(filedb:reopen-db fdb))
    (if path path
        (let loop ((curr-id id)
                   (path    ""))
          (let ((path-record (filedb:get-path-record fdb curr-id)))
            (if (not path-record) #f ;; this id has no path
                (let* ((parent-id (list-ref path-record 1))
                       (pname     (list-ref path-record 0))

Modified fs-transport.scm from [8a07492e90] to [d187681c70].

33
34
35
36
37
38
39
40
41
42
43
44
;;======================================================================

;; 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 *megatest-db*) ;; we will require that (launch:setup-for-run) has already been called
      (set! *megatest-db* (open-db)))
  (debug:print-info 11 "fs:process-queue-item called with packet=" packet)
  (db:process-queue-item *megatest-db* packet))
      







|




33
34
35
36
37
38
39
40
41
42
43
44
;;======================================================================

;; 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 *megatest-db*) ;; we will require that (setup-for-run) has already been called
      (set! *megatest-db* (open-db)))
  (debug:print-info 11 "fs:process-queue-item called with packet=" packet)
  (db:process-queue-item *megatest-db* packet))
      

Modified gutils.scm from [0911f9831f] to [b83aee11f3].

21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
	 (c2 (map string->number (string-split color2)))
	 (delta (map (lambda (a b)(abs (- a b))) c1 c2)))
    (null? (filter (lambda (x)(> x 3)) delta))))

(define (gutils:get-color-for-state-status state status);; #!key (get-label #f))
  ;; ((if get-label cadr car)
   (case (string->symbol state)
     ((COMPLETED)
      (case (string->symbol status)
	((PASS)        (list "70  249 73" status))
	((WARN WAIVED) (list "255 172 13" status))
	((SKIP)        (list "230 230 0" status))
	(else (list "223 33 49" status))))
     ;;      (if (equal? status "PASS")
     ;;	  '("70 249 73" "PASS")







|







21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
	 (c2 (map string->number (string-split color2)))
	 (delta (map (lambda (a b)(abs (- a b))) c1 c2)))
    (null? (filter (lambda (x)(> x 3)) delta))))

(define (gutils:get-color-for-state-status state status);; #!key (get-label #f))
  ;; ((if get-label cadr car)
   (case (string->symbol state)
     ((COMPLETED ARCHIVED)
      (case (string->symbol status)
	((PASS)        (list "70  249 73" status))
	((WARN WAIVED) (list "255 172 13" status))
	((SKIP)        (list "230 230 0" status))
	(else (list "223 33 49" status))))
     ;;      (if (equal? status "PASS")
     ;;	  '("70 249 73" "PASS")

Modified http-transport.scm from [b92335f5bd] to [c3c2fc0fe7].

23
24
25
26
27
28
29

30
31
32
33
34
35
36

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


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

(define (http-transport:make-server-url hostport)
  (if (not hostport)
      #f







>







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

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

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

(define (http-transport:make-server-url hostport)
  (if (not hostport)
      #f
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
	   (set! res adr)))
     (vector->list (hostinfo-addresses (hostname->hostinfo hostname))))
    (string-intersperse 
     (map number->string
	  (u8vector->list
	   (if res res (hostname->ip hostname)))) ".")))

(define (http-transport:run hostn)
  (debug:print 2 "Attempting to start the server ...")
  (if (not *toppath*)
      (if (not (launch:setup-for-run))
	  (begin
	    (debug:print 0 "ERROR: cannot find megatest.config, cannot start server, exiting")
	    (exit))))
  (let* (;; (iface           (if (string=? "-" hostn)
	 ;;        	      #f ;; (get-host-name) 
	 ;;        	      hostn))
	 (db              #f) ;;        (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily
	 (hostname        (get-host-name))
	 (ipaddrstr       (let ((ipstr (if (string=? "-" hostn)
					   ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
					   (server:get-best-guess-address hostname)
					   #f)))
			    (if ipstr ipstr hostn))) ;; hostname)))
	 (start-port    (if (and (args:get-arg "-port")
				 (string->number (args:get-arg "-port")))
			    (string->number (args:get-arg "-port"))
			    (if (and (config-lookup  *configdat* "server" "port")
				     (string->number (config-lookup  *configdat* "server" "port")))
				(string->number (config-lookup  *configdat* "server" "port"))
				(+ 5000 (random 1001)))))
	 (link-tree-path (config-lookup *configdat* "setup" "linktree")))
    (set! *cache-on* #t)

    (root-path     (if link-tree-path 
		       link-tree-path
		       (current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP!
    (handle-directory spiffy-directory-listing)






    ;; http-transport:handle-directory) ;; simple-directory-handler)
    ;; Setup the web server and a /ctrl interface
    ;;
    (vhost-map `(((* any) . ,(lambda (continue)
			       ;; open the db on the first call 
			       (if (not db)(set! db (open-db)))
			       (let* (($   (request-vars source: 'both))
				      (dat ($ 'dat))
				      (res #f))
				 (cond
				  ;; This is the /ctrl path where data is handed to the server and
				  ;; responses 
				  ((equal? (uri-path (request-uri (current-request)))
					   '(/ "ctrl"))
				   (let* ((packet (db:string->obj dat))

					  (qtype  (cdb:packet-get-qtype packet)))
				     (debug:print-info 12 "server=> received packet=" packet)
				     (if (not (member qtype '(sync ping)))
					 (begin
					   (mutex-lock! *heartbeat-mutex*)
					   (set! *last-db-access* (current-seconds))
					   (mutex-unlock! *heartbeat-mutex*)))
				     ;; (mutex-lock! *db:process-queue-mutex*) ;; trying a mutex
				     ;; (set! res (open-run-close db:process-queue-item open-db packet))
				     (set! res (db:process-queue-item db packet))
				     ;; (mutex-unlock! *db:process-queue-mutex*)
				     (debug:print-info 11 "Return value from db:process-queue-item is " res)
				     (send-response body: (conc "<head>ctrl data</head>\n<body>"
								res
								"</body>")
						    headers: '((content-type text/plain)))))
				  ((equal? (uri-path (request-uri (current-request))) 
					   '(/ ""))
				   (send-response body: (http-transport:main-page)))
				  ((equal? (uri-path (request-uri (current-request))) 
					   '(/ "runs"))
				   (send-response body: (http-transport:main-page)))
				  ((equal? (uri-path (request-uri (current-request))) 
					   '(/ any))
				   (send-response body: "hey there!\n"
						  headers: '((content-type text/plain))))
				  ((equal? (uri-path (request-uri (current-request))) 
					   '(/ "hey"))
				   (send-response body: "hey there!\n"
						  headers: '((content-type text/plain))))
				  (else (continue))))))))
    (http-transport:try-start-server ipaddrstr start-port)))

;; This is recursively run by http-transport:run until sucessful
;;
(define (http-transport:try-start-server ipaddrstr portnum)



  (handle-exceptions
   exn
   (begin
     (print-error-message exn)
     (if (< portnum 9000)
	 (begin 




	   (debug:print 0 "WARNING: failed to start on portnum: " portnum ", trying next port")
	   (thread-sleep! 0.1)
	   ;; (open-run-close tasks:remove-server-records tasks:open-db)
	   (open-run-close tasks:server-delete tasks:open-db ipaddrstr portnum)

	   (http-transport:try-start-server ipaddrstr (+ portnum 1)))





	 (print "ERROR: Tried and tried but could not start the server")))
   ;; any error in following steps will result in a retry
   (set! *runremote* (list ipaddrstr portnum))
   ;; (open-run-close tasks:remove-server-records tasks:open-db)
   (open-run-close tasks:server-register 
		   tasks:open-db 
		   (current-process-id)
		   ipaddrstr portnum 0 'startup 'http)
   (debug:print 1 "INFO: Trying to start server on " ipaddrstr ":" portnum)
   ;; This starts the spiffy server
   ;; NEED WAY TO SET IP TO #f TO BIND ALL
   (start-server bind-address: ipaddrstr port: portnum)


   (open-run-close tasks:server-delete tasks:open-db ipaddrstr portnum)




   (debug:print 1 "INFO: server has been stopped")))

;;======================================================================
;; S E R V E R   U T I L I T I E S 
;;======================================================================

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

(define *http-mutex* (make-mutex))



;; (system "megatest -list-servers | grep alive || megatest -server - -daemonize && sleep 4")






;; <html>


;; <head></head>
;; <body>1 Hello, world! Goodbye Dolly</body></html>
;; Send msg to serverdat and receive result
(define (http-transport:client-send-receive serverdat msg #!key (numretries 30))
  (let* (;; (url        (http-transport:make-server-url serverdat))


	 (fullurl    (if (list? serverdat)
			 (caddr serverdat)
			 (begin
			   (debug:print 0 "FATAL ERROR: http-transport:client-send-receive called with no server info")


			   (exit 1)))) ;; (conc url "/ctrl")) ;; (conc url "/?dat=" msg)))





	 (res        #f))












    (handle-exceptions



     exn





     (begin
       (print "ERROR IN http-transport:client-send-receive " ((condition-property-accessor 'exn 'message) exn))

       (thread-sleep! 2)





       (if (> numretries 0)








	   (http-transport:client-send-receive serverdat msg numretries: (- numretries 1))))
     (begin




       (debug:print-info 11 "fullurl=" fullurl "\n")
       ;; set up the http-client here
       (max-retry-attempts 5)
       ;; consider all requests indempotent
       (retry-request? (lambda (request)
			 #t))   ;;  		 (thread-sleep! (/ (if (> numretries 100) 100 numretries) 10))
       ;; (set! numretries (- numretries 1))
       ;;  		 #t))
       ;; send the data and get the response
       ;; extract the needed info from the http data and 
       ;; process and return it.
       (let* ((send-recieve (lambda ()
			      (mutex-lock! *http-mutex*)


















			      (set! res (with-input-from-request 
					 fullurl 
					 (list (cons 'dat msg)) 


					 read-string))


			      (close-all-connections!) 
			      (mutex-unlock! *http-mutex*)))

	      (time-out     (lambda ()
			      (thread-sleep! 45)
			      (if (not res)
				  (begin
				    (debug:print 0 "WARNING: communication with the server timed out.")
				    (mutex-unlock! *http-mutex*)
				    (http-transport:client-send-receive serverdat msg numretries: (- numretries 1))
				    (if (< numretries 3) ;; on last try just exit
					(begin
					  (debug:print 0 "ERROR: communication with the server timed out. Giving up.")
					  (exit 1)))))))
	      (th1 (make-thread send-recieve "with-input-from-request"))
	      (th2 (make-thread time-out     "time out")))
	 (thread-start! th1)
	 (thread-start! th2)
	 (thread-join! th1)
	 (thread-terminate! th2)
	 (debug:print-info 11 "got res=" res)














	 (let ((match (string-search (regexp "<body>(.*)<.body>") res)))









	   (debug:print-info 11 "match=" match)
	   (let ((final (cadr match)))








	     (debug:print-info 11 "final=" final)








	     final)))))))










(define (http-transport:client-connect iface port)
  (let* ((login-res   #f)
	 (uri-dat     (make-request method: 'POST uri: (uri-reference (conc "http://" iface ":" port "/ctrl"))))

	 (serverdat   (list iface port uri-dat)))
    (set! login-res (client:login serverdat))
    (if (and (not (null? login-res))
	     (car login-res))
	(begin
	  (debug:print-info 2 "Logged in and connected to " iface ":" port)
	  (set! *runremote* serverdat)
	  serverdat)
	(begin
	  (debug:print-info 0 "ERROR: Failed to login or connect to " iface ":" port)
	  (exit 1)))))
;; 	  (set! *runremote* #f)
;; 	  (set! *transport-type* 'fs)
;; 	  #f))))


;; run http-transport:keep-running in a parallel thread to monitor that the db is being 
;; used and to shutdown after sometime if it is not.
;;
(define (http-transport:keep-running)
  ;; if none running or if > 20 seconds since 
  ;; server last used then start shutdown
  ;; This thread waits for the server to come alive


  (let* ((server-info (let loop ()


                        (let ((sdat #f))


                          (mutex-lock! *heartbeat-mutex*)
                          (set! sdat *runremote*)
                          (mutex-unlock! *heartbeat-mutex*)
                          (if sdat


			      sdat
                              (begin

                                (sleep 4)







                                (loop))))))
         (iface       (car server-info))
         (port        (cadr server-info))
         (last-access 0)

	 (tdb         (tasks:open-db))
	 (spid        ;;(open-run-close tasks:server-get-server-id tasks:open-db #f iface port #f))
	   (tasks:server-get-server-id tdb #f iface port #f))

	 (server-timeout (let ((tmo (config-lookup  *configdat* "server" "timeout")))

			   (if (and (string? tmo)

				    (string->number tmo))

			       (* 60 60 (string->number tmo))


			       ;; default to three days
			       (* 3 24 60 60)))))

    (debug:print-info 2 "server-timeout: " server-timeout ", server pid: " spid " on " iface ":" port)
    (let loop ((count 0))
      (thread-sleep! 4) ;; no need to do this very often
      ;; NB// sync currently does NOT return queue-length
      (let () ;; (queue-len (cdb:client-call server-info 'sync #t 1)))
      ;; (print "Server running, count is " count)
        (if (< count 1) ;; 3x3 = 9 secs aprox



            (loop (+ count 1)))



        
	;; Check that iface and port have not changed (can happen if server port collides)
	(mutex-lock! *heartbeat-mutex*)

	(set! sdat *runremote*)
	(mutex-unlock! *heartbeat-mutex*)








	(if (or (not (equal? sdat (list iface port)))
		(not spid))
	    (begin 






















	      (debug:print-info 0 "interface changed, refreshing iface and port info")
	      (set! iface (car sdat))
	      (set! port  (cadr sdat))
	      (set! spid  (tasks:server-get-server-id tdb #f iface port #f))))

        ;; NOTE: Get rid of this mechanism! It really is not needed...
        ;; (open-run-close tasks:server-update-heartbeat tasks:open-db spid)
        (tasks:server-update-heartbeat tdb spid)
      
        ;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access
        (mutex-lock! *heartbeat-mutex*)
        (set! last-access *last-db-access*)
        (mutex-unlock! *heartbeat-mutex*)

	;; (debug:print 11 "last-access=" last-access ", server-timeout=" server-timeout)





        (if (and *server-run*
		 (> (+ last-access server-timeout)
		    (current-seconds)))
            (begin
              (debug:print-info 0 "Server continuing, seconds since last db access: " (- (current-seconds) last-access))







              (loop 0))

            (begin


              (debug:print-info 0 "Starting to shutdown the server.")
              ;; need to delete only *my* server entry (future use)
              (set! *time-to-exit* #t)





              (open-run-close tasks:server-deregister-self tasks:open-db (get-host-name))
              (thread-sleep! 1)
              (debug:print-info 0 "Max cached queries was    " *max-cache-size*)
	      (debug:print-info 0 "Number of cached writes   " *number-of-writes*)
	      (debug:print-info 0 "Average cached write time "
				(if (eq? *number-of-writes* 0)
				    "n/a (no writes)"
				    (/ *writes-total-delay*
				       *number-of-writes*))
				" ms")
	      (debug:print-info 0 "Number non-cached queries "  *number-non-write-queries*)
	      (debug:print-info 0 "Average non-cached time   "
				(if (eq? *number-non-write-queries* 0)
				    "n/a (no queries)"
				    (/ *total-non-write-delay* 
				       *number-non-write-queries*))
				" ms")
              (debug:print-info 0 "Server shutdown complete. Exiting")
              (exit)))))))

;; all routes though here end in exit ...
(define (http-transport:launch)
  (if (not *toppath*)
      (if (not (launch:setup-for-run))
	  (begin
	    (debug:print 0 "ERROR: cannot find megatest.config, exiting")
	    (exit))))
  (debug:print-info 2 "Starting the standalone server")
  (if (args:get-arg "-daemonize")
      (daemon:ize))
  (let ((hostinfo (open-run-close tasks:get-best-server tasks:open-db)))
    (debug:print 11 "http-transport:launch hostinfo=" hostinfo)
    ;; #(1 "143.182.207.24" 5736 -1 "http" 22771 "hostname")
    (if hostinfo
	(debug:print-info 2 "NOT starting new server, one is already running on " (vector-ref hostinfo 1) ":" (vector-ref hostinfo 2))
	(if *toppath* 
	    (let* ((th2 (make-thread (lambda ()
				       (http-transport:run 
					(if (args:get-arg "-server")
					    (args:get-arg "-server")
					    "-"))) "Server run"))
		   (th3 (make-thread http-transport:keep-running "Keep running"))
		   (th1 (make-thread server:write-queue-handler  "write queue")))
	      (thread-start! th2)
	      (thread-start! th3)
	      (thread-start! th1)
	      (set! *didsomething* #t)
	      (thread-join! th2))
	    (debug:print 0 "ERROR: Failed to setup for megatest")))
    (exit)))


;; (use trace)


;; (trace http-transport:keep-running 













;;        tasks:server-update-heartbeat

;;        tasks:server-get-server-id)



;;        tasks:get-best-server
;;        http-transport:run




;;        http-transport:launch


;;        http-transport:try-start-server
;;        http-transport:client-send-receive

;;        http-transport:make-server-url


;;        tasks:server-register


;;        tasks:server-delete

;;        start-server





;;        hostname->ip




;;        with-input-from-request
;;        tasks:server-deregister-self)






(define (http-transport:server-signal-handler signum)

  (handle-exceptions
   exn
   (debug:print " ... exiting ...")
   (let ((th1 (make-thread (lambda ()
			     (thread-sleep! 1))
			     ;; (if (not *received-response*)
			     ;;	 (receive-message* *runremote*))) ;; flush out last call if applicable
			   "eat response"))
	 (th2 (make-thread (lambda ()
			     (debug:print 0 "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.")
			     (thread-sleep! 3) ;; give the flush three seconds to do it's stuff
			     (debug:print 0 "       Done.")
			     (exit 4))
			   "exit on ^C timer")))







|

<
<
<
<
<
<
<
<
|





|
|
<
<
<
<
<
<
|
|
>




>
>
>
>
>
>





|




<
<

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















|



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











>
>
|
>
>
>

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

|


<
<
|





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


<
<
<
<
<
<
<
<
|







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

>
>
>

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




|



>
>
|
>
>

>
>

|

|
>
>


>

>
>
>
>
>
>
>
|



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

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


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


>





<
<







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
	   (set! res adr)))
     (vector->list (hostinfo-addresses (hostname->hostinfo hostname))))
    (string-intersperse 
     (map number->string
	  (u8vector->list
	   (if res res (hostname->ip hostname)))) ".")))

(define (http-transport:run hostn run-id server-id)
  (debug:print 2 "Attempting to start the server ...")








  (let* ((db              #f) ;;        (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily
	 (hostname        (get-host-name))
	 (ipaddrstr       (let ((ipstr (if (string=? "-" hostn)
					   ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
					   (server:get-best-guess-address hostname)
					   #f)))
			    (if ipstr ipstr hostn))) ;; hostname))) 
	 (start-port      (portlogger:open-run-close portlogger:find-port))






	 (link-tree-path  (configf:lookup *configdat* "setup" "linktree")))
    ;; (set! db *inmemdb*)
    (debug:print-info 0 "portlogger recommended port: " start-port)
    (root-path     (if link-tree-path 
		       link-tree-path
		       (current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP!
    (handle-directory spiffy-directory-listing)
    (handle-exception (lambda (exn chain)
			(signal (make-composite-condition
				 (make-property-condition 
				  'server
				  'message "server error")))))

    ;; http-transport:handle-directory) ;; simple-directory-handler)
    ;; Setup the web server and a /ctrl interface
    ;;
    (vhost-map `(((* any) . ,(lambda (continue)
			       ;; open the db on the first call 
				 ;; This is were we set up the database connections
			       (let* (($   (request-vars source: 'both))
				      (dat ($ 'dat))
				      (res #f))
				 (cond


				  ((equal? (uri-path (request-uri (current-request)))
					   '(/ "api"))

				   (send-response body:    (api:process-request *inmemdb* $) ;; the $ is the request vars proc
						  headers: '((content-type text/plain)))



				   (mutex-lock! *heartbeat-mutex*)
				   (set! *last-db-access* (current-seconds))
				   (mutex-unlock! *heartbeat-mutex*))









				  ((equal? (uri-path (request-uri (current-request))) 
					   '(/ ""))
				   (send-response body: (http-transport:main-page)))
				  ((equal? (uri-path (request-uri (current-request))) 
					   '(/ "runs"))
				   (send-response body: (http-transport:main-page)))
				  ((equal? (uri-path (request-uri (current-request))) 
					   '(/ any))
				   (send-response body: "hey there!\n"
						  headers: '((content-type text/plain))))
				  ((equal? (uri-path (request-uri (current-request))) 
					   '(/ "hey"))
				   (send-response body: "hey there!\n"
						  headers: '((content-type text/plain))))
				  (else (continue))))))))
    (http-transport:try-start-server run-id ipaddrstr start-port server-id)))

;; This is recursively run by http-transport:run until sucessful
;;
(define (http-transport:try-start-server run-id ipaddrstr portnum server-id)
  (let ((config-hostname (configf:lookup *configdat* "server" "hostname"))
	(tdbdat          (tasks:open-db)))
    (debug:print-info 0 "http-transport:try-start-server run-id=" run-id " ipaddrsstr=" ipaddrstr " portnum=" portnum " server-id=" server-id " config-hostname=" config-hostname)
    (handle-exceptions
     exn
     (begin
       (print-error-message exn)
       (if (< portnum 64000)
	   (begin 
	     (debug:print 0 "WARNING: attempt to start server failed. Trying again ...")
	     (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
	     (debug:print 0 "exn=" (condition->list exn))
	     (portlogger:open-run-close portlogger:set-failed portnum)
	     (debug:print 0 "WARNING: failed to start on portnum: " portnum ", trying next port")
	     (thread-sleep! 0.1)


	     ;; get_next_port goes here
	     (http-transport:try-start-server run-id
					      ipaddrstr
					      (portlogger:open-run-close portlogger:find-port)
					      server-id))
	   (begin
	     (tasks:server-force-clean-run-record (db:delay-if-busy tdbdat) run-id ipaddrstr portnum " http-transport:try-start-server")
	     (print "ERROR: Tried and tried but could not start the server"))))
     ;; any error in following steps will result in a retry
     (set! *server-info* (list ipaddrstr portnum))

     (tasks:server-set-interface-port 
		     (db:delay-if-busy tdbdat)
		     server-id 
		     ipaddrstr portnum)
     (debug:print 0 "INFO: Trying to start server on " ipaddrstr ":" portnum)
     ;; This starts the spiffy server
     ;; NEED WAY TO SET IP TO #f TO BIND ALL
     ;; (start-server bind-address: ipaddrstr port: portnum)
     (if config-hostname ;; this is a hint to bind directly
	 (start-server port: portnum bind-address: (if (equal? config-hostname "-")
						       ipaddrstr
						       config-hostname))
	 (start-server port: portnum))
     ;;  (portlogger:open-run-close portlogger:set-port portnum "released")
     (tasks:server-force-clean-run-record (db:delay-if-busy tdbdat) run-id ipaddrstr portnum " http-transport:try-start-server")
     (debug:print 1 "INFO: server has been stopped"))))

;;======================================================================
;; S E R V E R   U T I L I T I E S 
;;======================================================================

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

(define *http-mutex* (make-mutex))

;; NOTE: Large block of code from 32436b426188080f72fceb6894af541fbad9921e removed here
;;       I'm pretty sure it is defunct.

;; This next block all imported en-mass from the api branch
(define *http-requests-in-progress* 0)
(define *http-connections-next-cleanup* (current-seconds))

(define (http-transport:get-time-to-cleanup)
  (let ((res #f))
    (mutex-lock! *http-mutex*)
    (set! res (> (current-seconds) *http-connections-next-cleanup*))
    (mutex-unlock! *http-mutex*)
    res))


(define (http-transport:inc-requests-count)
  (mutex-lock! *http-mutex*)
  (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*))
  ;; Use this opportunity to slow things down iff there are too many requests in flight
  (if (> *http-requests-in-progress* 5)

      (begin
	(debug:print-info 0 "Whoa there buddy, ease up...")
	(thread-sleep! 1)))
  (mutex-unlock! *http-mutex*))

(define (http-transport:dec-requests-count proc) 
  (mutex-lock! *http-mutex*)
  (proc)
  (set! *http-requests-in-progress* (- *http-requests-in-progress* 1))
  (mutex-unlock! *http-mutex*))

(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 0 "ERROR: 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*)))

;; Send "cmd" with json payload "params" to serverdat and receive result
;;
(define (http-transport:client-api-send-receive run-id serverdat cmd params #!key (numretries 3))
  (let* ((fullurl    (if (vector? serverdat)
			 (http-transport:server-dat-get-api-req serverdat)
			 (begin
			   (debug:print 0 "FATAL ERROR: http-transport:client-api-send-receive called with no server info")
			   (exit 1))))
	 (res        #f)
	 (success    #t)
	 (sparams    (db:obj->string params transport: 'http)))
;;    (condition-case
;;     handle-exceptions
;;     exn
;;     (if (> numretries 0)
;;	 (begin
;;	   (mutex-unlock! *http-mutex*)
;;	   (thread-sleep! 1)
;;	   (handle-exceptions
;;	    exn
;;	    (debug:print 0 "WARNING: closing connections failed. Server at " fullurl " almost certainly dead")
;;	    (close-all-connections!))
;;	   (debug:print 0 "WARNING: Failed to communicate with server, trying again, numretries left: " numretries)
;;	   (http-transport:client-api-send-receive run-id serverdat cmd sparams numretries: (- numretries 1)))
;;	 (begin
;;	   (mutex-unlock! *http-mutex*)
;;	   (tasks:kill-server-run-id run-id)
;;	   #f))
;;     (begin
       (debug:print-info 11 "fullurl=" fullurl ", cmd=" cmd ", params=" params ", run-id=" run-id "\n")
       ;; set up the http-client here
       (max-retry-attempts 1)
       ;; consider all requests indempotent
       (retry-request? (lambda (request)


			 #f))
       ;; send the data and get the response
       ;; extract the needed info from the http data and 
       ;; process and return it.
       (let* ((send-recieve (lambda ()
			      (mutex-lock! *http-mutex*)
			      ;; (condition-case (with-input-from-request "http://localhost"; #f read-lines)
			      ;;					       ((exn http client-error) e (print e)))
			      (set! res (vector
					 success
					 (db:string->obj 
					  (handle-exceptions
					   exn
					   (begin
					     (set! success #f)
					     (debug:print 0 "WARNING: failure in with-input-from-request to " fullurl ".")
					     (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
					     (hash-table-delete! *runremote* run-id)
					     ;; Killing associated server to allow clean retry.")
					     (tasks:kill-server-run-id run-id)  ;; better to kill the server in the logic that called this routine?
					     (mutex-unlock! *http-mutex*)
					     (signal (make-composite-condition
						      (make-property-condition 'commfail 'message "failed to connect to server")))
					     "communications failed")
					   (with-input-from-request ;; was dat
					    fullurl 
					    (list (cons 'key "thekey")
						  (cons 'cmd cmd)
						  (cons 'params sparams))
					    read-string))
					  transport: 'http)))
			      ;; 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)








			      #f))
	      (th1 (make-thread send-recieve "with-input-from-request"))
	      (th2 (make-thread time-out     "time out")))
	 (thread-start! th1)
	 (thread-start! th2)
	 (thread-join! th1)
	 (thread-terminate! th2)
	 (debug:print-info 11 "got res=" res)
	 (if (vector? res)
	     (if (vector-ref res 0)
		 res
		 (begin ;; note: this code also called in nmsg-transport - consider consolidating it
		   (debug:print 0 "ERROR: error occured at server, info=" (vector-ref res 2))
		   (debug:print 0 " client call chain:")
		   (print-call-chain (current-error-port))
		   (debug:print 0 " server call chain:")
		   (pp (vector-ref res 1) (current-error-port))
		   (signal (vector-ref result 0))))
	     (signal (make-composite-condition
		      (make-property-condition 
		       'timeout
		       'message "nmsg-transport:client-api-send-receive-raw timed out talking to server")))))))

;; careful closing of connections stored in *runremote*
;;
(define (http-transport:close-connections run-id)
  (let* ((server-dat (hash-table-ref/default *runremote* run-id #f)))
    (if (vector? server-dat)
	(let ((api-dat (http-transport:server-dat-get-api-uri server-dat)))
	  (close-connection! api-dat)
	  #t)
	#f)))


(define (make-http-transport:server-dat)(make-vector 6))
(define (http-transport:server-dat-get-iface         vec)    (vector-ref  vec 0))
(define (http-transport:server-dat-get-port          vec)    (vector-ref  vec 1))
(define (http-transport:server-dat-get-api-uri       vec)    (vector-ref  vec 2))
(define (http-transport:server-dat-get-api-url       vec)    (vector-ref  vec 3))
(define (http-transport:server-dat-get-api-req       vec)    (vector-ref  vec 4))
(define (http-transport:server-dat-get-last-access   vec)    (vector-ref  vec 5))
(define (http-transport:server-dat-get-socket        vec)    (vector-ref  vec 6))

(define (http-transport:server-dat-make-url vec)
  (if (and (http-transport:server-dat-get-iface vec)
	   (http-transport:server-dat-get-port  vec))
      (conc "http://" 
	    (http-transport:server-dat-get-iface vec)
	    ":"
	    (http-transport:server-dat-get-port  vec))
      #f))

(define (http-transport:server-dat-update-last-access vec)
  (if (vector? vec)
      (vector-set! vec 5 (current-seconds))
      (begin
	(print-call-chain (current-error-port))
	(debug:print 0 "ERROR: call to http-transport:server-dat-update-last-access with non-vector!!"))))

;;
;; connect
;;
(define (http-transport:client-connect iface port)
  (let* ((api-url      (conc "http://" iface ":" port "/api"))
	 (api-uri      (uri-reference (conc "http://" iface ":" port "/api")))
	 (api-req      (make-request method: 'POST uri: api-uri))
	 (server-dat   (vector iface port api-uri api-url api-req (current-seconds))))






    server-dat))








;; run http-transport:keep-running in a parallel thread to monitor that the db is being 
;; used and to shutdown after sometime if it is not.
;;
(define (http-transport:keep-running server-id run-id)
  ;; if none running or if > 20 seconds since 
  ;; server last used then start shutdown
  ;; This thread waits for the server to come alive
  (debug:print-info 0 "Starting the sync-back, keep alive thread in server for run-id=" run-id)
  (let* ((tdbdat      (tasks:open-db))
	 (server-info (let loop ((start-time (current-seconds))
				 (changed    #t)
				 (last-sdat  "not this"))
                        (let ((sdat #f))
			  (thread-sleep! 0.01)
			  (debug:print-info 0 "Waiting for server alive signature")
                          (mutex-lock! *heartbeat-mutex*)
                          (set! sdat *server-info*)
                          (mutex-unlock! *heartbeat-mutex*)
                          (if (and sdat
				   (not changed)
				   (> (- (current-seconds) start-time) 2))
			      sdat
                              (begin
				(debug:print-info 0 "Still waiting, last-sdat=" last-sdat)
                                (sleep 4)
				(if (> (- (current-seconds) start-time) 120) ;; been waiting for two minutes
				    (begin
				      (debug:print 0 "ERROR: transport appears to have died, exiting server " server-id " for run " run-id)
				      (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id "failed to start, never received server alive signature")
				      (exit))
				    (loop start-time
					  (equal? sdat last-sdat)
					  sdat)))))))
         (iface       (car server-info))
         (port        (cadr server-info))
         (last-access 0)
	 (server-timeout (server:get-timeout)))
    (let loop ((count         0)

	       (server-state 'available)
	       (bad-sync-count 0))

      ;; Use this opportunity to sync the inmemdb to db
      (if *inmemdb* 
	  (let ((start-time (current-milliseconds))
		(sync-time  #f)
		(rem-time   #f))
	    ;; inmemdb is a dbstruct
	    (condition-case
	     (db:sync-touched *inmemdb* *run-id* force-sync: #t)
	     ((sync-failed)(cond

			    ((> bad-sync-count 10) ;; time to give up
			     (http-transport:server-shutdown server-id port))
			    (else ;; (> bad-sync-count 0)  ;; we've had a fail or two, delay and loop
			     (thread-sleep! 5)



			     (loop count server-state (+ bad-sync-count 1)))))
	     ((exn)
	      (debug:print 0 "ERROR: error from sync code other than 'sync-failed. Attempting to gracefully shutdown the server")
	      (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running crashed")
	      (exit)))
	    (set! sync-time  (- (current-milliseconds) start-time))
	    (set! rem-time (quotient (- 4000 sync-time) 1000))
	    (debug:print 2 "SYNC: time= " sync-time ", rem-time=" rem-time)
	    


	    (if (and (<= rem-time 4)
		     (> rem-time 0))

		(thread-sleep! rem-time)
		(thread-sleep! 4))) ;; fallback for if the math is changed ...

	  ;;
	  ;; no *inmemdb* yet, set running after our first pass through and start the db
	  ;;
	  (if (eq? server-state 'available)
	      (let ((new-server-id (tasks:server-am-i-the-server? (db:delay-if-busy tdbdat) run-id))) ;; try to ensure no double registering of servers
		(if (equal? new-server-id server-id)

		    (begin
		      (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "dbprep")
		      (thread-sleep! 0.5) ;; give some margin for queries to complete before switching from file based access to server based access
		      (set! *inmemdb*  (db:setup run-id))
		      ;; force initialization
		      ;; (db:get-db *inmemdb* #t)
		      (db:get-db *inmemdb* run-id)
		      (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "running"))
		    (begin ;; gotta exit nicely
		      (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "collision")
		      (http-transport:server-shutdown server-id port))))))
      
      (if (< count 1) ;; 3x3 = 9 secs aprox
	  (loop (+ count 1) 'running bad-sync-count))
      
      ;; Check that iface and port have not changed (can happen if server port collides)
      (mutex-lock! *heartbeat-mutex*)
      (set! sdat *server-info*)
      (mutex-unlock! *heartbeat-mutex*)
      
      (if (or (not (equal? sdat (list iface port)))
	      (not server-id))
	  (begin 
	    (debug:print-info 0 "interface changed, refreshing iface and port info")
	    (set! iface (car sdat))
	    (set! port  (cadr sdat))))

      



      ;; Transfer *last-db-access* to last-access to use in checking that we are still alive

      (mutex-lock! *heartbeat-mutex*)
      (set! last-access *last-db-access*)
      (mutex-unlock! *heartbeat-mutex*)

      ;; (debug:print 11 "last-access=" last-access ", server-timeout=" server-timeout)
      ;;
      ;; no_traffic, no running tests, if server 0, no running servers
      ;;
      ;; (let ((wait-on-running (configf:lookup *configdat* "server" "wait-on-running"))) ;; wait on running tasks (if not true then exit on time out)
      ;;
      (if (and *server-run*
	       (> (+ last-access server-timeout)
		  (current-seconds)))
	  (begin
	    (debug:print-info 0 "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
	    ;;
	    ;; Consider implementing some smarts here to re-insert the record or kill self is
	    ;; the db indicates so
	    ;;
	    ;; (if (tasks:server-am-i-the-server? tdb run-id)
	    ;;     (tasks:server-set-state! tdb server-id "running"))
	    ;;
	    (loop 0 server-state bad-sync-count))
	  (http-transport:server-shutdown server-id port)))))

(define (http-transport:server-shutdown server-id port)
  (let ((tdbdat (tasks:open-db)))
    (debug:print-info 0 "Starting to shutdown the server.")
    ;; need to delete only *my* server entry (future use)
    (set! *time-to-exit* #t)
    (if *inmemdb* (db:sync-touched *inmemdb* *run-id* force-sync: #t))
    ;;
    ;; start_shutdown
    ;;
    (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "shutting-down")
    (portlogger:open-run-close portlogger:set-port port "released")
    (thread-sleep! 5)
    (debug:print-info 0 "Max cached queries was    " *max-cache-size*)
    (debug:print-info 0 "Number of cached writes   " *number-of-writes*)
    (debug:print-info 0 "Average cached write time "
		      (if (eq? *number-of-writes* 0)
			  "n/a (no writes)"
			  (/ *writes-total-delay*
			     *number-of-writes*))
		      " ms")
    (debug:print-info 0 "Number non-cached queries "  *number-non-write-queries*)
    (debug:print-info 0 "Average non-cached time   "
		      (if (eq? *number-non-write-queries* 0)
			  "n/a (no queries)"
			  (/ *total-non-write-delay* 
			     *number-non-write-queries*))
		      " ms")
    (debug:print-info 0 "Server shutdown complete. Exiting")























    (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running complete")







    (exit)))

;; all routes though here end in exit ...
;;
;; start_server? 
;;
(define (http-transport:launch run-id)
  (let* ((tdbdat (tasks:open-db)))
    (set! *run-id*   run-id)
    (if (args:get-arg "-daemonize")
	(begin
	  (daemon:ize)
	  (if *alt-log-file* ;; we should re-connect to this port, I think daemon:ize disrupts it
	      (begin
		(current-error-port *alt-log-file*)
		(current-output-port *alt-log-file*)))))
    (if (server:check-if-running run-id)
	(begin
	  (debug:print 0 "INFO: Server for run-id " run-id " already running")
	  (exit 0)))
    (let loop ((server-id (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id))
	       (remtries  4))
      (if (not server-id)
	  (if (> remtries 0)
	      (begin
		(thread-sleep! 2)
		(loop (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id)

		      (- remtries 1)))
	      (begin
		;; since we didn't get the server lock we are going to clean up and bail out
		(debug:print-info 2 "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue")
		(tasks:server-delete-records-for-this-pid (db:delay-if-busy tdbdat) " http-transport:launch")
		))
	  (let* ((th2 (make-thread (lambda ()
				     (debug:print-info 0 "Server run thread started")
				     (http-transport:run 
				      (if (args:get-arg "-server")
					  (args:get-arg "-server")
					  "-")
				      run-id
				      server-id)) "Server run"))
		 (th3 (make-thread (lambda ()
				     (debug:print-info 0 "Server monitor thread started")
				     (http-transport:keep-running server-id run-id))
				   "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:ping run-id host-port)
  (let* ((server-dat (http-transport:client-connect (car host-port)(cadr host-port)))
	 (login-res  (rmt:login-no-auto-client-setup server-dat run-id)))
    (if (and (list? login-res)
	     (car login-res))
	(begin
	  (print "LOGIN_OK")
	  (exit 0))
	(begin
	  (print "LOGIN_FAILED")
	  (exit 1)))))

(define (http-transport:server-signal-handler signum)
  (signal-mask! signum)
  (handle-exceptions
   exn
   (debug:print " ... exiting ...")
   (let ((th1 (make-thread (lambda ()
			     (thread-sleep! 1))


			   "eat response"))
	 (th2 (make-thread (lambda ()
			     (debug:print 0 "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.")
			     (thread-sleep! 3) ;; give the flush three seconds to do it's stuff
			     (debug:print 0 "       Done.")
			     (exit 4))
			   "exit on ^C timer")))

Added iupexamples/graph.scm version [5afd5f9dcd].





























































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
(use iup)
(import iup-pplot)

 

(define (tl)
  (let* ((lastx 0)
	 (lastsample 2)
	 (plt (pplot 
	       #:title "MyTitle"
	       #:marginbottom "65"
	       #:marginleft   "65"
	       #:axs_xlabel   "Score" 
	       #:axs_ylabel "Count"
	       #:legendshow "YES"
	       ;; #:axs_xmin    "0"
	       ;; #:axs_ymin    "0"
	       #:axs_yautomin "YES"
	       #:axs_xautomin "YES"
	       #:axs_xautotick "YES"
	       #:axs_yautotick "YES"
	       #:ds_showvalues "YES"
	       #:size "200x200"
	       ))
	 (plt1  (call-with-pplot 
		 plt
		 (lambda (x)
		   (pplot-add! plt 10 100)
		   (pplot-add! plt 20 120)
		   (pplot-add! plt 30 200))
		 #:x-string #f
		 ))
	 (plt2  (call-with-pplot 
		 plt
		 (lambda (x)
		   (pplot-add! plt 10 180)
		   (pplot-add! plt 20 125)
		   (pplot-add! plt 30 100))
		 #:x-string #f
		 ))
	 (dlg (dialog
	       (vbox
		plt
		(hbox
		;;  (button "Redraw" size: "50x" action: (lambda (obj)
		;; 					(redraw plt)))
		 (button "Quit"   size: "50x" action: (lambda (obj)
							(exit)))
		 (button "AddPoint" size: "50x" action: (lambda (obj)
							  (set! lastx (+ lastx 10))
							  (set! lastsample (+ lastsample 1))
							  ;; (attribute-set! plt 'current 0)
							  (print "lastx: " lastx " lastsample: " lastsample)
							  (pplot-add! plt lastx (random 300) lastsample 1)
							  (attribute-set! plt "REDRAW" "1"))))))))
    (set! lastx 30)
    (attribute-set! plt 'ds_mode "LINE")
    ;; (attribute-set! plt 'ds_legend "Yada")
    (show dlg)
    (main-loop)))

(tl)

Modified launch.scm from [69229ba1dd] to [2480988c90].

9
10
11
12
13
14
15
16
17
18
19
20
21
22
23



24
25
26
27
28
29
30
;;  PURPOSE.

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

(use regex regex-case base64 sqlite3 srfi-18)
(import (prefix base64 base64:))
(import (prefix sqlite3 sqlite3:))

(declare (unit launch))
(declare (uses common))
(declare (uses configf))
(declare (uses db))




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

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







|







>
>
>







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

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

(use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3)
(import (prefix base64 base64:))
(import (prefix sqlite3 sqlite3:))

(declare (unit launch))
(declare (uses common))
(declare (uses configf))
(declare (uses db))
;; (declare (uses sdb))
(declare (uses tdb))
;; (declare (uses filedb))

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

;;======================================================================
;; ezsteps
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
  (or (eq? exitcode 0)
      (and logpro (eq? exitcode 2))))

;; if handed a string, process it, else look for MT_CMDINFO
(define (launch:get-cmdinfo-assoc-list #!key (encoded-cmd #f))
  (let ((enccmd (if encoded-cmd encoded-cmd (getenv "MT_CMDINFO"))))
    (if enccmd
	(read (open-input-string (base64:base64-decode enccmd)))
	'())))

(define (launch:execute encoded-cmd)
  (let* ((cmdinfo   (read (open-input-string (base64:base64-decode encoded-cmd)))))
    (setenv "MT_CMDINFO" encoded-cmd)
    (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed)
	;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1))
	(let* ((testpath  (assoc/default 'testpath  cmdinfo))  ;; testpath is the test spec area
	       (top-path  (assoc/default 'toppath   cmdinfo))
	       (work-area (assoc/default 'work-area cmdinfo))  ;; work-area is the test run area
	       (test-name (assoc/default 'test-name cmdinfo))
	       (runscript (assoc/default 'runscript cmdinfo))
	       (ezsteps   (assoc/default 'ezsteps   cmdinfo))
	       ;; (runremote (assoc/default 'runremote cmdinfo))
	       (transport (assoc/default 'transport cmdinfo))
	       (serverinf (assoc/default 'serverinf cmdinfo))
	       (port      (assoc/default 'port      cmdinfo))
	       (run-id    (assoc/default 'run-id    cmdinfo))
	       (test-id   (assoc/default 'test-id   cmdinfo))
	       (target    (assoc/default 'target    cmdinfo))
	       (itemdat   (assoc/default 'itemdat   cmdinfo))
	       (env-ovrd  (assoc/default 'env-ovrd  cmdinfo))
	       (set-vars  (assoc/default 'set-vars  cmdinfo)) ;; pre-overrides from -setvar
	       (runname   (assoc/default 'runname   cmdinfo))
	       (megatest  (assoc/default 'megatest  cmdinfo))
	       (runtlim   (assoc/default 'runtlim   cmdinfo))

	       (mt-bindir-path (assoc/default 'mt-bindir-path cmdinfo))
	       (keys      #f)
	       (keyvals   #f)
	       (fullrunscript (if (not runscript)
                                  #f
                                  (if (substring-index "/" runscript)
                                      runscript ;; use unadultered if contains slashes
                                      (let ((fulln (conc testpath "/" runscript)))
	                                  (if (and (file-exists? fulln)
                                                   (file-execute-access? fulln))
                                              fulln
                                              runscript))))) ;; assume it is on the path
	       (rollup-status 0))
	  (change-directory top-path)
	  (debug:print 2 "Exectuing " test-name " (id: " test-id ") on " (get-host-name))














	  ;; (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process
	  ;; one of these is defunct/redundant ...
	  (if (not (launch:setup-for-run force: #t))
	      (begin
		(debug:print 0 "Failed to setup, exiting") 
		;; (sqlite3:finalize! db)
		;; (sqlite3:finalize! tdb)
		(exit 1)))
	  (change-directory *toppath*) 





	  (let ((rconfig (full-runconfigs-read))) ;; (read-config (conc  *toppath* "/runconfigs.config") #f #t sections: (list "default" target))))
	    ;; (setup-env-defaults (conc *toppath* "/runconfigs.config") run-id (make-hash-table) keyvals target)
	    ;; (set-run-config-vars run-id keyvals target) ;; (db:get-target db run-id))
	    ;; Now have runconfigs data loaded, set environment vars
	    (for-each (lambda (section)
			(for-each (lambda (varval)
				    (let ((var (car varval))
					  (val (cadr varval)))
				      (if (and (string? var)(string? val))
					  (begin
					    (setenv var (config:eval-string-in-environment val))) ;; val)
					  (debug:print 0 "ERROR: bad variable spec, " var "=" val))))
				  (configf:get-section rconfig section)))
		      (list "default" target)))
	  (change-directory work-area) 
	  ;; Setup the *runremote* global var
	  (if *runremote* (debug:print 2 "ERROR: I'm not expecting *runremote* to be set at this time"))
	  ;; (set! *runremote* runremote)
	  ;; (set! *transport-type* (string->symbol transport))
	  (set! keys       (cdb:remote-run db:get-keys #f))
	  (set! keyvals    (keys:target->keyval keys target))
	  ;; apply pre-overrides before other variables. The pre-override vars must not
	  ;; clobbers things from the official sources such as megatest.config and runconfigs.config
	  (if (string? set-vars)
	      (let ((varpairs (string-split set-vars ",")))
		(debug:print 4 "varpairs: " varpairs)
		(map (lambda (varpair)







|



|











|










>














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









>
>
>
>
>















<
<
<
<
<







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
  (or (eq? exitcode 0)
      (and logpro (eq? exitcode 2))))

;; if handed a string, process it, else look for MT_CMDINFO
(define (launch:get-cmdinfo-assoc-list #!key (encoded-cmd #f))
  (let ((enccmd (if encoded-cmd encoded-cmd (getenv "MT_CMDINFO"))))
    (if enccmd
	(common:read-encoded-string enccmd)
	'())))

(define (launch:execute encoded-cmd)
  (let* ((cmdinfo   (common:read-encoded-string encoded-cmd)))
    (setenv "MT_CMDINFO" encoded-cmd)
    (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed)
	;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1))
	(let* ((testpath  (assoc/default 'testpath  cmdinfo))  ;; testpath is the test spec area
	       (top-path  (assoc/default 'toppath   cmdinfo))
	       (work-area (assoc/default 'work-area cmdinfo))  ;; work-area is the test run area
	       (test-name (assoc/default 'test-name cmdinfo))
	       (runscript (assoc/default 'runscript cmdinfo))
	       (ezsteps   (assoc/default 'ezsteps   cmdinfo))
	       ;; (runremote (assoc/default 'runremote cmdinfo))
	       (transport (assoc/default 'transport cmdinfo))
	       ;; (serverinf (assoc/default 'serverinf cmdinfo))
	       (port      (assoc/default 'port      cmdinfo))
	       (run-id    (assoc/default 'run-id    cmdinfo))
	       (test-id   (assoc/default 'test-id   cmdinfo))
	       (target    (assoc/default 'target    cmdinfo))
	       (itemdat   (assoc/default 'itemdat   cmdinfo))
	       (env-ovrd  (assoc/default 'env-ovrd  cmdinfo))
	       (set-vars  (assoc/default 'set-vars  cmdinfo)) ;; pre-overrides from -setvar
	       (runname   (assoc/default 'runname   cmdinfo))
	       (megatest  (assoc/default 'megatest  cmdinfo))
	       (runtlim   (assoc/default 'runtlim   cmdinfo))
	       (item-path (item-list->path itemdat))
	       (mt-bindir-path (assoc/default 'mt-bindir-path cmdinfo))
	       (keys      #f)
	       (keyvals   #f)
	       (fullrunscript (if (not runscript)
                                  #f
                                  (if (substring-index "/" runscript)
                                      runscript ;; use unadultered if contains slashes
                                      (let ((fulln (conc testpath "/" runscript)))
	                                  (if (and (file-exists? fulln)
                                                   (file-execute-access? fulln))
                                              fulln
                                              runscript))))) ;; assume it is on the path
	       (rollup-status 0))
	  (change-directory top-path)

	  ;; (set-signal-handler! signal/int (lambda ()
					    
	  ;; Do not run the test if it is REMOVING, RUNNING, KILLREQ or REMOTEHOSTSTART,
	  ;; Mark the test as REMOTEHOSTSTART *IMMEDIATELY*
	  ;;
	  (let ((test-info (rmt:get-testinfo-state-status run-id test-id)))
	    (if (not (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ")))
		(tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")
		(begin
		  (debug:print 0 "ERROR: test state is " (db:test-get-state test-info) ", cannot proceed")
		  (exit))))
	  
	  (debug:print 2 "Exectuing " test-name " (id: " test-id ") on " (get-host-name))
	  (set! keys       (rmt:get-keys))
	  ;; (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process
	  ;; one of these is defunct/redundant ...
	  (if (not (launch:setup-for-run force: #t))
	      (begin
		(debug:print 0 "Failed to setup, exiting") 
		;; (sqlite3:finalize! db)
		;; (sqlite3:finalize! tdb)
		(exit 1)))
	  (change-directory *toppath*) 

	  ;; NOTE: Current order is to process runconfigs *before* setting the MT_ vars. This 
	  ;;       seems non-ideal but could well break stuff
	  ;;    BUG? BUG? BUG?

	  (let ((rconfig (full-runconfigs-read))) ;; (read-config (conc  *toppath* "/runconfigs.config") #f #t sections: (list "default" target))))
	    ;; (setup-env-defaults (conc *toppath* "/runconfigs.config") run-id (make-hash-table) keyvals target)
	    ;; (set-run-config-vars run-id keyvals target) ;; (db:get-target db run-id))
	    ;; Now have runconfigs data loaded, set environment vars
	    (for-each (lambda (section)
			(for-each (lambda (varval)
				    (let ((var (car varval))
					  (val (cadr varval)))
				      (if (and (string? var)(string? val))
					  (begin
					    (setenv var (config:eval-string-in-environment val))) ;; val)
					  (debug:print 0 "ERROR: bad variable spec, " var "=" val))))
				  (configf:get-section rconfig section)))
		      (list "default" target)))
	  (change-directory work-area) 





	  (set! keyvals    (keys:target->keyval keys target))
	  ;; apply pre-overrides before other variables. The pre-override vars must not
	  ;; clobbers things from the official sources such as megatest.config and runconfigs.config
	  (if (string? set-vars)
	      (let ((varpairs (string-split set-vars ",")))
		(debug:print 4 "varpairs: " varpairs)
		(map (lambda (varpair)
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
		   (begin
		     (debug:print 0 "ERROR: required variable " var " does not have a valid value. Exiting")
		     (exit)))))
	     (list 
	      (list  "MT_TEST_RUN_DIR" work-area)
	      (list  "MT_TEST_NAME" test-name)
	      (list  "MT_ITEM_INFO" (conc itemdat))

	      (list  "MT_RUNNAME"   runname)
	      (list  "MT_MEGATEST"  megatest)
	      (list  "MT_TARGET"    target)
	      (list  "MT_LINKTREE"  (configf:lookup *configdat* "setup" "linktree"))))


	  (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path)))
	  ;; (change-directory top-path)
	  ;; Can setup as client for server mode now
	  ;; (client:setup)

	  
	  ;; environment overrides are done *before* the remaining critical envars.
	  (alist->env-vars env-ovrd)
	  (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals)
	  (set-item-env-vars itemdat)
	  (save-environment-as-files "megatest")
	  ;; open-run-close not needed for test-set-meta-info


	  (tests:set-full-meta-info #f test-id run-id 0 work-area 10)

	  ;; (tests:test-set-status! test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m") #f)
	  (tests:test-force-state-status! test-id "REMOTEHOSTSTART" "n/a")
	  (thread-sleep! 0.3) ;; NFS slowness has caused grief here

	  (if (args:get-arg "-xterm")
	      (set! fullrunscript "xterm")
	      (if (and fullrunscript (not (file-execute-access? fullrunscript)))
		  (system (conc "chmod ug+x " fullrunscript))))
	  ;; We are about to actually kick off the test







>



|
>
>












>
>


<
<







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
		   (begin
		     (debug:print 0 "ERROR: required variable " var " does not have a valid value. Exiting")
		     (exit)))))
	     (list 
	      (list  "MT_TEST_RUN_DIR" work-area)
	      (list  "MT_TEST_NAME" test-name)
	      (list  "MT_ITEM_INFO" (conc itemdat))
	      (list  "MT_ITEMPATH"  item-path)
	      (list  "MT_RUNNAME"   runname)
	      (list  "MT_MEGATEST"  megatest)
	      (list  "MT_TARGET"    target)
	      (list  "MT_LINKTREE"  (configf:lookup *configdat* "setup" "linktree"))
	      (list  "MT_TESTSUITENAME" (common:get-testsuite-name))))

	  (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path)))
	  ;; (change-directory top-path)
	  ;; Can setup as client for server mode now
	  ;; (client:setup)

	  
	  ;; environment overrides are done *before* the remaining critical envars.
	  (alist->env-vars env-ovrd)
	  (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals)
	  (set-item-env-vars itemdat)
	  (save-environment-as-files "megatest")
	  ;; open-run-close not needed for test-set-meta-info
	  ;; (tests:set-full-meta-info #f test-id run-id 0 work-area)
	  ;; (tests:set-full-meta-info test-id run-id 0 work-area)
	  (tests:set-full-meta-info #f test-id run-id 0 work-area 10)



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

	  (if (args:get-arg "-xterm")
	      (set! fullrunscript "xterm")
	      (if (and fullrunscript (not (file-execute-access? fullrunscript)))
		  (system (conc "chmod ug+x " fullrunscript))))
	  ;; We are about to actually kick off the test
189
190
191
192
193
194
195
196

197
198
199
200
201

202
203
204
205
206
207
208
				 ;; (tests:test-set-status! test-id "RUNNING" "n/a" #f #f)
				 ;; Since we should have a clean slate at this time there is no need to do 
				 ;; any of the other stuff that tests:test-set-status! does. Let's just 
				 ;; force RUNNING/n/a
				 

				 (thread-sleep! 0.3)
				 (tests:test-force-state-status! test-id "RUNNING" "n/a")

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

				 ;; if there is a runscript do it first
				 (if fullrunscript
				     (let ((pid (process-run fullrunscript)))

				       (let loop ((i 0))
					 (let-values
					  (((pid-val exit-status exit-code) (process-wait pid #t)))
					  (mutex-lock! m)
					  (vector-set! exit-info 0 pid)
					  (vector-set! exit-info 1 exit-status)
					  (vector-set! exit-info 2 exit-code)







|
>





>







209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
				 ;; (tests:test-set-status! test-id "RUNNING" "n/a" #f #f)
				 ;; Since we should have a clean slate at this time there is no need to do 
				 ;; any of the other stuff that tests:test-set-status! does. Let's just 
				 ;; force RUNNING/n/a
				 

				 (thread-sleep! 0.3)
				 (tests:test-force-state-status! run-id test-id "RUNNING" "n/a")
				 (rmt:roll-up-pass-fail-counts run-id test-name item-path "RUNNING")
				 (thread-sleep! 0.3) ;; NFS slowness has caused grief here

				 ;; if there is a runscript do it first
				 (if fullrunscript
				     (let ((pid (process-run fullrunscript)))
				       (rmt:test-set-top-process-pid run-id test-id pid)
				       (let loop ((i 0))
					 (let-values
					  (((pid-val exit-status exit-code) (process-wait pid #t)))
					  (mutex-lock! m)
					  (vector-set! exit-info 0 pid)
					  (vector-set! exit-info 1 exit-status)
					  (vector-set! exit-info 2 exit-code)
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
						   ;; ;; first source the previous environment
						   ;; (let ((prev-env (conc ".ezsteps/" prevstep (if (string-search (regexp "csh") 
						   ;;      							 (get-environment-variable "SHELL")) ".csh" ".sh"))))
						   ;;   (if (and prevstep (file-exists? prev-env))
						   ;;       (set! script (conc script "source " prev-env))))
						   
						   ;; call the command using mt_ezstep
						   (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd))

						   (debug:print 4 "script: " script)
						   ;; DO NOT remote
						   (db:teststep-set-status! #f test-id stepname "start" "-" #f #f work-area: work-area)
						   ;; now launch
						   (let ((pid (process-run script)))

						     (let processloop ((i 0))
						       (let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
								   (mutex-lock! m)
								   (vector-set! exit-info 0 pid)
								   (vector-set! exit-info 1 exit-status)
								   (vector-set! exit-info 2 exit-code)
								   (mutex-unlock! m)
								   (if (eq? pid-val 0)
								       (begin
									 (thread-sleep! 2)
									 (processloop (+ i 1))))
								   ))
                                                     (let ((exinfo (vector-ref exit-info 2))
                                                           (logfna (if logpro-used (conc stepname ".html") "")))
						       ;; testing if procedures called in a remote call cause problems (ans: no or so I suspect)
						       (db:teststep-set-status! #f test-id stepname "end" exinfo #f logfna work-area: work-area))
						     (if logpro-used
							 (cdb:test-set-log! *runremote*  test-id (conc stepname ".html")))
						     ;; set the test final status
						     (let* ((this-step-status (cond
									       ((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn)
									       ((eq? (vector-ref exit-info 2) 0)                   'pass)
									       (else 'fail)))
							    (overall-status   (cond
									       ((eq? rollup-status 2) 'warn)







|


<
|


>














<
|

|







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
						   ;; ;; first source the previous environment
						   ;; (let ((prev-env (conc ".ezsteps/" prevstep (if (string-search (regexp "csh") 
						   ;;      							 (get-environment-variable "SHELL")) ".csh" ".sh"))))
						   ;;   (if (and prevstep (file-exists? prev-env))
						   ;;       (set! script (conc script "source " prev-env))))
						   
						   ;; call the command using mt_ezstep
						   (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "x") " " stepcmd))

						   (debug:print 4 "script: " script)

						   (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f)
						   ;; now launch
						   (let ((pid (process-run script)))
						     (rmt:test-set-top-process-pid run-id test-id pid)
						     (let processloop ((i 0))
						       (let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
								   (mutex-lock! m)
								   (vector-set! exit-info 0 pid)
								   (vector-set! exit-info 1 exit-status)
								   (vector-set! exit-info 2 exit-code)
								   (mutex-unlock! m)
								   (if (eq? pid-val 0)
								       (begin
									 (thread-sleep! 2)
									 (processloop (+ i 1))))
								   ))
                                                     (let ((exinfo (vector-ref exit-info 2))
                                                           (logfna (if logpro-used (conc stepname ".html") "")))

						       (rmt:teststep-set-status! run-id test-id stepname "end" exinfo #f logfna))
						     (if logpro-used
							 (rmt:test-set-log! run-id test-id (conc stepname ".html")))
						     ;; set the test final status
						     (let* ((this-step-status (cond
									       ((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn)
									       ((eq? (vector-ref exit-info 2) 0)                   'pass)
									       (else 'fail)))
							    (overall-status   (cond
									       ((eq? rollup-status 2) 'warn)
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
						       (debug:print 4 "Exit value received: " (vector-ref exit-info 2) " logpro-used: " logpro-used 
								    " this-step-status: " this-step-status " overall-status: " overall-status 
								    " next-status: " next-status " rollup-status: " rollup-status)
						       (case next-status
							 ((warn)
							  (set! rollup-status 2)
							  ;; NB// test-set-status! does rdb calls under the hood
							  (tests:test-set-status! test-id next-state "WARN" 
									  (if (eq? this-step-status 'warn) "Logpro warning found" #f)
									  #f))
							 ((pass)
							  (tests:test-set-status! test-id next-state "PASS" #f #f))
							 (else ;; 'fail
							  (set! rollup-status 1) ;; force fail, this used to be next-state but that doesn't make sense. should always be "COMPLETED" 
							  (tests:test-set-status! test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f)
							  ))))
						   (if (and (steprun-good? logpro-used (vector-ref exit-info 2))
							    (not (null? tal)))
						       (loop (car tal) (cdr tal) stepname)))
						 (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep))))))))
		 (monitorjob   (lambda ()
				 (let* ((start-seconds (current-seconds))
					(calc-minutes  (lambda ()
							 (inexact->exact 
							  (round 
							   (- 
							    (current-seconds) 
							    start-seconds)))))
					(kill-tries 0))


				   (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area 10)
				   (let loop ((minutes   (calc-minutes)))
				     (begin
				       (set! kill-job? (or (test-get-kill-request test-id) ;; run-id test-name itemdat))
							   (and runtlim (let* ((run-seconds   (- (current-seconds) start-seconds))
									       (time-exceeded (> run-seconds runtlim)))
									  (if time-exceeded
									      (begin
										(debug:print-info 0 "KILLING TEST DUE TO TIME LIMIT EXCEEDED! Runtime=" run-seconds " seconds, limit=" runtlim)
										#t)
									      #f)))))
				       ;; open-run-close not needed for test-set-meta-info
				       (tests:set-partial-meta-info #f test-id run-id minutes work-area 10)
				       (if kill-job? 
					   (begin
					     (mutex-lock! m)
					     ;; NOTE: The pid can change as different steps are run. Do we need handshaking between this
					     ;;       section and the runit section? Or add a loop that tries three times with a 1/4 second
					     ;;       between tries?
					     (let* ((pid (vector-ref exit-info 0)))


					       (if (number? pid)



						   (handle-exceptions
						    exn
						    (debug:print-info 0 "Unable to kill process with pid " pid ", possibly already killed.")
						    ;;(process-signal pid signal/kill))
						    (begin


						      (debug:print 0 "WARNING: Request received to kill job (attempt # " kill-tries ")")
						      (let ((processes (cmd-run->list (conc "pgrep -l -P " pid))))
							(for-each 
							 (lambda (p)
							   (let* ((parts  (string-split p))
								  (p-id   (if (> (length parts) 0)
									      (string->number (car parts))
									      #f)))
							     (if p-id
								 (begin
								   (debug:print 0 "Killing " (cadr parts) "; kill -9  " p-id)
								   ;; (process-signal pid signal/kill))))) ;; 
								   (system (conc "kill -9 " p-id))))))

							 (car processes)))

						      (system (conc "kill -9 -" pid))
						      (tests:test-set-status! test-id "KILLED"  "KILLED" (args:get-arg "-m") #f)))
						   (begin
						     (debug:print 0 "WARNING: Request received to kill job but problem with process, attempting to kill manager process")
						     (tests:test-set-status! test-id "KILLED"  "KILLED" (args:get-arg "-m") #f)
						     (sqlite3:finalize! tdb)
						     (exit 1) ;; IS THIS NECESSARY OR WISE???
						     )))
					     (set! kill-tries (+ 1 kill-tries))
					     (mutex-unlock! m)))

				       ;; (sqlite3:finalize! db)
				       (if keep-going
					   (begin
					     (thread-sleep! 3) ;; (+ 3 (random 6))) ;; add some jitter to the call home time to spread out the db accesses
					     (if keep-going
						 (loop (calc-minutes)))))))
				   (tests:update-central-meta-info test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f)))) ;; NOTE: Checking twice for keep-going is intentional
		 (th1          (make-thread monitorjob "monitor job"))
		 (th2          (make-thread runit "run job")))
	    (set! job-thread th2)
	    (thread-start! th1)
	    (thread-start! th2)
	    (thread-join! th2)

	    (set! keep-going #f)
	    (thread-join! th1)
	    ;; (thread-sleep! 1)
	    ;; (thread-terminate! th1) ;; Not sure if this is a good idea
	    (thread-sleep! 1)       ;; give thread th1 a chance to be done TODO: Verify this is needed. At 0.1 I was getting fail to stop, increased to total of 1.1 sec.
	    ;; (tests:update-central-meta-info test-id cpuload diskfree minutes #f #f)
	    (mutex-lock! m)
	    (let* ((item-path (item-list->path itemdat))
		   ;; only state and status needed - use lazy routine
		   (testinfo  (cdb:remote-run db:get-testinfo-state-status #f test-id))) ;;;(cdb:get-test-info-by-id *runremote* test-id))) ;; )) ;; run-id test-name item-path)))
	      ;; Am I completed?
	      (if (member (db:test-get-state testinfo) '("REMOTEHOSTSTART" "RUNNING")) ;; NOTE: It should *not* be REMOTEHOSTSTART but for reasons I don't yet understand it sometimes gets stuck in that state ;; (not (equal? (db:test-get-state testinfo) "COMPLETED"))
		  (let ((new-state  (if kill-job? "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status
				                                        ;; "COMPLETED"
							                ;; (db:test-get-state testinfo)))   ;; else preseve the state as set within the test
				    )
			(new-status (cond
				     ((not (vector-ref exit-info 1)) "FAIL") ;; job failed to run
				     ((eq? rollup-status 0)
				      ;; if the current status is AUTO then defer to the calculated value (i.e. leave this AUTO)
				      (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO" "PASS"))
				     ((eq? rollup-status 1) "FAIL")
				     ((eq? rollup-status 2)
				      ;; if the current status is AUTO the defer to the calculated value but qualify (i.e. make this AUTO-WARN)
				      (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO-WARN" "WARN"))
				     (else "FAIL")))) ;; (db:test-get-status testinfo)))
		    (debug:print-info 1 "Test exited in state=" (db:test-get-state testinfo) ", setting state/status based on exit code of " (vector-ref exit-info 1) " and rollup-status of " rollup-status)
		    (tests:test-set-status! test-id 

					    new-state
					    new-status
					    (args:get-arg "-m") #f)
		    ;; need to update the top test record if PASS or FAIL and this is a subtest
		    ;; NO NEED TO CALL roll-up-pass-fail-counts HERE, THIS IS DONE IN roll-up-pass-fail-counts called by tests:test-set-status!
		    ;; (if (not (equal? item-path ""))
		    ;;     (begin
		    ;;       (thread-sleep! 0.1) ;; give other processes an opportunity to access the db as rollup is lower priority
		    ;;       (cdb:roll-up-pass-fail-counts *runremote* run-id test-name item-path new-status)))
		    ))
	      ;; for automated creation of the rollup html file this is a good place...
	      (if (not (equal? item-path ""))


		  (tests:summarize-items #f run-id test-id test-name #f))) ;; don't force - just update if no
	    (mutex-unlock! m)
	    (debug:print 2 "Output from running " fullrunscript ", pid " (vector-ref exit-info 0) " in work area " 
			 work-area ":\n====\n exit code " (vector-ref exit-info 2) "\n" "====\n")
	    (if (not (vector-ref exit-info 1))
		(exit 4)))))))

;; set up the very basics needed for doing anything here.
(define (launch:setup-for-run #!key (force #f))
  ;; would set values for KEYS in the environment here for better support of env-override but 
  ;; have chicken/egg scenario. need to read megatest.config then read it again. Going to 
  ;; pass on that idea for now
  ;; special case
  (if (or force (not (hash-table? *configdat*)))  ;; no need to re-open on every call
      (begin










	(set! *configinfo* (find-and-read-config 
			    (if (args:get-arg "-config")(args:get-arg "-config") "megatest.config")
			    environ-patt: "env-override"
			    given-toppath: (get-environment-variable "MT_RUN_AREA_HOME")
			    pathenvvar: "MT_RUN_AREA_HOME"))
	(set! *configdat*  (if (car *configinfo*)(car *configinfo*) #f))
	(set! *toppath*    (if (car *configinfo*)(cadr *configinfo*) #f))

































	(if *toppath*

	    (setenv "MT_RUN_AREA_HOME" *toppath*) ;; to be deprecated

	    (debug:print 0 "ERROR: failed to find the top path to your Megatest area."))))


  *toppath*)




























(define (get-best-disk confdat)
  (let* ((disks    (hash-table-ref/default confdat "disks" #f))
	 (best     #f)
	 (bestsize 0))
    (if disks 
	(for-each 
	 (lambda (disk-num)
	   (let* ((dirpath    (cadr (assoc disk-num disks)))
		  (freespc    (if (and (directory? dirpath)
				       (file-write-access? dirpath))
				  (get-df dirpath)
				  (begin
				    (debug:print 0 "WARNING: path " dirpath " in [disks] section not valid or writable")
				    0))))
	     (if (> freespc bestsize)
		 (begin
		   (set! best     dirpath)
		   (set! bestsize freespc)))))
	 (map car disks)))
    (if best
	best
	(begin

	  (debug:print 0 "ERROR: No valid disks found in megatest.config. Please add some to your [disks] section")
	  (exit 1)))))

;; Desired directory structure:
;;
;;  <linkdir> - <target> - <testname> -.
;;                                     |
;;                                     v
;;  <rundir>  -  <target>  -    <testname> -|- <itempath(s)>
;;
;;  dir stored in test is:
;; 
;;  <linkdir> - <target> - <testname> [ - <itempath> ]
;; 
;; All log file links should be stored relative to the top of link path
;;  
;; <target> - <testname> [ - <itempath> ] 
;;
(define (create-work-area run-id run-info keyvals test-id test-src-path disk-path testname itemdat)
  (let* ((item-path (item-list->path itemdat))


	 (runname  (db:get-value-by-header (db:get-row run-info)
					   (db:get-header run-info)
					   "runname"))
	 ;; convert back to db: from rdb: - this is always run at server end
	 (target   (string-intersperse (map cadr keyvals) "/"))

	 (not-iterated  (equal? "" item-path))

	 ;; all tests are found at <rundir>/test-base or <linkdir>/test-base
	 (testtop-base (conc target "/" runname "/" testname))
	 (test-base    (conc testtop-base (if not-iterated "" "/") item-path))

	 ;; nb// if itempath is not "" then it is prefixed with "/"
	 (toptest-path (conc disk-path "/" testtop-base))
	 (test-path    (conc disk-path "/" test-base))

	 ;; ensure this exists first as links to subtests must be created there
	 (linktree  (let ((rd (config-lookup *configdat* "setup" "linktree")))
		      (if rd rd (conc *toppath* "/runs"))))

	 (lnkbase  (conc linktree "/" target "/" runname))
	 (lnkpath  (conc lnkbase "/" testname))
	 (lnkpathf (conc lnkpath (if not-iterated "" "/") item-path)))


    ;; Update the rundir path in the test record for all

    (cdb:test-set-rundir-by-test-id *runremote* test-id lnkpathf)

    (debug:print 2 "INFO:\n       lnkbase=" lnkbase "\n       lnkpath=" lnkpath "\n  toptest-path=" toptest-path "\n     test-path=" test-path)
    (if (not (file-exists? linktree))
	(begin
	  (debug:print 0 "WARNING: linktree did not exist! Creating it now at " linktree)
	  (create-directory linktree #t))) ;; (system (conc "mkdir -p " linktree))))
    ;; create the directory for the tests dir links, this is needed no matter what...
    (if (and (not (directory-exists? lnkbase))
	     (not (file-exists? lnkbase)))





	(create-directory lnkbase #t))
    
    ;; update the toptest record with its location rundir, cache the path
    ;; This wass highly inefficient, one db write for every subtest, potentially
    ;; thousands of unnecessary updates, cache the fact it was set and don't set it 
    ;; again. 

    ;; NB - This is not working right - some top tests are not getting the path set!!!

    (if (not (hash-table-ref/default *toptest-paths* testname #f))
	(let* ((testinfo       (cdb:get-test-info-by-id *runremote* test-id)) ;;  run-id testname item-path))
	       (curr-test-path (if testinfo (db:test-get-rundir testinfo) #f)))
	  (hash-table-set! *toptest-paths* testname curr-test-path)
	  ;; NB// Was this for the test or for the parent in an iterated test?
	  (cdb:test-set-rundir! *runremote* run-id testname "" lnkpath) ;; toptest-path)
	  (if (or (not curr-test-path)
		  (not (directory-exists? toptest-path)))
	      (begin
		(debug:print-info 2 "Creating " toptest-path " and link " lnkpath)
		(create-directory toptest-path #t)
		(hash-table-set! *toptest-paths* testname toptest-path)))))

    ;; Now create the link from the test path to the link tree, however
    ;; if the test is iterated it is necessary to create the parent path
    ;; to the iteration. use pathname-directory to trim the path by one
    ;; level
    (if (not not-iterated) ;; i.e. iterated
	(let ((iterated-parent  (pathname-directory (conc lnkpath "/" item-path))))
	  (debug:print-info 2 "Creating iterated parent " iterated-parent)







|



|


|














>
>



|







<
|






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

|
|
<
<

<
|
>
|





|






>


<
<

<



|

















|
>





<
<
<
<


|
>
>
|














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


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

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



|
|

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
















|
|
>
>
|
|
|

















|
|
|
>

|
>
|









>
>
>
>
>
|






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







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
						       (debug:print 4 "Exit value received: " (vector-ref exit-info 2) " logpro-used: " logpro-used 
								    " this-step-status: " this-step-status " overall-status: " overall-status 
								    " next-status: " next-status " rollup-status: " rollup-status)
						       (case next-status
							 ((warn)
							  (set! rollup-status 2)
							  ;; NB// test-set-status! does rdb calls under the hood
							  (tests:test-set-status! run-id test-id next-state "WARN" 
									  (if (eq? this-step-status 'warn) "Logpro warning found" #f)
									  #f))
							 ((pass)
							  (tests:test-set-status! run-id test-id next-state "PASS" #f #f))
							 (else ;; 'fail
							  (set! rollup-status 1) ;; force fail, this used to be next-state but that doesn't make sense. should always be "COMPLETED" 
							  (tests:test-set-status! run-id test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f)
							  ))))
						   (if (and (steprun-good? logpro-used (vector-ref exit-info 2))
							    (not (null? tal)))
						       (loop (car tal) (cdr tal) stepname)))
						 (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep))))))))
		 (monitorjob   (lambda ()
				 (let* ((start-seconds (current-seconds))
					(calc-minutes  (lambda ()
							 (inexact->exact 
							  (round 
							   (- 
							    (current-seconds) 
							    start-seconds)))))
					(kill-tries 0))
				   ;; (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area)
				   ;; (tests:set-full-meta-info test-id run-id (calc-minutes) work-area)
				   (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area 10)
				   (let loop ((minutes   (calc-minutes)))
				     (begin
				       (set! kill-job? (or (test-get-kill-request run-id test-id) ;; run-id test-name itemdat))
							   (and runtlim (let* ((run-seconds   (- (current-seconds) start-seconds))
									       (time-exceeded (> run-seconds runtlim)))
									  (if time-exceeded
									      (begin
										(debug:print-info 0 "KILLING TEST DUE TO TIME LIMIT EXCEEDED! Runtime=" run-seconds " seconds, limit=" runtlim)
										#t)
									      #f)))))

				       (tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f)
				       (if kill-job? 
					   (begin
					     (mutex-lock! m)
					     ;; NOTE: The pid can change as different steps are run. Do we need handshaking between this
					     ;;       section and the runit section? Or add a loop that tries three times with a 1/4 second
					     ;;       between tries?
					     (let* ((pid1 (vector-ref exit-info 0))
						    (pid2 (rmt:test-get-top-process-pid run-id test-id))
						    (pids (delete-duplicates (filter number? (list pid1 pid2)))))
					       (if (not (null? pids))
						   (begin
						     (for-each
						      (lambda (pid)
							(handle-exceptions
							 exn


							 (begin
							   (debug:print-info 0 "Unable to kill process with pid " pid ", possibly already killed.")
							   (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)))
							 (debug:print 0 "WARNING: Request received to kill job " pid) ;;  " (attempt # " kill-tries ")")







							 (if (process:alive? pid)
							     (begin

							       (process-signal pid signal/int)

							       (thread-sleep! 5)
							       (if (process:process-alive? pid)
								   (process-signal pid signal/kill))))))
						      pids)
						     (tests:test-set-status! run-id test-id "KILLED"  "KILLED" (args:get-arg "-m") #f))
						   (begin
						     (debug:print 0 "ERROR: Nothing to kill, pid1=" pid1 ", pid2=" pid2)
						     (tests:test-set-status! run-id test-id "KILLED"  "FAILED TO KILL" (args:get-arg "-m") #f)


						     )))

					     (mutex-unlock! m)
					     ;; no point in sticking around. Exit now.
					     (exit)))
				       (if keep-going
					   (begin
					     (thread-sleep! 3) ;; (+ 3 (random 6))) ;; add some jitter to the call home time to spread out the db accesses
					     (if keep-going
						 (loop (calc-minutes)))))))
				   (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
		 (th1          (make-thread monitorjob "monitor job"))
		 (th2          (make-thread runit "run job")))
	    (set! job-thread th2)
	    (thread-start! th1)
	    (thread-start! th2)
	    (thread-join! th2)
	    (debug:print-info 0 "Megatest exectute of test " test-name ", item path " item-path " complete. Notifying the db ...")
	    (set! keep-going #f)
	    (thread-join! th1)


	    (thread-sleep! 1)       ;; give thread th1 a chance to be done TODO: Verify this is needed. At 0.1 I was getting fail to stop, increased to total of 1.1 sec.

	    (mutex-lock! m)
	    (let* ((item-path (item-list->path itemdat))
		   ;; only state and status needed - use lazy routine
		   (testinfo  (rmt:get-testinfo-state-status run-id test-id)))
	      ;; Am I completed?
	      (if (member (db:test-get-state testinfo) '("REMOTEHOSTSTART" "RUNNING")) ;; NOTE: It should *not* be REMOTEHOSTSTART but for reasons I don't yet understand it sometimes gets stuck in that state ;; (not (equal? (db:test-get-state testinfo) "COMPLETED"))
		  (let ((new-state  (if kill-job? "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status
				                                        ;; "COMPLETED"
							                ;; (db:test-get-state testinfo)))   ;; else preseve the state as set within the test
				    )
			(new-status (cond
				     ((not (vector-ref exit-info 1)) "FAIL") ;; job failed to run
				     ((eq? rollup-status 0)
				      ;; if the current status is AUTO then defer to the calculated value (i.e. leave this AUTO)
				      (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO" "PASS"))
				     ((eq? rollup-status 1) "FAIL")
				     ((eq? rollup-status 2)
				      ;; if the current status is AUTO the defer to the calculated value but qualify (i.e. make this AUTO-WARN)
				      (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO-WARN" "WARN"))
				     (else "FAIL")))) ;; (db:test-get-status testinfo)))
		    (debug:print-info 1 "Test exited in state=" (db:test-get-state testinfo) ", setting state/status based on exit code of " (vector-ref exit-info 1) " and rollup-status of " rollup-status)
		    (tests:test-set-status! run-id 
					    test-id 
					    new-state
					    new-status
					    (args:get-arg "-m") #f)
		    ;; need to update the top test record if PASS or FAIL and this is a subtest
		    ;; NO NEED TO CALL roll-up-pass-fail-counts HERE, THIS IS DONE IN roll-up-pass-fail-counts called by tests:test-set-status!




		    ))
	      ;; for automated creation of the rollup html file this is a good place...
	      ;; (if (and (not (equal? item-path ""))
	      ;;      (< (random (rmt:get-count-tests-running-for-testname run-id test-name)) 5))
	      (tests:summarize-items run-id test-id test-name #f)
	      (tests:summarize-test run-id test-id)) ;; don't force - just update if no
	    (mutex-unlock! m)
	    (debug:print 2 "Output from running " fullrunscript ", pid " (vector-ref exit-info 0) " in work area " 
			 work-area ":\n====\n exit code " (vector-ref exit-info 2) "\n" "====\n")
	    (if (not (vector-ref exit-info 1))
		(exit 4)))))))

;; set up the very basics needed for doing anything here.
(define (launch:setup-for-run #!key (force #f))
  ;; would set values for KEYS in the environment here for better support of env-override but 
  ;; have chicken/egg scenario. need to read megatest.config then read it again. Going to 
  ;; pass on that idea for now
  ;; special case
  (if (or force (not (hash-table? *configdat*)))  ;; no need to re-open on every call
      (begin
	(set! *configinfo* (or (if (get-environment-variable "MT_CMDINFO") ;; we are inside a test - do not reprocess configs
				   (let ((alistconfig (conc (get-environment-variable "MT_LINKTREE") "/"
							    (get-environment-variable "MT_TARGET")   "/"
							    (get-environment-variable "MT_RUNNAME")  "/"
							    ".megatest.cfg")))
				     (if (file-exists? alistconfig)
					 (list (configf:read-alist alistconfig)
					       (get-environment-variable "MT_RUN_AREA_HOME"))
					 #f))
				   #f) ;; no config cached - give up
			       (find-and-read-config 
				(if (args:get-arg "-config")(args:get-arg "-config") "megatest.config")
				environ-patt: "env-override"
				given-toppath: (get-environment-variable "MT_RUN_AREA_HOME")
				pathenvvar: "MT_RUN_AREA_HOME")))
	(set! *configdat*  (if (car *configinfo*)(car *configinfo*) #f))
	(set! *toppath*    (if (car *configinfo*)(cadr *configinfo*) #f))
	(let* ((tmptransport (configf:lookup *configdat* "server" "transport"))
	       (transport    (if tmptransport (string->symbol tmptransport) 'http)))
	  (if (member transport '(http rpc nmsg))
	      (set! *transport-type* transport)
	      (begin
		(debug:print 0 "ERROR: Unrecognised transport " transport)
		(exit))))
	(let ((linktree (configf:lookup *configdat* "setup" "linktree"))) ;; link tree is critical
	  (if linktree
	      (if (not (file-exists? linktree))
		  (begin
		    (handle-exceptions
		     exn
		     (begin
		       (debug:print 0 "ERROR: Something went wrong when trying to create linktree dir at " linktree)
		       (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
		       (exit 1))
		     (create-directory linktree #t))))
	      (begin
		(debug:print 0 "ERROR: linktree not defined in [setup] section of megatest.config")
		(exit 1)))
	  (if linktree
	      (let ((dbdir (conc linktree "/.db")))
		(handle-exceptions
		 exn
		 (begin
		   (debug:print 0 "ERROR: failed to create the " dbdir " area for your database files")
		   (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)))
		 (if (not (directory-exists? dbdir))(create-directory dbdir)))
		(setenv "MT_LINKTREE" linktree))
	      (begin
		(debug:print 0 "ERROR: linktree is required in your megatest.config [setup] section")
		(exit 1)))
	  (if (and *toppath*
		   (directory-exists? *toppath*))
	      (setenv "MT_RUN_AREA_HOME" *toppath*)
	      (begin
		(debug:print 0 "ERROR: failed to find the top path to your Megatest area.")
		(exit 1)))
	  )))
  *toppath*)

(define (launch:cache-config)
  ;; if we have a linktree and -runtests and -target and the directory exists dump the config
  ;; to megatest-(current-seconds).cfg and symlink it to megatest.cfg
  (if (and *configdat* 
	   (args:get-arg "-runtests"))
      (let* ((linktree (get-environment-variable "MT_LINKTREE"))
	     (target   (common:args-get-target))
	     (runname  (or (args:get-arg "-runname")
			   (args:get-arg ":runname")))
	     (fulldir  (conc linktree "/"
			     target "/"
			     runname)))
	(debug:print-info 0 "Have -runtests with target=" target ", runname=" runname ", fulldir=" fulldir)
	(if (file-exists? linktree) ;; can't proceed without linktree
	    (begin
	      (if (not (file-exists? fulldir))
		  (create-directory fulldir #t)) ;; need to protect with exception handler 
	      (if (and target
		       runname
		       (file-exists? fulldir))
		  (let ((tmpfile  (conc fulldir "/.megatest.cfg." (current-seconds)))
			(targfile (conc fulldir "/.megatest.cfg")))
		    (debug:print-info 0 "Caching megatest.config in " fulldir "/.megatest.cfg")
		    (configf:write-alist *configdat* tmpfile)
		    (system (conc "ln -sf " tmpfile " " targfile))
		    )))))))

(define (get-best-disk confdat)
  (let* ((disks    (hash-table-ref/default confdat "disks" #f))
	 (minspace (let ((m (configf:lookup confdat "setup" "minspace")))
		     (string->number (or m "10000")))))
    (if disks 













	(let ((res (common:get-disk-with-most-free-space disks minspace))) ;; min size of 1000, seems tad dumb
	  (if res
	      (cdr res)
	      (begin
		(if (common:low-noise-print 20 "no valid disks")
		    (debug:print 0 "ERROR: No valid disks found in megatest.config. Please add some to your [disks] section and ensure the directory exists!"))
		(exit 1)))))))

;; Desired directory structure:
;;
;;  <linkdir> - <target> - <testname> -.
;;                                     |
;;                                     v
;;  <rundir>  -  <target>  -    <testname> -|- <itempath(s)>
;;
;;  dir stored in test is:
;; 
;;  <linkdir> - <target> - <testname> [ - <itempath> ]
;; 
;; All log file links should be stored relative to the top of link path
;;  
;; <target> - <testname> [ - <itempath> ] 
;;
(define (create-work-area run-id run-info keyvals test-id test-src-path disk-path testname itemdat #!key (remtries 2))
  (let* ((item-path (if (string? itemdat) itemdat (item-list->path itemdat))) ;; if pass in string - just use it
	 (runname   (if (string? run-info) ;; if we pass in a string as run-info use it as run-name.
			run-info
			(db:get-value-by-header (db:get-rows run-info)
						(db:get-header run-info)
						"runname")))
	 ;; convert back to db: from rdb: - this is always run at server end
	 (target   (string-intersperse (map cadr keyvals) "/"))

	 (not-iterated  (equal? "" item-path))

	 ;; all tests are found at <rundir>/test-base or <linkdir>/test-base
	 (testtop-base (conc target "/" runname "/" testname))
	 (test-base    (conc testtop-base (if not-iterated "" "/") item-path))

	 ;; nb// if itempath is not "" then it is prefixed with "/"
	 (toptest-path (conc disk-path "/" testtop-base))
	 (test-path    (conc disk-path "/" test-base))

	 ;; ensure this exists first as links to subtests must be created there
	 (linktree  (let ((rd (config-lookup *configdat* "setup" "linktree")))
		      (if rd rd (conc *toppath* "/runs"))))

	 (lnkbase   (conc linktree "/" target "/" runname))
	 (lnkpath   (conc lnkbase "/" testname))
	 (lnkpathf  (conc lnkpath (if not-iterated "" "/") item-path))
	 (lnktarget (conc lnkpath "/" item-path)))

    ;; Update the rundir path in the test record for all, rundir=physical, shortdir=logical
    ;;                                                 rundir   shortdir
    (rmt:general-call 'test-set-rundir-shortdir run-id lnkpathf test-path testname item-path)

    (debug:print 2 "INFO:\n       lnkbase=" lnkbase "\n       lnkpath=" lnkpath "\n  toptest-path=" toptest-path "\n     test-path=" test-path)
    (if (not (file-exists? linktree))
	(begin
	  (debug:print 0 "WARNING: linktree did not exist! Creating it now at " linktree)
	  (create-directory linktree #t))) ;; (system (conc "mkdir -p " linktree))))
    ;; create the directory for the tests dir links, this is needed no matter what...
    (if (and (not (directory-exists? lnkbase))
	     (not (file-exists? lnkbase)))
	(handle-exceptions
	 exn
	 (begin
	   (debug:print "ERROR: Problem creating linktree base at " lnkbase)
	   (print-error-message exn (current-error-port)))
	 (create-directory lnkbase #t)))
    
    ;; update the toptest record with its location rundir, cache the path
    ;; This wass highly inefficient, one db write for every subtest, potentially
    ;; thousands of unnecessary updates, cache the fact it was set and don't set it 
    ;; again. 
















    ;; Now create the link from the test path to the link tree, however
    ;; if the test is iterated it is necessary to create the parent path
    ;; to the iteration. use pathname-directory to trim the path by one
    ;; level
    (if (not not-iterated) ;; i.e. iterated
	(let ((iterated-parent  (pathname-directory (conc lnkpath "/" item-path))))
	  (debug:print-info 2 "Creating iterated parent " iterated-parent)
578
579
580
581
582
583
584































585
586
587
588
589
590
591
592
593
594
595
	(handle-exceptions
	 exn
	 (begin
	   (debug:print 0 "ERROR:  Failed to create symlink " lnkpath ((condition-property-accessor 'exn 'message) exn) ", exiting")
	   (exit 1))
	 (create-symbolic-link toptest-path lnkpath)))
    































    ;; The toptest path has been created, the link to the test in the linktree has
    ;; been created. Now, if this is an iterated test the real test dir must be created
    (if (not not-iterated) ;; this is an iterated test
	(let ((lnktarget (conc lnkpath "/" item-path)))
	  (debug:print 2 "Setting up sub test run area")
	  (debug:print 2 " - creating run area in " test-path)
	  (handle-exceptions
	   exn
	   (begin
	     (debug:print 0 "ERROR:  Failed to create directory " test-path ((condition-property-accessor 'exn 'message) exn) ", exiting")
	     (exit 1))







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



|







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
	(handle-exceptions
	 exn
	 (begin
	   (debug:print 0 "ERROR:  Failed to create symlink " lnkpath ((condition-property-accessor 'exn 'message) exn) ", exiting")
	   (exit 1))
	 (create-symbolic-link toptest-path lnkpath)))
    
    ;; NB - This was not working right - some top tests are not getting the path set!!!
    ;;
    ;; Do the setting of this record after the paths are created so that the shortdir can 
    ;; be set to the real directory location. This is safer for future clean up if the link
    ;; tree is damaged or lost.
    ;; 
    (if (not (hash-table-ref/default *toptest-paths* testname #f))
	(let* ((testinfo       (rmt:get-test-info-by-id run-id test-id)) ;;  run-id testname item-path))
	       (curr-test-path (if testinfo ;; (filedb:get-path *fdb*
							     ;; (db:get-path dbstruct
				   ;; (rmt:sdb-qry 'getstr 
				   (db:test-get-rundir testinfo) ;; ) ;; )
				   #f)))
	  (hash-table-set! *toptest-paths* testname curr-test-path)
	  ;; NB// Was this for the test or for the parent in an iterated test?
	  (rmt:general-call 'test-set-rundir-shortdir run-id lnkpath 
			    (if (file-exists? lnkpath)
				(resolve-pathname lnkpath)
				lnkpath)
			    testname "")
	  ;; (rmt:general-call 'test-set-rundir run-id lnkpath testname "") ;; toptest-path)
	  (if (or (not curr-test-path)
		  (not (directory-exists? toptest-path)))
	      (begin
		(debug:print-info 2 "Creating " toptest-path " and link " lnkpath)
		(handle-exceptions
		 exn
		 #f ;; don't care to catch and deal with errors here for now.
		 (create-directory toptest-path #t))
		(hash-table-set! *toptest-paths* testname toptest-path)))))

    ;; The toptest path has been created, the link to the test in the linktree has
    ;; been created. Now, if this is an iterated test the real test dir must be created
    (if (not not-iterated) ;; this is an iterated test
	(begin ;; (let ((lnktarget (conc lnkpath "/" item-path)))
	  (debug:print 2 "Setting up sub test run area")
	  (debug:print 2 " - creating run area in " test-path)
	  (handle-exceptions
	   exn
	   (begin
	     (debug:print 0 "ERROR:  Failed to create directory " test-path ((condition-property-accessor 'exn 'message) exn) ", exiting")
	     (exit 1))
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
	   exn
	   (begin
	     (debug:print 0 "ERROR:  Failed to re-create link " lnktarget ((condition-property-accessor 'exn 'message) exn) ", exiting")
	     (exit))
	   (if (symbolic-link? lnktarget)     (delete-file lnktarget))
	   (if (not (file-exists? lnktarget)) (create-symbolic-link test-path lnktarget)))))

    ;; I suspect this section was deleting test directories under some 
    ;; wierd sitations? This doesn't make sense - reenabling the rm -f 
    ;; I honestly don't remember *why* this chunk was needed...
    ;; (let ((testlink (conc lnkpath "/" testname)))
    ;;   (if (and (file-exists? testlink)
    ;;            (or (regular-file? testlink)
    ;;     	   (symbolic-link? testlink)))
    ;;       (system (conc "rm -f " testlink)))
    ;;   (system  (conc "ln -sf " test-path " " testlink)))
    (if (directory? test-path)
	(begin
	  (let* ((ovrcmd (let ((cmd (config-lookup *configdat* "setup" "testcopycmd")))
			   (if cmd
			       ;; substitute the TEST_SRC_PATH and TEST_TARG_PATH
			       (string-substitute "TEST_TARG_PATH" test-path
						  (string-substitute "TEST_SRC_PATH" test-src-path cmd #t) #t)
			       #f)))
		 (cmd    (if ovrcmd 
			     ovrcmd
			     (conc "rsync -av" (if (debug:debug-mode 1) "" "q") " " test-src-path "/ " test-path "/"
				   " >> " test-path "/mt_launch.log 2>> " test-path "/mt_launch.log")))
		 (status (system cmd)))
	    (if (not (eq? status 0))
		(debug:print 2 "ERROR: problem with running \"" cmd "\"")))
	  (list lnkpathf lnkpath ))





	(list #f #f))))

;; 1. look though disks list for disk with most space
;; 2. create run dir on disk, path name is meaningful
;; 3. create link from run dir to megatest runs area 
;; 4. remotely run the test on allocated host
;;    - could be ssh to host from hosts table (update regularly with load)
;;    - could be netbatch







|
|
|
<
<
<
<
<
<
|















>
>
>
>
>
|







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
	   exn
	   (begin
	     (debug:print 0 "ERROR:  Failed to re-create link " lnktarget ((condition-property-accessor 'exn 'message) exn) ", exiting")
	     (exit))
	   (if (symbolic-link? lnktarget)     (delete-file lnktarget))
	   (if (not (file-exists? lnktarget)) (create-symbolic-link test-path lnktarget)))))

    (if (not (directory? test-path))
	(create-directory test-path #t)) ;; this is a hack, I don't know why out of the blue this path does not exist sometimes







    (if (and test-src-path (directory? test-path))
	(begin
	  (let* ((ovrcmd (let ((cmd (config-lookup *configdat* "setup" "testcopycmd")))
			   (if cmd
			       ;; substitute the TEST_SRC_PATH and TEST_TARG_PATH
			       (string-substitute "TEST_TARG_PATH" test-path
						  (string-substitute "TEST_SRC_PATH" test-src-path cmd #t) #t)
			       #f)))
		 (cmd    (if ovrcmd 
			     ovrcmd
			     (conc "rsync -av" (if (debug:debug-mode 1) "" "q") " " test-src-path "/ " test-path "/"
				   " >> " test-path "/mt_launch.log 2>> " test-path "/mt_launch.log")))
		 (status (system cmd)))
	    (if (not (eq? status 0))
		(debug:print 2 "ERROR: problem with running \"" cmd "\"")))
	  (list lnkpathf lnkpath ))
	(if (and test-src-path (> remtries 0))
	    (begin
	      (debug:print 0 "ERROR: Failed to create work area at " test-path " with link at " lnktarget ", remaining attempts " remtries)
	      ;; 
	      (create-work-area run-id run-info keyvals test-id test-src-path disk-path testname itemdat remtries: (- remtries 1)))
	    (list #f #f)))))

;; 1. look though disks list for disk with most space
;; 2. create run dir on disk, path name is meaningful
;; 3. create link from run dir to megatest runs area 
;; 4. remotely run the test on allocated host
;;    - could be ssh to host from hosts table (update regularly with load)
;;    - could be netbatch
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
	 (work-area  #f)
	 (toptest-work-area #f) ;; for iterated tests the top test contains data relevant for all
	 (diskpath   #f)
	 (cmdparms   #f)
	 (fullcmd    #f) ;; (define a (with-output-to-string (lambda ()(write x))))
	 (mt-bindir-path #f)
	 ;; (test-id    (cdb:remote-run db:get-test-id #f run-id test-name item-path))
	 (testinfo   (cdb:get-test-info-by-id *runremote* test-id))
	 (mt_target  (string-intersperse (map cadr keyvals) "/"))
	 (debug-param (append (if (args:get-arg "-debug")  (list "-debug" (args:get-arg "-debug")) '())
			      (if (args:get-arg "-logging")(list "-logging") '()))))
    (setenv "MT_ITEMPATH" item-path)
    (if hosts (set! hosts (string-split hosts)))
    ;; set the megatest to be called on the remote host
    (if (not remote-megatest)(set! remote-megatest local-megatest)) ;; "megatest"))
    (set! mt-bindir-path (pathname-directory remote-megatest))
    (if launcher (set! launcher (string-split launcher)))
    ;; set up the run work area for this test
    (if (and (args:get-arg "-preclean") ;; user has requested to preclean for this run
	     (not (equal? (db:test-get-rundir testinfo) "n/a"))) ;; n/a is a placeholder and thus not a read dir
	(begin 
	  (debug:print-info 0 "attempting to preclean directory " (db:test-get-rundir testinfo) " for test " test-name "/" item-path)
	  (runs:remove-test-directory #f testinfo #t))) ;; remove data only, do not perturb the record





    (set! diskpath (get-best-disk *configdat*))
    (if diskpath
	(let ((dat  (create-work-area run-id run-info keyvals test-id test-path diskpath test-name itemdat)))
	  (set! work-area (car dat))
	  (set! toptest-work-area (cadr dat))
	  (debug:print-info 2 "Using work area " work-area))
	(begin
	  (set! work-area (conc test-path "/tmp_run"))
	  (create-directory work-area #t)
	  (debug:print 0 "WARNING: No disk work area specified - running in the test directory under tmp_run")))
    (set! cmdparms (base64:base64-encode 

		    (with-output-to-string
		      (lambda () ;; (list 'hosts     hosts)
			(write (list (list 'testpath  test-path)
				     ;; (list 'runremote *runremote*)
				     (list 'transport (conc *transport-type*))
				     (list 'serverinf *server-info*)
				     (list 'toppath   *toppath*)
				     (list 'work-area work-area)
				     (list 'test-name test-name) 
				     (list 'runscript runscript) 
				     (list 'run-id    run-id   )
				     (list 'test-id   test-id  )

				     (list 'itemdat   itemdat  )
				     (list 'megatest  remote-megatest)
				     (list 'ezsteps   ezsteps) 
				     (list 'target    mt_target)
				     (list 'runtlim   (if run-time-limit (common:hms-string->seconds run-time-limit) #f))
				     (list 'env-ovrd  (hash-table-ref/default *configdat* "env-override" '())) 
				     (list 'set-vars  (if params (hash-table-ref/default params "-setvars" #f)))
				     (list 'runname   runname)
				     (list 'mt-bindir-path mt-bindir-path)))))))

    ;; clean out step records from previous run if they exist
    ;; (debug:print-info 4 "FIXMEEEEE!!!! This can be removed some day, perhaps move all test records to the test db?")
    ;; (open-run-close db:delete-test-step-records db test-id)
    (change-directory work-area) ;; so that log files from the launch process don't clutter the test dir
    (tests:test-set-status! test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED"))
    (cond
     ((and launcher hosts) ;; must be using ssh hostname
      (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms) debug-param)))
     ;; (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms))))
     (launcher
      (set! fullcmd (append launcher (list remote-megatest test-sig "-execute" cmdparms) debug-param)))
     ;; (set! fullcmd (append launcher (list remote-megatest test-sig "-execute" cmdparms))))







|











|
|

|
>
>
>
>
>











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

<
|

<







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
	 (work-area  #f)
	 (toptest-work-area #f) ;; for iterated tests the top test contains data relevant for all
	 (diskpath   #f)
	 (cmdparms   #f)
	 (fullcmd    #f) ;; (define a (with-output-to-string (lambda ()(write x))))
	 (mt-bindir-path #f)
	 ;; (test-id    (cdb:remote-run db:get-test-id #f run-id test-name item-path))
	 (testinfo   (rmt:get-test-info-by-id run-id test-id))
	 (mt_target  (string-intersperse (map cadr keyvals) "/"))
	 (debug-param (append (if (args:get-arg "-debug")  (list "-debug" (args:get-arg "-debug")) '())
			      (if (args:get-arg "-logging")(list "-logging") '()))))
    (setenv "MT_ITEMPATH" item-path)
    (if hosts (set! hosts (string-split hosts)))
    ;; set the megatest to be called on the remote host
    (if (not remote-megatest)(set! remote-megatest local-megatest)) ;; "megatest"))
    (set! mt-bindir-path (pathname-directory remote-megatest))
    (if launcher (set! launcher (string-split launcher)))
    ;; set up the run work area for this test
    (if (and (args:get-arg "-preclean") ;; user has requested to preclean for this run
	     (not (member (db:test-get-rundir testinfo)(list "n/a" "/tmp/badname")))) ;; n/a is a placeholder and thus not a read dir
	(begin
	  (debug:print-info 0 "attempting to preclean directory " (db:test-get-rundir testinfo) " for test " test-name "/" item-path)
	  (runs:remove-test-directory testinfo 'remove-data-only))) ;; remove data only, do not perturb the record

    ;; prevent overlapping actions - set to LAUNCHED as early as possible
    ;;
    (tests:test-set-status! run-id test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED"))
    (rmt:roll-up-pass-fail-counts run-id test-name item-path "LAUNCHED")
    (set! diskpath (get-best-disk *configdat*))
    (if diskpath
	(let ((dat  (create-work-area run-id run-info keyvals test-id test-path diskpath test-name itemdat)))
	  (set! work-area (car dat))
	  (set! toptest-work-area (cadr dat))
	  (debug:print-info 2 "Using work area " work-area))
	(begin
	  (set! work-area (conc test-path "/tmp_run"))
	  (create-directory work-area #t)
	  (debug:print 0 "WARNING: No disk work area specified - running in the test directory under tmp_run")))
    (set! cmdparms (base64:base64-encode 
		    (z3:encode-buffer 
		     (with-output-to-string
		       (lambda () ;; (list 'hosts     hosts)
			 (write (list (list 'testpath  test-path)

				      (list 'transport (conc *transport-type*))
				      ;; (list 'serverinf *server-info*)
				      (list 'toppath   *toppath*)
				      (list 'work-area work-area)
				      (list 'test-name test-name) 
				      (list 'runscript runscript) 
				      (list 'run-id    run-id   )
				      (list 'test-id   test-id  )
				      ;; (list 'item-path item-path )
				      (list 'itemdat   itemdat  )
				      (list 'megatest  remote-megatest)
				      (list 'ezsteps   ezsteps) 
				      (list 'target    mt_target)
				      (list 'runtlim   (if run-time-limit (common:hms-string->seconds run-time-limit) #f))
				      (list 'env-ovrd  (hash-table-ref/default *configdat* "env-override" '())) 
				      (list 'set-vars  (if params (hash-table-ref/default params "-setvars" #f)))
				      (list 'runname   runname)
				      (list 'mt-bindir-path mt-bindir-path))))))))

    ;; clean out step records from previous run if they exist

    ;; (rmt:delete-test-step-records run-id test-id)
    (change-directory work-area) ;; so that log files from the launch process don't clutter the test dir

    (cond
     ((and launcher hosts) ;; must be using ssh hostname
      (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms) debug-param)))
     ;; (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms))))
     (launcher
      (set! fullcmd (append launcher (list remote-megatest test-sig "-execute" cmdparms) debug-param)))
     ;; (set! fullcmd (append launcher (list remote-megatest test-sig "-execute" cmdparms))))

Modified lock-queue.scm from [0b444a0bb7] to [1e70529cd9].

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
;; Copyright 2006-2013, 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.

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

(use sqlite3 srfi-18)
(import (prefix sqlite3 sqlite3:))

(declare (unit lock-queue))
(declare (uses common))


;;======================================================================
;; attempt to prevent overlapping updates of rollup files by queueing
;; update requests in an sqlite db
;;======================================================================















(define (lock-queue:open-db fname #!key (count 10))
  (let* ((actualfname (conc fname ".lockdb"))
	 (dbexists (file-exists? actualfname))
	 (db       (sqlite3:open-database actualfname))
	 (handler  (make-busy-timeout 136000)))
    (if dbexists
	db
	(begin
	  (handle-exceptions
	   exn
	   (begin
	     (thread-sleep! 10)
	     (if (> count 0)
		 (lock-queue:open-db fname count: (- count 1))


		 db))

	   (sqlite3:execute 
	    db
	    "CREATE TABLE IF NOT EXISTS queue (
  	      id         INTEGER PRIMARY KEY,
              test_id    INTEGER,
              start_time INTEGER,
              state      TEXT,
              CONSTRAINT queue_constraint UNIQUE (test_id));")
	   (sqlite3:execute
	    db
	    "CREATE TABLE IF NOT EXISTS runlocks (
              id         INTEGER PRIMARY KEY,
              test_id    INTEGER,
              run_lock   TEXT,
              CONSTRAINT runlock_constraint UNIQUE (run_lock));"))))
    (sqlite3:set-busy-handler! db handler)
    db))

(define (lock-queue:set-state db test-id newstate #!key (count 10))

  (handle-exceptions
   exn

   (begin


     (thread-sleep! 10)
     (if (> count 0)
	 (lock-queue:set-state db test-id newstate (- count 1))


	 #f))
   (sqlite3:execute db "UPDATE queue SET state=? WHERE test_id=?;"
		    newstate
		    test-id)))

(define (lock-queue:any-younger? db mystart test-id #!key (count 10))
  (let ((res #f))

    (handle-exceptions
     exn

     (begin


       (thread-sleep! 10)
       (if (> count 0)

	   (lock-queue:any-younger? db mystart test-id count: (- count 1))


	   #f))

     (sqlite3:for-each-row
      (lambda (tid)
	;; Actually this should not be needed as mystart cannot be simultaneously less than and test-id same as 
	(if (not (equal? tid test-id)) 
	    (set! res tid)))
      db
      "SELECT test_id FROM queue WHERE start_time > ?;" mystart)
     res)))

(define (lock-queue:get-lock db test-id #!key (count 10))

  (let ((res       #f)

	(lckqry    (sqlite3:prepare db "SELECT test_id,run_lock FROM runlocks WHERE run_lock='locked';"))
	(mklckqry  (sqlite3:prepare db "INSERT INTO runlocks (test_id,run_lock) VALUES (?,'locked');")))
    (let ((result 
	   (handle-exceptions
	    exn
	    (begin


	      (thread-sleep! 10)
	      (if (> count 0)
		  (lock-queue:get-lock db test-id count: (- count 1)))


	      #f)
	    (sqlite3:with-transaction
	     db
	     (lambda ()
	       (sqlite3:for-each-row (lambda (tid lockstate)
				       (set! res (list tid lockstate)))
				     lckqry)
	       (if res
		   (if (equal? (car res) test-id)
		       #t ;; already have the lock
		       #f)
		   (begin
		     (sqlite3:execute mklckqry test-id)
		     ;; if no error handled then return #t for got the lock
		     #t)))))))
      (sqlite3:finalize! lckqry)
      (sqlite3:finalize! mklckqry)
      result)))

(define (lock-queue:release-lock fname test-id #!key (count 10))
  (let ((db (lock-queue:open-db fname)))

    (handle-exceptions
     exn
     (begin


       (thread-sleep! 10)
       (if (> count 0)


	   (lock-queue:release-lock fname test-id count: (- count 1))








	   #f))
     (sqlite3:execute db "DELETE FROM runlocks WHERE test_id=?;" test-id)
     (sqlite3:finalize! db))))

(define (lock-queue:steal-lock db test-id #!key (count 10))


  (handle-exceptions
   exn
   (begin


     (thread-sleep! 10)
     (if (> count 0)
	 (lock-queue:steal-lock db test-id count: (- count 1))
	 #f))
   (sqlite3:execute db "DELETE FROM runlocks WHERE run_lock='locked';"))
  (lock-queue:get-lock db test-it))

;; returns #f if ok to skip the task
;; returns #t if ok to proceed with task
;; otherwise waits
;;
(define (lock-queue:wait-turn fname test-id #!key (count 10))
  (let ((db      (lock-queue:open-db fname))
	(mystart (current-seconds)))


    (handle-exceptions
     exn
     (begin



       (thread-sleep! 10)
       (if (> count 0)


	   (lock-queue:wait-turn fname test-id count: (- count 1))



	   #f))





     (sqlite3:execute
      db
      "INSERT OR REPLACE INTO queue (test_id,start_time,state) VALUES (?,?,'waiting');"
      test-id mystart)
     (thread-sleep! 1) ;; give other tests a chance to register
     (let ((result 
	    (let loop ((younger-waiting (lock-queue:any-younger? db mystart test-id)))
	      (if younger-waiting
		  (begin
		    ;; no need for us to wait. mark in the lock queue db as skipping


		    (lock-queue:set-state db test-id "skipping")
		    #f) ;; let the calling process know that nothing needs to be done
		  (if (lock-queue:get-lock db test-id)
		      #t
		      (if (> (- (current-seconds) mystart) 36000) ;; waited too long, steal the lock
			  (lock-queue:steal-lock db test-id)
			  (begin
			    (thread-sleep! 1)
			    (loop (lock-queue:any-younger? db mystart test-id)))))))))
       (sqlite3:finalize! db)
       result))))
	  
            
;; (use trace)
;; (trace lock-queue:get-lock lock-queue:release-lock lock-queue:wait-turn lock-queue:any-younger? lock-queue:set-state)









<
<
<
<
<





>





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







|







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

|

|
>


>
|
>
>
|
<
|
>
>

|



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





|



|
>
|
>
|
|




>
>

|
|
>
>




















|
>



>
>
|

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

|
>
>



>
>


|

|
|





|
|
|
>
>



>
>
>


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




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
;; Copyright 2006-2013, 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.






(use sqlite3 srfi-18)
(import (prefix sqlite3 sqlite3:))

(declare (unit lock-queue))
(declare (uses common))
(declare (uses tasks))

;;======================================================================
;; attempt to prevent overlapping updates of rollup files by queueing
;; update requests in an sqlite db
;;======================================================================

;;======================================================================
;; db record, <vector db path-to-db>
;;======================================================================

(define (make-lock-queue:db-dat)(make-vector 3))
(define-inline (lock-queue:db-dat-get-db        vec)    (vector-ref  vec 0))
(define-inline (lock-queue:db-dat-get-path      vec)    (vector-ref  vec 1))
(define-inline (lock-queue:db-dat-set-db!       vec val)(vector-set! vec 0 val))
(define-inline (lock-queue:db-dat-set-path!     vec val)(vector-set! vec 1 val))

(define (lock-queue:delete-lock-db dbdat)
  (let ((fname (lock-queue:db-dat-get-path dbdat)))
    (system (conc "rm -f " fname "*"))))

(define (lock-queue:open-db fname #!key (count 10))
  (let* ((actualfname (conc fname ".lockdb"))
	 (dbexists (file-exists? actualfname))
	 (db       (sqlite3:open-database actualfname))
	 (handler  (make-busy-timeout 136000)))
    (if dbexists
	(vector db actualfname)
	(begin
	  (handle-exceptions
	   exn
	   (begin
	     (thread-sleep! 10)
	     (if (> count 0)
		 (lock-queue:open-db fname count: (- count 1))
		 (vector db actualfname)))
	   (sqlite3:with-transaction
	    db
	    (lambda ()
	      (sqlite3:execute 
	       db
	       "CREATE TABLE IF NOT EXISTS queue (
     	         id         INTEGER PRIMARY KEY,
                 test_id    INTEGER,
                 start_time INTEGER,
                 state      TEXT,
                 CONSTRAINT queue_constraint UNIQUE (test_id));")
	      (sqlite3:execute
	       db
	       "CREATE TABLE IF NOT EXISTS runlocks (
                 id         INTEGER PRIMARY KEY,
                 test_id    INTEGER,
                 run_lock   TEXT,
                 CONSTRAINT runlock_constraint UNIQUE (run_lock));"))))))
    (sqlite3:set-busy-handler! db handler)
    (vector db actualfname)))

(define (lock-queue:set-state dbdat test-id newstate #!key (remtries 10))
  (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200)
  (handle-exceptions
   exn
   (if (> remtries 0)
       (begin
	 (debug:print 0 "WARNING: exception on lock-queue:set-state. Trying again in 30 seconds.")
	 (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
	 (thread-sleep! 30)

	 (lock-queue:set-state dbdat test-id newstate remtries: (- remtries 1)))
       (begin
	 (debug:print 0 "ERROR:  Failed to set lock state for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.")
	 #f))
   (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "UPDATE queue SET state=? WHERE test_id=?;"
		    newstate
		    test-id)))

(define (lock-queue:any-younger? dbdat mystart test-id #!key (remtries 10))
  ;; no need to wait on journal on read only queries
  ;; (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200)
  (handle-exceptions
   exn
   (if (> remtries 0)
       (begin
	 (debug:print 0 "WARNING: exception on lock-queue:any-younger. Removing lockdb and trying again in 5 seconds.")
	 (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
	 (thread-sleep! 5)

         (lock-queue:delete-lock-db dbdat)
	 (lock-queue:any-younger? dbdat mystart test-id remtries: (- remtries 1)))
       (begin
	 (debug:print 0 "ERROR:  Failed to find younger locks for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.")
	 #f))
   (let ((res #f))
     (sqlite3:for-each-row
      (lambda (tid)
	;; Actually this should not be needed as mystart cannot be simultaneously less than and test-id same as 
	(if (not (equal? tid test-id)) 
	    (set! res tid)))
      (lock-queue:db-dat-get-db dbdat)
      "SELECT test_id FROM queue WHERE start_time > ?;" mystart)
     res)))

(define (lock-queue:get-lock dbdat test-id #!key (count 10)(waiting-msg #f))
  (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 remove: #t waiting-msg: "lock-queue:get-lock, waiting on journal")
  (let* ((res       #f)
	 (db        (lock-queue:db-dat-get-db dbdat))
	 (lckqry    (sqlite3:prepare db "SELECT test_id,run_lock FROM runlocks WHERE run_lock='locked';"))
	 (mklckqry  (sqlite3:prepare db "INSERT INTO runlocks (test_id,run_lock) VALUES (?,'locked');")))
    (let ((result 
	   (handle-exceptions
	    exn
	    (begin
	      (debug:print 0 "WARNING: failed to get queue lock. Removing lock db and returning fail") ;; Will try again in a few seconds")
	      (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
	      (thread-sleep! 10)
	      ;; (if (> count 0)	
	      ;;  #f ;; (lock-queue:get-lock dbdat test-id count: (- count 1)) - give up on retries 
	      ;; (begin ;; never recovered, remote the lock file and return #f, no lock obtained
	      (lock-queue:delete-lock-db dbdat)
	      #f)
	    (sqlite3:with-transaction
	     db
	     (lambda ()
	       (sqlite3:for-each-row (lambda (tid lockstate)
				       (set! res (list tid lockstate)))
				     lckqry)
	       (if res
		   (if (equal? (car res) test-id)
		       #t ;; already have the lock
		       #f)
		   (begin
		     (sqlite3:execute mklckqry test-id)
		     ;; if no error handled then return #t for got the lock
		     #t)))))))
      (sqlite3:finalize! lckqry)
      (sqlite3:finalize! mklckqry)
      result)))

(define (lock-queue:release-lock fname test-id #!key (count 10))
  (let* ((dbdat (lock-queue:open-db fname)))
    (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 "lock-queue:release-lock; waiting on journal")
    (handle-exceptions
     exn
     (begin
       (debug:print 0 "WARNING: Failed to release queue lock. Will try again in few seconds")
       (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
       (thread-sleep! (/ count 10))
       (if (> count 0)
	   (begin
	     (sqlite3:finalize! (lock-queue:db-dat-get-db dbdat))
	     (lock-queue:release-lock fname test-id count: (- count 1)))
	   (let ((journal (conc fname "-journal")))
	     ;; If we've tried ten times and failed there is a serious problem
	     ;; try to remove the lock db and allow it to be recreated
	     (handle-exceptions
	      exn
	      #f
	      (if (file-exists? journal)(delete-file journal))
	      (if (file-exists? fname)  (delete-file fname))
	      #f))))
     (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE test_id=?;" test-id)
     (sqlite3:finalize! (lock-queue:db-dat-get-db dbdat)))))

(define (lock-queue:steal-lock dbdat test-id #!key (count 10))
  (debug:print-info 0 "Attempting to steal lock at " (lock-queue:db-dat-get-path dbdat))
  (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 "lock-queue:steal-lock; waiting on journal")
  (handle-exceptions
   exn
   (begin
     (tadebug:print 0 "WARNING: Failed to steal queue lock. Will try again in few seconds")
     (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
     (thread-sleep! 10)
     (if (> count 0)
	 (lock-queue:steal-lock dbdat test-id count: (- count 1))
	 #f))
   (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE run_lock='locked';"))
  (lock-queue:get-lock dbdat test-it))

;; returns #f if ok to skip the task
;; returns #t if ok to proceed with task
;; otherwise waits
;;
(define (lock-queue:wait-turn fname test-id #!key (count 10)(waiting-msg #f))
  (let* ((dbdat   (lock-queue:open-db fname))
	 (mystart (current-seconds))
	 (db      (lock-queue:db-dat-get-db dbdat)))
    ;; (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 waiting-msg: "lock-queue:wait-turn; waiting on journal file")
    (handle-exceptions
     exn
     (begin
       (debug:print 0 "WARNING: Failed to find out if it is ok to skip the wait queue. Will try again in few seconds")
       (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
       (print-call-chain (current-error-port))
       (thread-sleep! 10)
       (if (> count 0)
	   (begin
	     (sqlite3:finalize! db)
	     (lock-queue:wait-turn fname test-id count: (- count 1)))
	   (begin
	     (debug:print 0 "Giving up calls to lock-queue:wait-turn for test-id " test-id " at path " fname ", printing call chain")
	     (print-call-chain (current-error-port))
	     #f)))
     ;; wait 10 seconds and then check to see if someone is already updating the html
     (thread-sleep! 10)
     (if (not (lock-queue:any-younger? dbdat mystart test-id)) ;; no processing in flight, must try to start processing
	 (begin
	   (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 waiting-msg: "lock-queue:wait-turn; waiting on journal file")
	   (sqlite3:execute
	    db
	    "INSERT OR REPLACE INTO queue (test_id,start_time,state) VALUES (?,?,'waiting');"
	    test-id mystart)
	   ;; (thread-sleep! 1) ;; give other tests a chance to register
	   (let ((result 
		  (let loop ((younger-waiting (lock-queue:any-younger? dbdat mystart test-id)))
		    (if younger-waiting
			(begin
			  ;; no need for us to wait. mark in the lock queue db as skipping
			  ;; no point in marking anything in the queue - simply never register this
			  ;; test as it is *covered* by a previously started update to the html file
			  ;; (lock-queue:set-state dbdat test-id "skipping")
			  #f) ;; let the calling process know that nothing needs to be done
			(if (lock-queue:get-lock dbdat test-id)
			    #t
			    (if (> (- (current-seconds) mystart) 36000) ;; waited too long, steal the lock
				(lock-queue:steal-lock dbdat test-id)
				(begin
				  (thread-sleep! 1)
				  (loop (lock-queue:any-younger? dbdat mystart test-id)))))))))
	     (sqlite3:finalize! db)
	     result))))))
	  
            
;; (use trace)
;; (trace lock-queue:get-lock lock-queue:release-lock lock-queue:wait-turn lock-queue:any-younger? lock-queue:set-state)

Modified megatest-version.scm from [ca9cc860b4] to [66e3f5fa5c].

1
2
3
4
5
6
7
;; Always use two digit decimal
;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00..

(declare (unit megatest-version))

(define megatest-version 1.5525)

|
|



|

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

Modified megatest.scm from [54431b021e] to [0e40d16995].

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
;; Copyright 2006-2012, 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.

;; (include "common.scm")
;; (include "megatest-version.scm")

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






(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))



;; (use zmq)

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






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












|
>
>
>
>
>
>


>
>















>
>
>
>
>







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
;; Copyright 2006-2012, 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.

;; (include "common.scm")
;; (include "megatest-version.scm")

(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 readline apropos json http-client directory-utils rpc ;; (srfi 18) extras)
     http-client srfi-18 extras format) ;;  zmq extras)

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

(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))
(import (prefix rpc rpc:))
(require-library mutils)

;; (use zmq)

(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 tdb))
(declare (uses mt))
(declare (uses api))
(declare (uses tasks)) ;; only used for debugging.

(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")
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
  -section sectionName
  -var varName            : for config and runconfig lookup value for sectionName varName

Misc 
  -start-dir path         : switch to this directory before running megatest
  -rebuild-db             : bring the database schema up to date
  -cleanup-db             : remove any orphan records, vacuum the db


  -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
  -transport http|fs      : use http or direct access for transport (default is http) 
  -daemonize              : fork into background and disconnect from stdin/out

  -list-servers           : list the servers 
  -stop-server id         : stop server specified by id (see output of -list-servers), use
                            0 to kill all
  -repl                   : start a repl (useful for extending megatest)
  -load file.scm          : load and run file.scm
  -mark-incompletes       : find and mark incomplete tests


Utilities
  -env2file fname         : write the environment to fname.csh and fname.sh
  -refdb2dat refdb        : convert refdb to sexp or to format specified by -dumpmode
                            formats: perl, ruby, sqlite3


  -o                      : output file for refdb2dat (defaults to stdout)




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







>
>





|

>






>




|
>
>

>
>
>







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
  -section sectionName
  -var varName            : for config and runconfig lookup value for sectionName varName

Misc 
  -start-dir path         : switch to this directory before running megatest
  -rebuild-db             : bring the database schema up to date
  -cleanup-db             : remove any orphan records, vacuum the db
  -import-megatest.db     : migrate a database from v1.55 series to v1.60 series
  -sync-to-megatest.db    : migrate data back to megatest.db
  -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
  -transport http|zmq     : use http or zmq for transport (default is http) 
  -daemonize              : fork into background and disconnect from stdin/out
  -log logfile            : send stdout and stderr to logfile
  -list-servers           : list the servers 
  -stop-server id         : stop server specified by id (see output of -list-servers), use
                            0 to kill all
  -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

Utilities
  -env2file fname         : write the environment to fname.csh and fname.sh
  -refdb2dat refdb        : convert refdb to sexp or to format specified by -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

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
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
			":value"
			":expected"
			":tol"
			":units"
			;; misc
			"-start-dir"
			"-server"

			"-transport"
			"-stop-server"
			"-port"
			"-extract-ods"
			"-pathmod"
			"-env2file"
			"-setvars"
			"-set-state-status"
			"-set-run-status"
			"-debug" ;; for *verbosity* > 2
			"-gen-megatest-test"
			"-override-timeout"
			"-test-files"  ;; -test-paths is for listing all
			"-load"        ;; load and exectute a scheme file
			"-section"
			"-var"
			"-dumpmode"


			"-refdb2dat"
			"-o"


			) 
		 (list  "-h" "-help" "--help"
			"-version"
		        "-force"
		        "-xterm"
		        "-showkeys"
		        "-show-keys"
		        "-test-status"
			"-set-values"
			"-load-test-data"
			"-summarize-items"
		        "-gui"
			"-daemonize"
			"-preclean"
			;; misc
			"-archive"
			"-repl"
			"-lock"
			"-unlock"
			"-list-servers"
                        "-run-wait"      ;; wait on a run to complete (i.e. no RUNNING)

			;; misc queries







>

|















>
>


>
>















<







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
			":value"
			":expected"
			":tol"
			":units"
			;; misc
			"-start-dir"
			"-server"
			"-stop-server"
			"-transport"
			"-kill-server"
			"-port"
			"-extract-ods"
			"-pathmod"
			"-env2file"
			"-setvars"
			"-set-state-status"
			"-set-run-status"
			"-debug" ;; for *verbosity* > 2
			"-gen-megatest-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"
			"-archive"
			) 
		 (list  "-h" "-help" "--help"
			"-version"
		        "-force"
		        "-xterm"
		        "-showkeys"
		        "-show-keys"
		        "-test-status"
			"-set-values"
			"-load-test-data"
			"-summarize-items"
		        "-gui"
			"-daemonize"
			"-preclean"
			;; misc

			"-repl"
			"-lock"
			"-unlock"
			"-list-servers"
                        "-run-wait"      ;; wait on a run to complete (i.e. no RUNNING)

			;; misc queries
254
255
256
257
258
259
260





261
262
263
264
265
266



























































267
268
269
270
271
272
273
			"-rebuild-db"
			"-cleanup-db"
			"-rollup"
			"-update-meta"
			"-gen-megatest-area"
			"-mark-incompletes"






			"-logging"
			"-v" ;; verbose 2, more than normal (normal is 1)
			"-q" ;; quiet 0, errors/warnings only
		       )
		 args:arg-hash
		 0))




























































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







>
>
>
>
>






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







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
			"-rebuild-db"
			"-cleanup-db"
			"-rollup"
			"-update-meta"
			"-gen-megatest-area"
			"-mark-incompletes"

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

			"-logging"
			"-v" ;; verbose 2, more than normal (normal is 1)
			"-q" ;; quiet 0, errors/warnings only
		       )
		 args:arg-hash
		 0))

;; The watchdog is to keep an eye on things like db sync etc.
;;
(define *time-zero* (current-seconds))
(define *watchdog*
  (make-thread 
   (lambda ()
     (thread-sleep! 0.05) ;; delay for startup
     (let ((legacy-sync (configf:lookup *configdat* "setup" "megatest-db"))
	   (debug-mode  (debug:debug-mode 1))
	   (last-time   (current-seconds)))
       (let loop ()
	 ;; sync for filesystem local db writes
	 ;;
	 (let ((start-time      (current-seconds))
	       (servers-started (make-hash-table)))
	   (for-each 
	    (lambda (run-id)
	      (mutex-lock! *db-multi-sync-mutex*)
	      (if (and legacy-sync 
		       (hash-table-ref/default *db-local-sync* run-id #f))
		  ;; (if (> (- start-time last-write) 5) ;; every five seconds
		  (begin ;; let ((sync-time (- (current-seconds) start-time)))
		    (db:multi-db-sync (list run-id) 'new2old)
		    (if (common:low-noise-print 30 "sync new to old")
			(let ((sync-time (- (current-seconds) start-time)))
			  (debug:print-info 0 "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds")))
		    ;; (if (> sync-time 10) ;; took more than ten seconds, start a server for this run
		    ;;     (begin
		    ;;       (debug:print-info 0 "Sync is taking a long time, start up a server to assist for run " run-id)
		    ;;       (server:kind-run run-id)))))
		    (hash-table-delete! *db-local-sync* run-id)))
	      (mutex-unlock! *db-multi-sync-mutex*))
	    (hash-table-keys *db-local-sync*))
	   (if (and debug-mode
		    (> (- start-time last-time) 60))
	       (begin
		 (set! last-time start-time)
		 (debug:print-info 4 "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*))))))
	 
	 ;; keep going unless time to exit
	 ;;
	 (if (not *time-to-exit*)
	     (let delay-loop ((count 0))
	       (if (and (not *time-to-exit*)
			(< count 11)) ;; aprox 5-6 seconds
		   (begin
		     (thread-sleep! 1)
		     (delay-loop (+ count 1))))
	       (loop))))))
   "Watchdog thread"))

(thread-start! *watchdog*)

(if (args:get-arg "-log")
    (let ((oup (open-output-file (args:get-arg "-log"))))
      (debug:print-info 0 "Sending log output to " (args:get-arg "-log"))
      (current-error-port oup)
      (current-output-port oup)))

(if (or (args:get-arg "-h")
	(args:get-arg "-help")
	(args:get-arg "--help"))
    (begin
      (print help)
      (exit)))
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
					      (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)))))

;; Force default transport to fs
;; (if ;; (and (or (args:get-arg "-list-targets")
;;     ;;          (args:get-arg "-list-db-targets"))
;;  (not (args:get-arg "-transport"))
;;  (hash-table-set! args:arg-hash "-transport" "fs"))

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



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

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

(if (args:get-arg "-list-disks")
    (begin
      (print 
       (string-intersperse 
	(map (lambda (x)
	       (string-intersperse 
		x
		" => "))
	     (common:get-disks) )
	"\n"))
      (set! *didsomething* #t)))

















































(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 (equal? out-fmt "sqlite3")))
			 (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 data) ;; some error occurred
	  (with-output-to-port out-port
	    (lambda ()
	      (case (string->symbol out-fmt)
		((scheme)(pp data))
		((perl)
		 ;; (print "%hash = (")
		 ;;        key1 => 'value1',







<
<
<
<
<
<
















>
>











|






|



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





|






|







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







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

(on-exit std-exit-procedure)

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

(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-for-run)))
      (print 
       (string-intersperse 
	(map (lambda (x)
	       (string-intersperse 
		x
		" => "))
	     (common:get-disks *configdat*))
	"\n"))
      (set! *didsomething* #t)))

(define (make-sparse-array)
  (let ((a (make-sparse-vector)))
    (sparse-vector-set! a 0 (make-sparse-vector))
    a))

(define (sparse-array? a)
  (and (sparse-vector? a)
       (sparse-vector? (sparse-vector-ref a 0))))

(define (sparse-array-ref a x y)
  (let ((row (sparse-vector-ref a x)))
    (if row
	(sparse-vector-ref row y)
	#f)))

(define (sparse-array-set! a x y val)
  (let ((row (sparse-vector-ref a x)))
    (if row
	(sparse-vector-set! row y val)
	(let ((new-row (make-sparse-vector)))
	  (sparse-vector-set! a x new-row)
	  (sparse-vector-set! new-row y val)))))

;; 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 "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',
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
		    (print "data[\"" sheetname "\"][\"" sectionname "\"][\"" varname "\"] = \"" val "\""))
		  initproc1:
		  (lambda (sheetname)
		    (print "data[\"" sheetname "\"] = {}"))
		  initproc2:
		  (lambda (sheetname sectionname)
		    (print "data[\"" sheetname "\"][\"" sectionname "\"] = {}"))))







































































		((sqlite3)
		 (let* ((db-file   (or out-file (pathname-file input-db)))
			(db-exists (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
      ))














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

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

    ;; Server? Start up here.
    ;;
    (let ((tl        (launch:setup-for-run))
	  (transport (or (configf:lookup *configdat* "setup" "transport")
			 (args:get-arg "-transport" "http"))))
      (debug:print 2 "Launching server using transport " transport)

      (server:launch (string->symbol transport)))



    ;; Not a server? This section will decide how to communicate
    ;;
    ;;  Setup client for all expect listed here
    (if (null? (lset-intersection 
		     equal?
		     (hash-table-keys args:arg-hash)
		     '("-list-servers"
		       "-stop-server"
		       "-show-cmdinfo")))


	(if (launch:setup-for-run)
	    (begin



	      ;; if not list or kill then start a client (if appropriate)
	      (if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test")
		      (eq? (length (hash-table-keys args:arg-hash)) 0))
		  (debug:print-info 1 "Server connection not needed")
		  ;; ok, so lets connect to the server
		  (let* ((transport-from-config   (configf:lookup *configdat* "setup" "transport"))
			 (transport-from-cmdln    (args:get-arg "-transport"))
			 (transport-from-cmdinfo  (if (getenv "MT_CMDINFO")
						      (let ((res (assoc 'transport 
									(read
									 (open-input-string 
									  (base64:base64-decode
									   (getenv "MT_CMDINFO")))))))
							(if res (cadr res) #f))


						      #f))
			 (chosen-transport        (string->symbol (or transport-from-cmdln
								      transport-from-cmdinfo
								      transport-from-config
								      "fs"))))
		    (debug:print 2 "chosen-transport: " chosen-transport " have; config=" transport-from-config ", cmdln=" transport-from-cmdln ", cmdinfo=" transport-from-cmdinfo)
		    (case chosen-transport
		      ((http)
		       (set! *transport-type 'http)
		       (server:ensure-running)
		       (client:launch))
		      (else ;; (fs)
		       (set! *transport-type* 'fs)
		       (set! *megatest-db* (open-db))))))))))

(if (or (args:get-arg "-list-servers")
	(args:get-arg "-stop-server"))
    (let ((tl (launch:setup-for-run)))
      (if tl 

	  (let* ((servers (open-run-close tasks:get-all-servers tasks:open-db))
		 (fmtstr  "~5a~12a~8a~20a~24a~10a~10a~10a~10a\n")
		 (servers-to-kill '())
		 (killinfo   (args:get-arg "-stop-server"))
		 (khost-port (if killinfo (if (substring-index ":" killinfo)(string-split ":") #f) #f))
		 (sid        (if killinfo (if (substring-index ":" killinfo) #f (string->number killinfo)) #f)))
	    (format #t fmtstr "Id" "MTver" "Pid" "Host" "Interface:OutPort" "InPort" "LastBeat" "State" "Transport")
	    (format #t fmtstr "==" "=====" "===" "====" "=================" "======" "========" "=====" "=========")
	    (for-each 
	     (lambda (server)
	       (let* ((id         (vector-ref server 0))
		      (pid        (vector-ref server 1))
		      (hostname   (vector-ref server 2))
		      (interface  (vector-ref server 3)) 
		      (pullport   (vector-ref server 4))
		      (pubport    (vector-ref server 5))
		      (start-time (vector-ref server 6))
		      (priority   (vector-ref server 7))
		      (state      (vector-ref server 8))
		      (mt-ver     (vector-ref server 9))
		      (last-update (vector-ref server 10)) ;;   (open-run-close tasks:server-alive? tasks:open-db #f hostname: hostname port: port))
		      (transport  (vector-ref server 11))
		      (killed     #f)
		      (status     (< last-update 20)))
		 ;;   (zmq-sockets (if status (server:client-connect hostname port) #f)))
		 ;; no need to login as status of #t indicates we are connecting to correct 
		 ;; server
		 (if (equal? state "dead")
		     (if (> last-update (* 25 60 60)) ;; keep records around for slighly over a day.
			 (open-run-close tasks:server-deregister tasks:open-db hostname pullport: pullport pid: pid action: 'delete))
		     (if (> last-update 20)        ;; Mark as dead if not updated in last 20 seconds
			 (open-run-close tasks:server-deregister tasks:open-db hostname pullport: pullport pid: pid)))
		 (format #t fmtstr id mt-ver pid hostname (conc interface ":" pullport) pubport last-update
			 (if status "alive" "dead") transport)
		 (if (or (equal? id sid)
			 (equal? sid 0)) ;; kill all/any
		     (begin
		       (debug:print-info 0 "Attempting to stop server with pid " pid)
		       (tasks:kill-server status hostname pullport pid transport)))))







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


















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










|
|
|
>
|
>
>









|
>
>

<
|
>
>




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





>
|



















|








|

|







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
		    (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 (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* ((run-id        (string->number (args:get-arg "-run-id")))
	   (host:port     (args:get-arg "-ping")))
      (server:ping run-id host:port)))

;;       (set! *did-something* #t)
;; 	      (begin
;; 		(print ((rpc:procedure 'testing (car host-port)(cadr host-port))))
;; 		(case (server:get-transport)
;; 		  ((http)(http:ping run-id host-port))
;; 		  ((rpc) (rpc:procedure 'server:login (car host-port)(cadr host-port));;  *toppath*)) ;; (rpc-transport:ping  run-id (car host-port)(cadr host-port)))
;; 		  (else  (debug:print 0 "ERROR: No transport set")(exit)))))

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

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

    ;; Server? Start up here.
    ;;
    (let ((tl        (launch:setup-for-run))
	  (run-id    (and (args:get-arg "-run-id")
			  (string->number (args:get-arg "-run-id")))))
      (if run-id
	  (begin
	    (server:launch run-id)
	    (set! *didsomething* #t))
	  (debug:print 0 "ERROR: server requires run-id be specified with -run-id")))

    ;; Not a server? This section will decide how to communicate
    ;;
    ;;  Setup client for all expect listed here
    (if (null? (lset-intersection 
		     equal?
		     (hash-table-keys args:arg-hash)
		     '("-list-servers"
		       "-stop-server"
		       "-show-cmdinfo"
		       "-list-runs"
		       "-ping")))
	(if (launch:setup-for-run)

	    (let ((run-id    (and (args:get-arg "-run-id")
				  (string->number (args:get-arg "-run-id")))))
	      ;; (set! *fdb*   (filedb:open-db (conc *toppath* "/db/paths.db")))
	      ;; if not list or kill then start a client (if appropriate)
	      (if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test")
		      (eq? (length (hash-table-keys args:arg-hash)) 0))
		  (debug:print-info 1 "Server connection not needed")





		  (begin



		    ;; (if run-id 
		    ;;     (client:launch run-id) 
		    ;;     (client:launch 0)      ;; without run-id we'll start a server for "0"
		    #t



		    ))))))






;; MAY STILL NEED THIS

;;		       (set! *megatest-db* (make-dbr:dbstruct path: *toppath* local: #t))))))))))

(if (or (args:get-arg "-list-servers")
	(args:get-arg "-stop-server"))
    (let ((tl (launch:setup-for-run)))
      (if tl 
	  (let* ((tdbdat  (tasks:open-db))
		 (servers (tasks:get-all-servers (db:delay-if-busy tdbdat)))
		 (fmtstr  "~5a~12a~8a~20a~24a~10a~10a~10a~10a\n")
		 (servers-to-kill '())
		 (killinfo   (args:get-arg "-stop-server"))
		 (khost-port (if killinfo (if (substring-index ":" killinfo)(string-split ":") #f) #f))
		 (sid        (if killinfo (if (substring-index ":" killinfo) #f (string->number killinfo)) #f)))
	    (format #t fmtstr "Id" "MTver" "Pid" "Host" "Interface:OutPort" "InPort" "LastBeat" "State" "Transport")
	    (format #t fmtstr "==" "=====" "===" "====" "=================" "======" "========" "=====" "=========")
	    (for-each 
	     (lambda (server)
	       (let* ((id         (vector-ref server 0))
		      (pid        (vector-ref server 1))
		      (hostname   (vector-ref server 2))
		      (interface  (vector-ref server 3)) 
		      (pullport   (vector-ref server 4))
		      (pubport    (vector-ref server 5))
		      (start-time (vector-ref server 6))
		      (priority   (vector-ref server 7))
		      (state      (vector-ref server 8))
		      (mt-ver     (vector-ref server 9))
		      (last-update (vector-ref server 10)) 
		      (transport  (vector-ref server 11))
		      (killed     #f)
		      (status     (< last-update 20)))
		 ;;   (zmq-sockets (if status (server:client-connect hostname port) #f)))
		 ;; no need to login as status of #t indicates we are connecting to correct 
		 ;; server
		 (if (equal? state "dead")
		     (if (> last-update (* 25 60 60)) ;; keep records around for slighly over a day.
			 (tasks:server-deregister (db:delay-if-busy tdbdat) hostname pullport: pullport pid: pid action: 'delete))
		     (if (> last-update 20)        ;; Mark as dead if not updated in last 20 seconds
			 (tasks:server-deregister (db:delay-if-busy tdbdat) hostname pullport: pullport pid: pid)))
		 (format #t fmtstr id mt-ver pid hostname (conc interface ":" pullport) pubport last-update
			 (if status "alive" "dead") transport)
		 (if (or (equal? id sid)
			 (equal? sid 0)) ;; kill all/any
		     (begin
		       (debug:print-info 0 "Attempting to stop server with pid " pid)
		       (tasks:kill-server status hostname pullport pid transport)))))
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
      (for-each (lambda (x)
		  ;; (print "[" x "]"))
		  (print x))
		targets)
      (set! *didsomething* #t)))

(define (full-runconfigs-read)
  (let* ((keys   (cdb:remote-run db:get-keys #f))
	 (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)







|







736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
      (for-each (lambda (x)
		  ;; (print "[" x "]"))
		  (print x))
		targets)
      (set! *didsomething* #t)))

(define (full-runconfigs-read)
  (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)
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
       (else
	(debug:print 0 "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised")))
      (set! *didsomething* #t)
      (pop-directory)))

(if (args:get-arg "-show-cmdinfo")
    (if (getenv "MT_CMDINFO")
	(let ((data (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO"))))))
	  (if (equal? (args:get-arg "-dumpmode") "json")
	      (json-write data)
	      (pp data))
	  (set! *didsomething* #t))
	(debug:print-info 0 "environment variable MT_CMDINFO is not set")))

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







|







790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
       (else
	(debug:print 0 "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised")))
      (set! *didsomething* #t)
      (pop-directory)))

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

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

(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  (cdb:remote-run db:get-runs-by-patt #f keys runname 
					(common:args-get-target)
					#f #f))
	      (header   (vector-ref runsdat 0))
	      (rows     (vector-ref runsdat 1)))
	 (if (null? rows)
	     (begin
	       (debug:print-info 0 "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")
		   (cdb:remote-run db:set-run-status #f run-id (args:get-arg "-set-run-status") msg: (args:get-arg "-m"))
		   (print (open-run-close db:get-run-status #f run-id))
		   )))))))

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



(if (or (args:get-arg "-list-runs")
	(args:get-arg "-list-db-targets"))
    (if (launch:setup-for-run)
	(let* ((db       #f)
	       (runpatt  (args:get-arg "-list-runs"))
	       (testpatt (if (args:get-arg "-testpatt") 
			     (args:get-arg "-testpatt") 
			     "%"))
	       (keys     (cdb:remote-run db:get-keys #f))
	       (runsdat  (cdb:remote-run db:get-runs-by-patt #f keys (if runpatt runpatt "%")
					 (if (args:get-arg "-list-runs")(common:args-get-target) #f)
					 #f #f))
		;; (cdb:remote-run db:get-runs #f runpatt #f #f '()))
	       (runs     (db:get-rows runsdat))
	       (header   (db:get-header runsdat))
	       (db-targets (args:get-arg "-list-db-targets"))
	       (seen     (make-hash-table)))



	  ;; 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 "]"))))
			 (print targetstr))))
	       (if (not db-targets)
		   (let* ((run-id (db:get-value-by-header run header "id"))
			  (tests  (mt:get-tests-for-run run-id testpatt '() '())))







		     (print "Run: " targetstr "/" (db:get-value-by-header run header "runname") 
			    " status: " (db:get-value-by-header run header "state")
			    " run-id: " run-id ", number tests: " (length tests))
		     (for-each 
		      (lambda (test)
			(format #t
				"  Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n"


				(conc (db:test-get-testname test)
				      (if (equal? (db:test-get-item-path test) "")
					  "" 
					  (conc "(" (db:test-get-item-path test) ")")))
				(db:test-get-state test)
				(db:test-get-status test)













				(db:test-get-run_duration test)
				(db:test-get-event_time test)
				(db:test-get-host test))
			(if (not (or (equal? (db:test-get-status test) "PASS")
				     (equal? (db:test-get-status test) "WARN")
				     (equal? (db:test-get-state test)  "NOT_STARTED")))
			    (begin
			      (print "         cpuload:  " (db:test-get-cpuload test)
				     "\n         diskfree: " (db:test-get-diskfree test)
				     "\n         uname:    " (db:test-get-uname test)
				     "\n         rundir:   " (db:test-get-rundir test)


				     )
			      ;; Each test
			      ;; DO NOT remote run
			      (let ((steps (db:get-steps-for-test #f (db:test-get-id test))))
				(for-each 
				 (lambda (step)
				   (format #t 
					   "    Step: ~20a State: ~10a Status: ~10a Time ~22a\n"
					   (db:step-get-stepname step)
					   (db:step-get-state step)
					   (db:step-get-status step)
					   (db:step-get-event_time step)))
				 steps)))))
		      tests)))))
	     runs)

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

;;======================================================================
;; full run
;;======================================================================

;; get lock in db for full run for this directory
;; for all tests with deps







|











|
|






>
>



|




|
|
|





|
>
>
>











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


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

|
>
|







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

(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))
	      (header   (vector-ref runsdat 0))
	      (rows     (vector-ref runsdat 1)))
	 (if (null? rows)
	     (begin
	       (debug:print-info 0 "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
;;======================================================================

;; NOTE: list-runs and list-db-targets operate on local db!!!
;;
(if (or (args:get-arg "-list-runs")
	(args:get-arg "-list-db-targets"))
    (if (launch:setup-for-run)
	(let* ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t))
	       (runpatt  (args:get-arg "-list-runs"))
	       (testpatt (if (args:get-arg "-testpatt") 
			     (args:get-arg "-testpatt") 
			     "%"))
	       (keys     (db:get-keys dbstruct))
	       ;; (runsdat  (db:get-runs dbstruct runpatt #f #f '()))
	       (runsdat  (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target)
					 #f #f))
		;; (cdb:remote-run db:get-runs #f runpatt #f #f '()))
	       (runs     (db:get-rows runsdat))
	       (header   (db:get-header runsdat))
	       (db-targets (args:get-arg "-list-db-targets"))
	       (seen     (make-hash-table))
	       (dmode    (let ((d (args:get-arg "-dumpmode")))
			   (if d (string->symbol d) #f)))
	       (data     (make-hash-table)))
	  ;; 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))))
		   (let* ((run-id  (db:get-value-by-header run header "id"))
			  (runname (db:get-value-by-header run header "runname")) 
			  (tests  (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc #f)))
		     (case dmode
		       ((json)
			(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" ))
		       (else
			(print "Run: " targetstr "/" runname 
			       " status: " (db:get-value-by-header run header "state")
			       " run-id: " run-id ", number tests: " (length tests))))
		     (for-each 
		      (lambda (test)
		      	(handle-exceptions
			 exn
			 (debug:print 0 "ERROR: Bad data in test record? " test)
			 (let ((test-id    (db:test-get-id test))
			       (fullname   (conc (db:test-get-testname test)
						 (if (equal? (db:test-get-item-path test) "")
						     "" 
						     (conc "(" (db:test-get-item-path test) ")"))))
			       (tstate     (db:test-get-state test))
			       (tstatus    (db:test-get-status test))
			       (event-time (db:test-get-event_time test)))
			   (case dmode
			     ((json)
			      (mutils:hierhash-set! data  fullname   targetstr runname "data" (conc test-id) "tname"     )
			      (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  event-time targetstr runname "data" (conc test-is) "event_time"))
			     (else
			      (format #t
				      "  Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n"
				      fullname
				      tstate
				      tstatus
				      (db:test-get-run_duration test)
				      event-time
				      (db:test-get-host test))
			      (if (not (or (equal? (db:test-get-status test) "PASS")
					   (equal? (db:test-get-status test) "WARN")
					   (equal? (db:test-get-state test)  "NOT_STARTED")))
				  (begin
				    (print   "         cpuload:  " (db:test-get-cpuload test)
					     "\n         diskfree: " (db:test-get-diskfree test)
					     "\n         uname:    " (db:test-get-uname test)
					     "\n         rundir:   " (db:test-get-rundir test)
					     "\n         rundir:   " ;; (sdb:qry 'getstr ;; (filedb:get-path *fdb* 
					     (db:test-get-rundir test) ;; )
					     )
				    ;; Each test
				    ;; DO NOT remote run
				    (let ((steps (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)))))))))
		      tests)))))
	   runs)
	  (if (eq? dmode 'json)(json-write data))
	  (set! *didsomething* #t))))

;;======================================================================
;; full run
;;======================================================================

;; get lock in db for full run for this directory
;; for all tests with deps
787
788
789
790
791
792
793











794
795
796
797
798
799
800
;;    - if cannot access db > allowed disconnect time then kill job

(if (args:get-arg "-runtests")
  (general-run-call 
   "-runtests" 
   "run a test" 
   (lambda (target runname keys keyvals)











     (runs:run-tests target
		     runname
		     (args:get-arg "-runtests")
		     user
		     args:arg-hash))))

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







>
>
>
>
>
>
>
>
>
>
>







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
;;    - if cannot access db > allowed disconnect time then kill job

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

;;======================================================================
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
;; 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   (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO")))))
	       ;; (runremote (assoc/default 'runremote 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))
	       (db        #f)
	       (state     (args:get-arg ":state"))
	       (status    (args:get-arg ":status"))
	       (target    (args:get-arg "-target"))
	       (toppath   (assoc/default 'toppath   cmdinfo)))
	  (change-directory toppath)
	  ;; (set! *runremote* runremote)
	  ;; (set! *transport-type* (string->symbol transport))
	  (if (not target)
	      (begin
		(debug:print 0 "ERROR: -target is required.")
		(exit 1)))
	  (if (not (launch:setup-for-run))
	      (begin
		(debug:print 0 "Failed to setup, giving up on -test-paths or -test-files, exiting")
		(exit 1)))
	  (let* ((keys     (cdb:remote-run db:get-keys db))
		 ;; db:test-get-paths must not be run remote
		 (paths    (db:test-get-paths-matching db keys target (args:get-arg "-test-files"))))
	    (set! *didsomething* #t)
	    (for-each (lambda (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    (db:test-get-paths-matching db keys target (args:get-arg "-test-files"))))
	     (for-each (lambda (path)
			 (print path))
		       paths))))))

;;======================================================================
;; Archive tests
;;======================================================================
;; Archive tests matching target, runname, and testpatt
(if (args:get-arg "-archive")
    ;; if we are in a test use the MT_CMDINFO data
    (if (getenv "MT_CMDINFO")
	(let* ((startingdir (current-directory))
	       (cmdinfo   (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO")))))
	       ;; (runremote (assoc/default 'runremote 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))
	       (db        #f)
	       (state     (args:get-arg ":state"))
	       (status    (args:get-arg ":status"))
	       (target    (args:get-arg "-target")))
	  (change-directory testpath)
	  ;; (set! *runremote* runremote)
	  ;; (set! *transport-type* (string->symbol transport))
	  (if (not target)
	      (begin
		(debug:print 0 "ERROR: -target is required.")
		(exit 1)))
	  (if (not (launch:setup-for-run))
	      (begin
		(debug:print 0 "Failed to setup, giving up on -archive, exiting")
		(exit 1)))
	  (let* ((keys     (cdb:remote-run db:get-keys db))
		 ;; DO NOT run remote
		 (paths    (db:test-get-paths-matching db keys target)))
	    (set! *didsomething* #t)
	    (for-each (lambda (path)
			(print path))
		      paths)))
	;; else do a general-run-call
	(general-run-call 
	 "-test-paths"
	 "Get paths to tests"

	 (lambda (target runname keys keyvals)
	   (let* ((db       #f)
		  ;; DO NOT run remote
		  (paths    (db:test-get-paths-matching db keys target)))
	     (for-each (lambda (path)
			 (print path))
		       paths))))))

;;======================================================================
;; 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 ((db         #f)
	     (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 "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvals: " keyvals)
	 (cdb:remote-run db:extract-ods-file db outputfile keyvals (if runspatt runspatt "%") pathmod)))))



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







|
<







<





<
<








|

|











|









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










|





|
>
>







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
;; 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"))
	       (toppath   (assoc/default 'toppath   cmdinfo)))
	  (change-directory toppath)


	  (if (not target)
	      (begin
		(debug:print 0 "ERROR: -target is required.")
		(exit 1)))
	  (if (not (launch:setup-for-run))
	      (begin
		(debug:print 0 "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)
			(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 (args:get-arg "-archive")


































    ;; else do a general-run-call
    (general-run-call 
     "-archive"

     "Archive"
     (lambda (target runname keys keyvals)





       (operate-on 'archive))))

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

(define (megatest:step step state status logfile msg)
  (if (not (getenv "MT_CMDINFO"))
      (begin
	(debug:print 0 "ERROR: MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!")
	(exit 5))
      (let* ((cmdinfo   (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO")))))
	     ;; (runremote (assoc/default 'runremote 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)
	;; (set! *runremote* runremote)
	;; The transport is handled earlier in the loading process of megatest.
	;; (set! *transport-type* (string->symbol transport))
	(if (not (launch:setup-for-run))
	    (begin
	      (debug:print 0 "Failed to setup, exiting")
	      (exit 1)))
	(if (and state status)
	    ;; DO NOT remote run, makes calls to the testdat.db test db.
	    (db:teststep-set-status! db test-id step state status msg logfile work-area: work-area)
	    (begin
	      (debug:print 0 "ERROR: You must specify :state and :status with every call to -step")
	      (exit 6))))))

(if (args:get-arg "-step")
    (begin
      (megatest:step 
       (args:get-arg "-step")
       (args:get-arg ":state")
       (args:get-arg ":status")
       (args:get-arg "-setlog")
       (args:get-arg "-m"))
      ;; (if db (sqlite3:finalize! db))
      (set! *didsomething* #t)))
    
(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 0 "ERROR: 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   (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO")))))
	       ;; (runremote (assoc/default 'runremote 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")))
	  ;; (set! *runremote* runremote)
	  ;; (set! *transport-type* (string->symbol transport))
	  (if (not (launch:setup-for-run))
	      (begin
		(debug:print 0 "Failed to setup, exiting")
		(exit 1)))

	  (if (args:get-arg "-runstep")(debug:print-info 1 "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 cdb:remote-run or open-run-close
	      (db:load-test-data db test-id work-area: work-area))
	  (if (args:get-arg "-setlog")
	      (let ((logfname (args:get-arg "-setlog")))
		(cdb:test-set-log! *runremote* test-id logfname)))
	  (if (args:get-arg "-set-toplog")
	      ;; DO NOT run remote
	      (tests:test-set-toplog! db run-id test-name (args:get-arg "-set-toplog")))
	  (if (args:get-arg "-summarize-items")
	      ;; DO NOT run remote
	      (tests:summarize-items db run-id test-id test-name #t)) ;; do force here
	  (if (args:get-arg "-runstep")
	      (if (null? remargs)
		  (begin
		    (debug:print 0 "ERROR: nothing specified to run!")
		    (if db (sqlite3:finalize! db))
		    (exit 6))
		  (let* ((stepname   (args:get-arg "-runstep"))







|
<











<
<
<





<
|








|
|



















|
<












<
<













|


|


|


|







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

(define (megatest:step step state status logfile msg)
  (if (not (getenv "MT_CMDINFO"))
      (begin
	(debug:print 0 "ERROR: 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-for-run))
	    (begin
	      (debug:print 0 "Failed to setup, exiting")
	      (exit 1)))
	(if (and state status)

	    (rmt:teststep-set-status! run-id test-id step state status msg logfile)
	    (begin
	      (debug:print 0 "ERROR: You must specify :state and :status with every call to -step")
	      (exit 6))))))

(if (args:get-arg "-step")
    (begin
      (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)))
    
(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 0 "ERROR: 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")))


	  (if (not (launch:setup-for-run))
	      (begin
		(debug:print 0 "Failed to setup, exiting")
		(exit 1)))

	  (if (args:get-arg "-runstep")(debug:print-info 1 "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 cdb:remote-run 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 0 "ERROR: nothing specified to run!")
		    (if db (sqlite3:finalize! db))
		    (exit 6))
		  (let* ((stepname   (args:get-arg "-runstep"))
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
				       ((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
		    ;; DO NOT run remote
		    (db:teststep-set-status! db test-id stepname "start" "n/a" (args:get-arg "-m") logfile work-area: work-area)
		    ;; run the test step
		    (debug:print-info 2 "Running \"" fullcmd "\" in directory \"" startingdir)
		    (change-directory startingdir)
		    (set! exitstat (system fullcmd)) ;; cmd params))
		    (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 "running \"" cmd "\"")
			  (change-directory startingdir)
			  (set! exitstat (system cmd))
			  (set! *globalexitstatus* exitstat) ;; no necessary
			  (change-directory testpath)
			  (cdb:test-set-log! *runremote* test-id htmllogfile)))
		    (let ((msg (args:get-arg "-m")))
		      ;; DO NOT run remote
		      (db:teststep-set-status! db test-id stepname "end" exitstat msg logfile work-area: work-area))
		    )))
	  (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"))







<
|



|












|

<
|







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
				       ((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 "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 "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"))
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
					   (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 0 "ERROR: You must specify :state and :status with every call to -test-status\n" help)
		      ;; (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! test-id state newstatus msg otherdata work-area: work-area))))
	  (if 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-for-run))
	  (begin
	    (debug:print 0 "Failed to setup, exiting")
	    (exit 1)))
      (set! keys (cdb:remote-run db:get-keys db))
      (debug:print 1 "Keys: " (string-intersperse keys ", "))
      (if db (sqlite3:finalize! db))
      (set! *didsomething* #t)))

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







|




|
|
















|







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
					   (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 0 "ERROR: 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-for-run))
	  (begin
	    (debug:print 0 "Failed to setup, exiting")
	    (exit 1)))
      (set! keys (cdb:remote-run db:get-keys db))
      (debug:print 1 "Keys: " (string-intersperse keys ", "))
      (if (sqlite3:database? db)(sqlite3:finalize! db))
      (set! *didsomething* #t)))

(if (args:get-arg "-gui")
    (begin
      (debug:print 0 "Look at the dashboard for now")
      ;; (megatest-gui)
      (set! *didsomething* #t)))
1187
1188
1189
1190
1191
1192
1193
1194









1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
(if (args:get-arg "-cleanup-db")
    (begin
      (if (not (launch:setup-for-run))
	  (begin
	    (debug:print 0 "Failed to setup, exiting") 
	    (exit 1)))
      ;; keep this one local
      (open-run-close db:clean-up #f)









      (set! *didsomething* #t)))

(if (args:get-arg "-mark-incompletes")
    (begin
      (if (not (launch:setup-for-run))
	  (begin
	    (debug:print 0 "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
;;======================================================================







|
>
>
>
>
>
>
>
>
>






|







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
(if (args:get-arg "-cleanup-db")
    (begin
      (if (not (launch:setup-for-run))
	  (begin
	    (debug:print 0 "Failed to setup, exiting") 
	    (exit 1)))
      ;; keep this one local
      ;; (open-run-close db:clean-up #f)
      (db:multi-db-sync 
       #f ;; do all run-ids
       ;; 'new2old
       'killservers
       'dejunk
       ;; 'adj-testids
       ;; 'old2new
       'new2old
       )
      (set! *didsomething* #t)))

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

;;======================================================================
;; Update the tests meta data from the testconfig files
;;======================================================================
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
      (open-run-close runs:update-all-test_meta #f)
      (set! *didsomething* #t)))

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




(if (or (args:get-arg "-repl")
	(args:get-arg "-load"))
    (let* ((toppath (launch:setup-for-run))
	   (db      (if toppath (open-db) #f)))
      (if db
	  (begin
	    (set! *db* db)
	    (set! *client-non-blocking-mode* #t)


	    (import readline)
	    (import apropos)

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

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

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

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


















































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

(if *runremote* (close-all-connections!))

;; this is the socket if we are a client
;; (if (and *runremote*
;; 	 (socket? *runremote*))
;;     (close-socket *runremote*))

(if (not *didsomething*)
    (debug:print 0 help))

;; (if *runremote* (rpc:close-all-connections!))

    
(if (not (eq? *globalexitstatus* 0))
    (if (or (args:get-arg "-runtests")(args:get-arg "-runall"))
        (begin
           (debug:print 0 "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)))))







>
>
>



|
|

|

>
>


>






|
>
















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







<
<
<
<
<



|
>
|










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
      (open-run-close runs:update-all-test_meta #f)
      (set! *didsomething* #t)))

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

;; fakeout readline
(define (toplevel-command . a) #f)

(if (or (args:get-arg "-repl")
	(args:get-arg "-load"))
    (let* ((toppath (launch:setup-for-run))
	   (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)))
      (if dbstruct
	  (begin
	    (set! *db* dbstruct)
	    (set! *client-non-blocking-mode* #t)
	    (import extras) ;; might not be needed
	    ;; (import csi)
	    (import readline)
	    (import apropos)
	    ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
	    (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))
	  (exit))
      (set! *didsomething* #t)))

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

(if (and (args:get-arg "-run-wait")
	 (not (args:get-arg "-runtests"))) ;; run-wait is built into runtests now
    (begin
      (if (not (launch:setup-for-run))
	  (begin
	    (debug:print 0 "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 "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 "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 "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 
       #f ;; do all run-ids
       'killservers
       'dejunk
       'adj-testids
       'old2new
       ;; 'new2old
       )
      (set! *didsomething* #t)))

(if (args:get-arg "-sync-to-megatest.db")
    (begin
      (db:multi-db-sync 
       #f ;; do all run-ids
       'new2old
       )
      (set! *didsomething* #t)))

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

(if *runremote* (close-all-connections!))






(if (not *didsomething*)
    (debug:print 0 help))

(set! *time-to-exit* #t)
(thread-join! *watchdog*)

(if (not (eq? *globalexitstatus* 0))
    (if (or (args:get-arg "-runtests")(args:get-arg "-runall"))
        (begin
           (debug:print 0 "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)))))

Added mlaunch.scm version [4f4e7034c8].





















































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
;; Copyright 2006-2014, 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.

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

;;======================================================================
;; MLAUNCH
;;
;;   take jobs from the given queue and keep launching them keeping
;;   the cpu load at the targeted level
;;
;;======================================================================

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

(declare (unit mlaunch))
(declare (uses db))
(declare (uses common))

Modified mt.scm from [bbcabbe252] to [15956fcc00].

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
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
(declare (uses server))
(declare (uses runs))



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

;; runs:get-runs-by-patt
;; get runs by list of criteria
;; register a test run with the db
;;
;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo))
;;  to extract info from the structure returned
;;
(define (mt:get-runs-by-patt keys runnamepatt targpatt)
  (let loop ((runsdat  (cdb:remote-run db:get-runs-by-patt #f keys runnamepatt targpatt 0 500))
	     (res      '())
	     (offset   0)
	     (limit    500))
    ;; (print "runsdat: " runsdat)
    (let* ((header    (vector-ref runsdat 0))
	   (runslst   (vector-ref runsdat 1))
	   (full-list (append res runslst))
	   (have-more (eq? (length runslst) limit)))
      ;; (debug:print 0 "header: " header " runslst: " runslst " have-more: " have-more)
      (if have-more 
	  (let ((new-offset (+ offset limit))
		(next-batch (cdb:remote-run db:get-runs-by-patt #f keys runnamepatt targpatt offset limit)))
	    (debug:print-info 4 "More than " limit " runs, have " (length full-list) " runs so far.")
	    (debug:print-info 0 "next-batch: " next-batch)
	    (loop next-batch
		  full-list
		  new-offset
		  limit))
	 (vector header full-list)))))

;;======================================================================
;;  T E S T S
;;======================================================================

(define (mt:get-tests-for-run run-id testpatt states status #!key (not-in #t) (sort-by 'event_time) (sort-order "ASC") (qryvals #f))
  (let loop ((testsdat (cdb:remote-run db:get-tests-for-run #f run-id testpatt states status 0 500 not-in sort-by sort-order qryvals: qryvals))
	     (res      '())
	     (offset   0)
	     (limit    500))
    (let* ((full-list (append res testsdat))
	   (have-more (eq? (length testsdat) limit)))
      (if have-more 
	  (let ((new-offset (+ offset limit)))
	    (debug:print-info 4 "More than " limit " tests, have " (length full-list) " tests so far.")
	    (loop (cdb:remote-run db:get-tests-for-run #f run-id testpatt states status new-offset limit not-in sort-by sort-order qryvals: qryvals)
		  full-list
		  new-offset
		  limit))
	  full-list))))

(define (mt:get-prereqs-not-met run-id waitons ref-item-path #!key (mode '(normal))(itemmap #f))
  (db:get-prereqs-not-met run-id waitons ref-item-path mode: mode itemmap: itemmap))

(define (mt:lazy-get-prereqs-not-met run-id waitons ref-item-path #!key (mode '(normal))(itemmap #f) )
  (let* ((key    (list run-id waitons ref-item-path mode))
	 (res    (hash-table-ref/default *pre-reqs-met-cache* key #f))
	 (useres (let ((last-time (if (vector? res) (vector-ref res 0) #f)))
		   (if last-time
		       (< (current-seconds)(+ last-time 5))
		       #f))))
    (if useres
	(let ((result (vector-ref res 1)))
	  (debug:print 4 "Using lazy value res: " result)
	  result)

	(let ((newres (db:get-prereqs-not-met run-id waitons ref-item-path mode: mode itemmap: itemmap)))
	  (hash-table-set! *pre-reqs-met-cache* key (vector (current-seconds) newres))
	  newres))))

(define (mt:get-run-stats)

  (cdb:remote-run db:get-run-stats #f))

(define (mt:discard-blocked-tests run-id failed-test tests test-records)
  (if (null? tests)
      tests
      (begin
	(debug:print-info 1 "Discarding tests from " tests " that are waiting on " failed-test)
	(let loop ((testn (car tests))







>
>


















|



|











|













|








|





<
<
<











>
|



|
>
|







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

;; runs:get-runs-by-patt
;; get runs by list of criteria
;; register a test run with the db
;;
;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
;;  to extract info from the structure returned
;;
(define (mt:get-runs-by-patt keys runnamepatt targpatt)
  (let loop ((runsdat  (rmt:get-runs-by-patt keys runnamepatt targpatt 0 500))
	     (res      '())
	     (offset   0)
	     (limit    500))
    ;; (print "runsdat: " runsdat)
    (let* ((header    (vector-ref runsdat 0))
	   (runslst   (vector-ref runsdat 1))
	   (full-list (append res runslst))
	   (have-more (eq? (length runslst) limit)))
      ;; (debug:print 0 "header: " header " runslst: " runslst " have-more: " have-more)
      (if have-more 
	  (let ((new-offset (+ offset limit))
		(next-batch (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit)))
	    (debug:print-info 4 "More than " limit " runs, have " (length full-list) " runs so far.")
	    (debug:print-info 0 "next-batch: " next-batch)
	    (loop next-batch
		  full-list
		  new-offset
		  limit))
	 (vector header full-list)))))

;;======================================================================
;;  T E S T S
;;======================================================================

(define (mt:get-tests-for-run run-id testpatt states status #!key (not-in #t) (sort-by 'event_time) (sort-order "ASC") (qryvals #f))
  (let loop ((testsdat (rmt:get-tests-for-run run-id testpatt states status 0 500 not-in sort-by sort-order qryvals))
	     (res      '())
	     (offset   0)
	     (limit    500))
    (let* ((full-list (append res testsdat))
	   (have-more (eq? (length testsdat) limit)))
      (if have-more 
	  (let ((new-offset (+ offset limit)))
	    (debug:print-info 4 "More than " limit " tests, have " (length full-list) " tests so far.")
	    (loop (rmt:get-tests-for-run run-id testpatt states status new-offset limit not-in sort-by sort-order qryvals)
		  full-list
		  new-offset
		  limit))
	  full-list))))




(define (mt:lazy-get-prereqs-not-met run-id waitons ref-item-path #!key (mode '(normal))(itemmap #f) )
  (let* ((key    (list run-id waitons ref-item-path mode))
	 (res    (hash-table-ref/default *pre-reqs-met-cache* key #f))
	 (useres (let ((last-time (if (vector? res) (vector-ref res 0) #f)))
		   (if last-time
		       (< (current-seconds)(+ last-time 5))
		       #f))))
    (if useres
	(let ((result (vector-ref res 1)))
	  (debug:print 4 "Using lazy value res: " result)
	  result)
	(let ((newres (rmt:get-prereqs-not-met run-id waitons ref-item-path mode: mode itemmap: itemmap)))
;;	(let ((newres (db:get-prereqs-not-met run-id waitons ref-item-path mode: mode itemmap: itemmap)))
	  (hash-table-set! *pre-reqs-met-cache* key (vector (current-seconds) newres))
	  newres))))

(define (mt:get-run-stats dbstruct run-id)
;;  Get run stats from local access, move this ... but where?
  (db:get-run-stats dbstruct run-id))

(define (mt:discard-blocked-tests run-id failed-test tests test-records)
  (if (null? tests)
      tests
      (begin
	(debug:print-info 1 "Discarding tests from " tests " that are waiting on " failed-test)
	(let loop ((testn (car tests))
126
127
128
129
130
131
132
133
134

135
136
137
138
139

140
141
142
143
144
145
146
147
			    res)
			  (cons testn res)))))))))

;;======================================================================
;;  T R I G G E R S
;;======================================================================

(define (mt:process-triggers test-id newstate newstatus)
  (let* ((test-dat      (mt:lazy-get-test-info-by-id test-id))

	 (test-rundir   (db:test-get-rundir test-dat))
	 (test-name     (db:test-get-testname test-dat))
	 (tconfig       #f)
	 (state         (if newstate  newstate  (db:test-get-state  test-dat)))
	 (status        (if newstatus newstatus (db:test-get-status test-dat))))

    (if (and (file-exists? test-rundir)
	     (directory? test-rundir))
	(begin
	  (push-directory test-rundir)
	  (set! tconfig (mt:lazy-read-test-config test-name))
	  (pop-directory)
	  (for-each (lambda (trigger)
		      (let ((cmd  (configf:lookup tconfig "triggers" trigger))







|
|
>
|




>
|







127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
			    res)
			  (cons testn res)))))))))

;;======================================================================
;;  T R I G G E R S
;;======================================================================

(define (mt:process-triggers run-id test-id newstate newstatus)
  (let* ((test-dat      (rmt:get-test-info-by-id run-id test-id))
	 (test-rundir   ;; (rmt:sdb-qry 'getstr ;; (filedb:get-path *fdb*
	  (db:test-get-rundir test-dat)) ;; ) ;; )
	 (test-name     (db:test-get-testname test-dat))
	 (tconfig       #f)
	 (state         (if newstate  newstate  (db:test-get-state  test-dat)))
	 (status        (if newstatus newstatus (db:test-get-status test-dat))))
    (if (and test-rundir   ;; #f means no dir set yet
	     (file-exists? test-rundir)
	     (directory? test-rundir))
	(begin
	  (push-directory test-rundir)
	  (set! tconfig (mt:lazy-read-test-config test-name))
	  (pop-directory)
	  (for-each (lambda (trigger)
		      (let ((cmd  (configf:lookup tconfig "triggers" trigger))
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
		     (conc state "/")
		     (conc "/" status)))))))

;;======================================================================
;;  S T A T E   A N D   S T A T U S   F O R   T E S T S 
;;======================================================================


(define (mt:roll-up-pass-fail-counts run-id test-name item-path status)
  (if (and (not (equal? item-path ""))
	   (member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK" "SKIP")))
      (begin
	(cdb:update-pass-fail-counts *runremote* run-id test-name)
	(if (equal? status "RUNNING")
	    (cdb:top-test-set-running *runremote* run-id test-name)
	    (cdb:top-test-set-per-pf-counts *runremote* run-id test-name))
	#f)
      #f))

;; speed up for common cases with a little logic
(define (mt:test-set-state-status-by-id test-id newstate newstatus newcomment)
  (cond
   ((and newstate newstatus newcomment)
    (cdb:client-call *runremote* 'state-status-msg #t *default-numtries* newstate newstatus newcomment test-id))
   ((and newstate newstatus)
    (cdb:client-call *runremote* 'state-status #t *default-numtries* newstate newstatus test-id))
   (else
    (if newstate   (cdb:client-call *runremote* 'set-test-state #t *default-numtries* newstate test-id))
    (if newstatus  (cdb:client-call *runremote* 'set-test-status #t *default-numtries* newstatus test-id))
    (if newcomment (cdb:client-call *runremote* 'set-test-comment #t *default-numtries* newcomment test-id))))
   (mt:process-triggers test-id newstate newstatus)
   #t)

(define (mt:test-set-state-status-by-testname run-id test-name item-path new-state new-status new-comment)
  (let ((test-id (cdb:remote-run db:get-test-id-cached #f run-id test-name item-path)))
    (mt:test-set-state-status-by-id test-id new-state new-status new-comment)))

(define (mt:lazy-get-test-info-by-id test-id)
  (let* ((tdat (hash-table-ref/default *test-info* test-id #f)))
    (if (and tdat 
	     (< (current-seconds)(+ (vector-ref tdat 0) 10)))
	(vector-ref tdat 1)
	;; no need to update *test-info* as that is done in cdb:get-test-info-by-id
	(cdb:get-test-info-by-id *runremote* test-id))))

(define (mt:lazy-read-test-config test-name)
  (let ((tconf (hash-table-ref/default *testconfigs* test-name #f)))
    (if tconf
	tconf
	(let ((test-dirs (tests:get-tests-search-path *configdat*)))
	  (let loop ((hed (car test-dirs))
		     (tal (cdr test-dirs)))







>
|
|
<

|
|
<
<

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





<
<
<
<
<
<
<
<







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
		     (conc state "/")
		     (conc "/" status)))))))

;;======================================================================
;;  S T A T E   A N D   S T A T U S   F O R   T E S T S 
;;======================================================================

;; speed up for common cases with a little logic
(define (mt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment)
  (if (not (and run-id test-id))

      (begin
	(debug:print 0 "ERROR: bad data handed to mt:test-set-state-status-by-id, run-id=" run-id ", test-id=" test-id ", newstate=" newstate)
	(print-call-chain (current-error-port))


	#f)

      (begin


	(cond
	 ((and newstate newstatus newcomment)
	  (rmt:general-call 'state-status-msg run-id newstate newstatus newcomment test-id))
	 ((and newstate newstatus)
	  (rmt:general-call 'state-status run-id newstate newstatus test-id))
	 (else
	  (if newstate   (rmt:general-call 'set-test-state   run-id newstate   test-id))
	  (if newstatus  (rmt:general-call 'set-test-status  run-id newstatus  test-id))
	  (if newcomment (rmt:general-call 'set-test-comment run-id newcomment test-id))))
	(mt:process-triggers run-id test-id newstate newstatus)
	#t)))

(define (mt:test-set-state-status-by-testname run-id test-name item-path new-state new-status new-comment)
  (let ((test-id (cdb:remote-run db:get-test-id-cached #f run-id test-name item-path)))
    (mt:test-set-state-status-by-id test-id new-state new-status new-comment)))









(define (mt:lazy-read-test-config test-name)
  (let ((tconf (hash-table-ref/default *testconfigs* test-name #f)))
    (if tconf
	tconf
	(let ((test-dirs (tests:get-tests-search-path *configdat*)))
	  (let loop ((hed (car test-dirs))
		     (tal (cdr test-dirs)))

Modified newdashboard.scm from [9e84c96b6c] to [8ecdd4ecf2].

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
;;======================================================================
;; Copyright 2006-2013, 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.
;;======================================================================

(use format)
(require-library iup)
(import (prefix iup iup:))
(use canvas-draw)

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












|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
;;======================================================================
;; Copyright 2006-2013, 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.
;;======================================================================

(use format numbers)
(require-library iup)
(import (prefix iup iup:))
(use canvas-draw)

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

70
71
72
73
74
75
76
77
78
79
80
81
82












83
84
85
86
87
88
89
      (exit)))

(if (not (launch:setup-for-run))
    (begin
      (print "Failed to find megatest.config, exiting") 
      (exit 1)))

(if (args:get-arg "-host")
    (begin
      (set! *runremote* (string-split (args:get-arg "-host" ":")))
      (client:launch))
    (client:launch))














(debug:setup)

(define *tim* (iup:timer))
(define *ord* #f)

(iup:attribute-set! *tim* "TIME" 300)







|
|
|
|
|

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







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

(if (not (launch:setup-for-run))
    (begin
      (print "Failed to find megatest.config, exiting") 
      (exit 1)))

;; (if (args:get-arg "-host")
;;     (begin
;;       (set! *runremote* (string-split (args:get-arg "-host" ":")))
;;       (client:launch))
;;     (client:launch))

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

(define *dbdir* (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
(define *dbstruct-local*  (make-dbr:dbstruct path:  *dbdir*
					     local: #t))
(define *db-file-path* (db:dbfile-path 0))

;; HACK ALERT: this is a hack, please fix.
(define *read-only* (not (file-read-access? *db-file-path*)))

(debug:setup)

(define *tim* (iup:timer))
(define *ord* #f)

(iup:attribute-set! *tim* "TIME" 300)
265
266
267
268
269
270
271
272
273



274
275
276
277
278
279
280
281
282
		       (if (directory-exists? rundir)
			   (let ((shell (if (get-environment-variable "SHELL") 
					    (conc "-e " (get-environment-variable "SHELL"))
					    "")))
			     (system (conc "cd " rundir 
					   ";xterm -T \"" (string-translate testfullname "()" "  ") "\" " shell "&")))
			   (message-window  (conc "Directory " rundir " not found")))))
	 (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -10"))
	 (command-launch-button (iup:button "Execute!" #:action (lambda (x)



								  (let ((cmd (iup:attribute command-text-box "VALUE")))
								    (system (conc cmd "  &"))))))
	 (run-test  (lambda (x)
		      (iup:attribute-set! 
		       command-text-box "VALUE"
		       (conc "xterm -geometry 180x20 -e \"megatest -target " keystring " :runname " runname 
			     " -runtests " (conc testname "/" (if (equal? item-path "")
								  "%" 
								  item-path))







|
|
>
>
>
|
|







277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
		       (if (directory-exists? rundir)
			   (let ((shell (if (get-environment-variable "SHELL") 
					    (conc "-e " (get-environment-variable "SHELL"))
					    "")))
			     (system (conc "cd " rundir 
					   ";xterm -T \"" (string-translate testfullname "()" "  ") "\" " shell "&")))
			   (message-window  (conc "Directory " rundir " not found")))))
	 (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -12"))
	 (command-launch-button (iup:button "Execute!" 
					    ;; #:expand "HORIZONTAL"
					    #:size "50x"
					    #:action (lambda (x)
						       (let ((cmd (iup:attribute command-text-box "VALUE")))
							 (system (conc cmd "  &"))))))
	 (run-test  (lambda (x)
		      (iup:attribute-set! 
		       command-text-box "VALUE"
		       (conc "xterm -geometry 180x20 -e \"megatest -target " keystring " :runname " runname 
			     " -runtests " (conc testname "/" (if (equal? item-path "")
								  "%" 
								  item-path))
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
			    #:expand "YES"
			    #:numcol 1
			    #:numlin 5
			    #:numcol-visible 1
			    #:numlin-visible 5))
	 (steps-matrix     (iup:matrix
			    #:expand "YES"
			    #:numcol 5
			    #:numlin 50
			    #:numcol-visible 5
			    #:numlin-visible 8))
	 (data-matrix      (iup:matrix
			    #:expand "YES"
			    #:numcol 8
			    #:numlin 50
			    #:numcol-visible 8
			    #:numlin-visible 8))







|

|







329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
			    #:expand "YES"
			    #:numcol 1
			    #:numlin 5
			    #:numcol-visible 1
			    #:numlin-visible 5))
	 (steps-matrix     (iup:matrix
			    #:expand "YES"
			    #:numcol 6
			    #:numlin 50
			    #:numcol-visible 6
			    #:numlin-visible 8))
	 (data-matrix      (iup:matrix
			    #:expand "YES"
			    #:numcol 8
			    #:numlin 50
			    #:numcol-visible 8
			    #:numlin-visible 8))
345
346
347
348
349
350
351

352
353
354

355
356

357
358
359
360
361
362
363
       ;; (iup:attribute-set! mat "WIDTH1" "120")
       ;; (iup:attribute-set! mat "WIDTH0" "100"))
     (list run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix))

    ;; Steps matrix
    (iup:attribute-set! steps-matrix "0:1" "Step Name")
    (iup:attribute-set! steps-matrix "0:2" "Start")

    (iup:attribute-set! steps-matrix "0:3" "End")
    (iup:attribute-set! steps-matrix "WIDTH3" "50")
    (iup:attribute-set! steps-matrix "0:4" "Status")

    (iup:attribute-set! steps-matrix "WIDTH4" "50")
    (iup:attribute-set! steps-matrix "0:5" "Log File")

    (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT")
    ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1")
    (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES")
    ;; (iup:attribute-set! steps-matrix "WIDTH1" "120")
    ;; (iup:attribute-set! steps-matrix "WIDTH0" "100")

    ;; Data matrix







>

|

>
|
|
>







360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
       ;; (iup:attribute-set! mat "WIDTH1" "120")
       ;; (iup:attribute-set! mat "WIDTH0" "100"))
     (list run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix))

    ;; Steps matrix
    (iup:attribute-set! steps-matrix "0:1" "Step Name")
    (iup:attribute-set! steps-matrix "0:2" "Start")
    (iup:attribute-set! steps-matrix "WIDTH2" "40")
    (iup:attribute-set! steps-matrix "0:3" "End")
    (iup:attribute-set! steps-matrix "WIDTH3" "40")
    (iup:attribute-set! steps-matrix "0:4" "Status")
    (iup:attribute-set! steps-matrix "WIDTH4" "40")
    (iup:attribute-set! steps-matrix "0:5" "Duration")
    (iup:attribute-set! steps-matrix "WIDTH5" "40")
    (iup:attribute-set! steps-matrix "0:6" "Log File")
    (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT")
    ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1")
    (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES")
    ;; (iup:attribute-set! steps-matrix "WIDTH1" "120")
    ;; (iup:attribute-set! steps-matrix "WIDTH0" "100")

    ;; Data matrix
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
	 (iup:attribute-set! mat "REDRAW" "ALL")))
     (list
      (list run-info-matrix  '("Run Id"  "Target"   "Runname" "Run Start Time" ))
      (list test-info-matrix '("Test Id" "Testname" "Itempath" "State"   "Status" "Test Start Time" "Comment"))
      (list test-run-matrix  '("Hostname" "Host info" "Disk Free" "CPU Load" "Run Duration"))
      (list meta-dat-matrix  '("Author"   "Owner"     "Last Reviewed" "Tags" "Description"))))
	    


    (iup:vbox
     (iup:hbox

      run-info-matrix
      test-info-matrix)

     (iup:hbox
      test-run-matrix
      meta-dat-matrix)
     (iup:vbox
      (iup:vbox
       (iup:hbox 
	(iup:button "View Log"    #:action viewlog     #:size "80x")
	(iup:button "Start Xterm" #:action xterm       #:size "80x")

	(iup:button "Run Test"    #:action run-test    #:size "80x")
	(iup:button "Clean Test"  #:action remove-test #:size "80x"))
       (apply 
	iup:hbox




	(list command-text-box command-launch-button))))
     (iup:vbox
      (let ((tabs (iup:tabs
		   steps-matrix
		   data-matrix)))
	(iup:attribute-set! tabs "TABTITLE0" "Test Steps")
	(iup:attribute-set! tabs "TABTITLE1" "Test Data")
	tabs)))))
       
;; Test browser
(define (tests window-id)
  (iup:hbox 
   (let* ((tb      (iup:treebox
		    #:selection-cb
		    (lambda (obj id state)
		      ;; (print "obj: " obj ", id: " id ", state: " state)
		      (let* ((run-path (tree:node->path obj id))
			     (test-id  (tree-path->test-id (cdr run-path))))
			(if test-id







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



|







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
	 (iup:attribute-set! mat "REDRAW" "ALL")))
     (list
      (list run-info-matrix  '("Run Id"  "Target"   "Runname" "Run Start Time" ))
      (list test-info-matrix '("Test Id" "Testname" "Itempath" "State"   "Status" "Test Start Time" "Comment"))
      (list test-run-matrix  '("Hostname" "Host info" "Disk Free" "CPU Load" "Run Duration"))
      (list meta-dat-matrix  '("Author"   "Owner"     "Last Reviewed" "Tags" "Description"))))
	    
    (iup:split
      #:orientation "HORIZONTAL"
      (iup:vbox
       (iup:hbox
	(iup:vbox
	 run-info-matrix
	 test-info-matrix)
       ;; test-info-matrix)
	(iup:vbox
	 test-run-matrix
	 meta-dat-matrix))
       (iup:vbox
	(iup:vbox
	 (iup:hbox 
	  (iup:button "View Log"    #:action viewlog      #:size "60x" )   ;; #:size "30x" 
	  (iup:button "Start Xterm" #:action xterm        #:size "60x" ))	 ;; #:size "30x" 
	 (iup:hbox
	   (iup:button "Run Test"    #:action run-test    #:size "60x" )	 ;; #:size "30x" 
	   (iup:button "Clean Test"  #:action remove-test #:size "60x" )))	 ;; #:size "30x" 

	(iup:hbox
	 ;; hiup:split ;; hbox
	 ;; #:orientation "HORIZONTAL"
	 ;; #:value 300
	 command-text-box
	 command-launch-button)))
      (iup:vbox
       (let ((tabs (iup:tabs
		    steps-matrix
		    data-matrix)))
	 (iup:attribute-set! tabs "TABTITLE0" "Test Steps")
	 (iup:attribute-set! tabs "TABTITLE1" "Test Data")
	 tabs)))))
       
;; Test browser
(define (tests window-id)
  (iup:split
   (let* ((tb      (iup:treebox
		    #:selection-cb
		    (lambda (obj id state)
		      ;; (print "obj: " obj ", id: " id ", state: " state)
		      (let* ((run-path (tree:node->path obj id))
			     (test-id  (tree-path->test-id (cdr run-path))))
			(if test-id
436
437
438
439
440
441
442

443

444
445
446


447
448
449
450
451
452
453
;; The function to update the fields in the test view panel
(define (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix)
  ;; get test-id
  ;; then get test record
  (if testdat
      (let* ((test-id      (hash-table-ref/default (dboard:data-get-curr-test-ids *data*) window-id #f))
	     (test-data    (hash-table-ref/default testdat test-id #f))

	     (targ/runname (hash-table-ref/default (dboard:data-get-run-keys *data*) 

						   (db:test-get-run_id test-data) '()))
	     (target       (if (null? targ/runname) "" (string-intersperse (reverse (cdr (reverse targ/runname))) "/")))
	     (runname      (if (null? targ/runname) "" (car (cdr targ/runname)))))


	(if test-data
	    (begin
	      ;; 
	      (for-each 
	       (lambda (data)
		 (let ((mat    (car data))
		       (vals   (cadr data))







>

>
|

|
>
>







462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
;; The function to update the fields in the test view panel
(define (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix)
  ;; get test-id
  ;; then get test record
  (if testdat
      (let* ((test-id      (hash-table-ref/default (dboard:data-get-curr-test-ids *data*) window-id #f))
	     (test-data    (hash-table-ref/default testdat test-id #f))
	     (run-id       (db:test-get-run_id test-data))
	     (targ/runname (hash-table-ref/default (dboard:data-get-run-keys *data*) 
						   run-id
						   '()))
	     (target       (if (null? targ/runname) "" (string-intersperse (reverse (cdr (reverse targ/runname))) "/")))
	     (runname      (if (null? targ/runname) "" (car (cdr targ/runname))))
	     (steps-dat    (tests:get-compressed-steps *dbstruct-local* run-id test-id)))
				
	(if test-data
	    (begin
	      ;; 
	      (for-each 
	       (lambda (data)
		 (let ((mat    (car data))
		       (vals   (cadr data))
484
485
486
487
488
489
490


491
492
493
494
495
496
497
498
499
500
501
		      (if test-id
			  (list (db:test-get-host     test-data)
				(db:test-get-uname    test-data)
				(db:test-get-diskfree test-data)
				(db:test-get-cpuload  test-data)
				(seconds->hr-min-sec (db:test-get-run_duration test-data)))
			  (make-list 5 "")))


		;;(list meta-dat-matrix
		;;      (if test-id
		;;	  (list (
		)))))))

  
;; db:test-get-id           
;; db:test-get-run_id       
;; db:test-get-testname     
;; db:test-get-state        
;; db:test-get-status       







>
>



<







514
515
516
517
518
519
520
521
522
523
524
525

526
527
528
529
530
531
532
		      (if test-id
			  (list (db:test-get-host     test-data)
				(db:test-get-uname    test-data)
				(db:test-get-diskfree test-data)
				(db:test-get-cpuload  test-data)
				(seconds->hr-min-sec (db:test-get-run_duration test-data)))
			  (make-list 5 "")))
		))
	      (dcommon:populate-steps steps-dat steps-matrix))))))
		;;(list meta-dat-matrix
		;;      (if test-id
		;;	  (list (


  
;; db:test-get-id           
;; db:test-get-run_id       
;; db:test-get-testname     
;; db:test-get-state        
;; db:test-get-status       
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
;;======================================================================

;; Main Panel
(define (main-panel window-id)
  (iup:dialog
   #:title "Megatest Control Panel"
   #:menu (dcommon:main-menu)

   (let ((tabtop (iup:tabs 
		  (runs window-id)
		  (tests window-id)
		  (runcontrol window-id)
		  (mtest window-id) 
		  (rconfig window-id)
		  )))
     (iup:attribute-set! tabtop "TABTITLE0" "Runs")
     (iup:attribute-set! tabtop "TABTITLE1" "Tests")
     (iup:attribute-set! tabtop "TABTITLE2" "Run Control")
     (iup:attribute-set! tabtop "TABTITLE3" "megatest.config") 
     (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config")
     tabtop)))

(define *current-window-id* 0)

(define (newdashboard)
  (let* ((data     (make-hash-table))
	 (keys     (cdb:remote-run db:get-keys #f))
	 (runname  "%")
	 (testpatt "%")
	 (keypatts (map (lambda (k)(list k "%")) keys))
	 (states   '())
	 (statuses '())
	 (nextmintime (current-milliseconds))
	 (my-window-id *current-window-id*))
    (set! *current-window-id* (+ 1 *current-window-id*))
    (dboard:data-set-runs! *data* data) ;; make this data available to the rest of the application
    (iup:show (main-panel my-window-id))
    ;; Yes, running iup:show will pop up a new panel
    ;; (iup:show (main-panel my-window-id))
    (iup:callback-set! *tim*
		       "ACTION_CB"
		       (lambda (x)
			 ;; Want to dedicate no more than 50% of the time to this so skip if
			 ;; 2x delta time has not passed since last query
			 (if (< nextmintime (current-milliseconds))
			     (let* ((starttime (current-milliseconds))
				    (changes   (run-update keys data runname keypatts testpatt states statuses 'full my-window-id))
				    (endtime   (current-milliseconds)))
			       (set! nextmintime (+ endtime (* 2 (- endtime starttime))))
			       (debug:print 11 "CHANGE(S): " (car changes) "..."))
			     (debug:print-info 11 "Server overloaded"))))))


(newdashboard)    
(iup:main-loop)







>
















|

|



















|





>
|

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

;; Main Panel
(define (main-panel window-id)
  (iup:dialog
   #:title "Megatest Control Panel"
   #:menu (dcommon:main-menu)
   #:shrink "YES"
   (let ((tabtop (iup:tabs 
		  (runs window-id)
		  (tests window-id)
		  (runcontrol window-id)
		  (mtest window-id) 
		  (rconfig window-id)
		  )))
     (iup:attribute-set! tabtop "TABTITLE0" "Runs")
     (iup:attribute-set! tabtop "TABTITLE1" "Tests")
     (iup:attribute-set! tabtop "TABTITLE2" "Run Control")
     (iup:attribute-set! tabtop "TABTITLE3" "megatest.config") 
     (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config")
     tabtop)))

(define *current-window-id* 0)

(define (newdashboard dbstruct)
  (let* ((data     (make-hash-table))
	 (keys     (db:get-keys dbstruct))
	 (runname  "%")
	 (testpatt "%")
	 (keypatts (map (lambda (k)(list k "%")) keys))
	 (states   '())
	 (statuses '())
	 (nextmintime (current-milliseconds))
	 (my-window-id *current-window-id*))
    (set! *current-window-id* (+ 1 *current-window-id*))
    (dboard:data-set-runs! *data* data) ;; make this data available to the rest of the application
    (iup:show (main-panel my-window-id))
    ;; Yes, running iup:show will pop up a new panel
    ;; (iup:show (main-panel my-window-id))
    (iup:callback-set! *tim*
		       "ACTION_CB"
		       (lambda (x)
			 ;; Want to dedicate no more than 50% of the time to this so skip if
			 ;; 2x delta time has not passed since last query
			 (if (< nextmintime (current-milliseconds))
			     (let* ((starttime (current-milliseconds))
				    (changes   (dcommon:run-update keys data runname keypatts testpatt states statuses 'full my-window-id))
				    (endtime   (current-milliseconds)))
			       (set! nextmintime (+ endtime (* 2 (- endtime starttime))))
			       (debug:print 11 "CHANGE(S): " (car changes) "..."))
			     (debug:print-info 11 "Server overloaded"))))))

(dboard:data-set-updaters! *data* (make-hash-table))
(newdashboard *dbstruct-local*)    
(iup:main-loop)

Added nmsg-transport.scm version [c28712df60].













































































































































































































































































































































































































































































































































































































































































































































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

;; Copyright 2006-2012, 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.

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

(declare (unit nmsg-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))

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

;; Transition to pub --> sub with pull <-- push
;;
;;   1. client sends request to server via push to the pull port
;;   2. server puts request in queue or processes immediately as appropriate
;;   3. server puts responses from completed requests into pub port 
;;
;; TODO
;;
;; Done Tested
;; [x]  [ ]    1. Add columns pullport pubport to servers table
;; [x]  [ ]    2. Add rm of monitor.db if older than 11/12/2012 
;; [x]  [ ]    3. Add create of pullport and pubport with finding of available ports
;; [x]  [ ]    4. Add client compose of request
;; [x]  [ ]        - name of client: testname/itempath-test_id-hostname 
;; [x]  [ ]        - name of request: callname, params
;; [x]  [ ]        - request key: f(clientname, callname, params)
;; [x]  [ ]    5. Add processing of subscription hits
;; [x]  [ ]        - done when get key 
;; [x]  [ ]        - return results
;; [x]  [ ]    6. Add timeout processing
;; [x]  [ ]        - after 60 seconds
;; [ ]  [ ]            i. check server alive, connect to new if necessary
;; [ ]  [ ]           ii. resend request
;; [ ]  [ ]    7. Turn self ping back on

(define (nmsg-transport:make-server-url hostport #!key (bindall #f))
  (if (not hostport)
      #f
      (conc "tcp://" (if bindall "*" (car hostport)) ":" (cadr hostport))))

(define *server-loop-heart-beat* (current-seconds))
(define *heartbeat-mutex* (make-mutex))

;;======================================================================
;; S E R V E R
;;======================================================================

(define (nmsg-transport:run dbstruct hostn run-id server-id #!key (retrynum 1000))
  (debug:print 2 "Attempting to start the server ...")
  (let* ((start-port      (portlogger:open-run-close portlogger:find-port))
	 (server-thread   (make-thread (lambda ()
					 (nmsg-transport:try-start-server dbstruct run-id start-port server-id))
				       "server thread"))
	 (tdbdat          (tasks:open-db)))
    (thread-start! server-thread)
    (thread-sleep! 0.1)
    (if (nmsg-transport:ping hostn start-port timeout: 2 expected-key: (current-process-id))
	(let ((interface (if (equal? hostn "-")(get-host-name) hostn)))
	  (tasks:server-set-interface-port (db:delay-if-busy tdbdat) server-id interface start-port)
	  (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "dbprep")
	  (set! *server-info* (list hostn start-port)) ;; probably not needed anymore? currently used by keep-running
	  (thread-sleep! 3) ;; give some margin for queries to complete before switching from file based access to server based access
	  ;; (set! *inmemdb*  dbstruct)
	  (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "running")
	  (thread-start! (make-thread
			  (lambda ()(nmsg-transport:keep-running server-id run-id))
			  "keep running"))
	  (thread-join! server-thread))
	(if (> retrynum 0)
	    (begin
	      (debug:print 0 "WARNING: Failed to connect to server (self) on host " hostn ":" start-port ", trying again.")
	      (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id "failed to start, never received server alive signature")
	      (portlogger:open-run-close portlogger:set-failed start-port)
	      (nmsg-transport:run dbstruct hostn run-id server-id))
	    (begin
	      (debug:print 0 "ERROR: could not find an open port to start server on. Giving up")
	      (exit 1))))))

(define (nmsg-transport:try-start-server dbstruct run-id portnum server-id)
  (let ((repsoc (nn-socket 'rep)))
    (nn-bind repsoc (conc "tcp://*:" portnum))
    (let loop ((msg-in (nn-recv repsoc)))
      (let* ((dat    (db:string->obj msg-in transport: 'nmsg)))
	(debug:print 0 "server, received: " dat)
	(let ((result (api:execute-requests dbstruct dat)))
	  (debug:print 0 "server, sending: " result)
	  (nn-send repsoc (db:obj->string result  transport: 'nmsg)))
	(loop (nn-recv repsoc))))))

;; all routes though here end in exit ...
;;
(define (nmsg-transport:launch run-id)
  (let* ((tdbdat   (tasks:open-db))
	 (dbstruct (db:setup run-id))
	 (hostn    (or (args:get-arg "-server") "-")))
    (set! *run-id*   run-id)
    (set! *inmemdb* dbstruct)
    ;; with nbfake daemonize isn't really needed
    ;;
    ;; (if (args:get-arg "-daemonize")
    ;;     (begin
    ;;       (daemon:ize)
    ;;       (if *alt-log-file* ;; we should re-connect to this port, I think daemon:ize disrupts it
    ;;           (begin
    ;;     	(current-error-port *alt-log-file*)
    ;;     	(current-output-port *alt-log-file*)))))
    (if (server:check-if-running run-id)
	(begin
	  (debug:print-info 0 "Server for run-id " run-id " already running")
	  (exit 0)))
    (let loop ((server-id (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id))
	       (remtries  4))
      (if (not server-id)
	  (if (> remtries 0)
	      (begin
		(thread-sleep! 2)
		(if (not (server:check-if-running run-id))
		    (loop (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id)
			  (- remtries 1))
		    (begin
		      (debug:print-info 0 "Another server took the slot, exiting")
		      (exit 0))))
	      (begin
		;; since we didn't get the server lock we are going to clean up and bail out
		(debug:print-info 2 "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue")
		(tasks:server-delete-records-for-this-pid (db:delay-if-busy tdbdat) " http-transport:launch")
		))
	  ;; locked in a server id, try to start up
	  (nmsg-transport:run dbstruct hostn run-id server-id))
      (set! *didsomething* #t)
      (exit))))

;;======================================================================
;; S E R V E R   U T I L I T I E S 
;;======================================================================

(define (nmsg-transport:mk-signature)
  (message-digest-string (md5-primitive) 
			 (with-output-to-string
			   (lambda ()
			     (write (list (current-directory)
					  (argv)))))))

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

;; ping the server at host:port
;;   return the open socket if successful (return-socket == #t)
;;   expect the key expected-key returned in payload
;;   send our-key or #f as payload
;;
(define (nmsg-transport:ping hostn port #!key (timeout 3)(return-socket #t)(expected-key #f)(our-key #f)(socket #f))
  ;; send a random number along with pid and check that we get it back
  (let* ((host    (if (or (not hostn)
			  (equal? hostn "-")) ;; use localhost
		      (get-host-name)
		      hostn))
	 (req     (or socket
		      (let ((soc (nn-socket 'req)))
			(nn-connect soc (conc "tcp://" host ":" port))
			soc)))
	 (success #t)
	 (dat     (vector "ping" our-key))
	 (result  (condition-case 
		   (nmsg-transport:client-api-send-receive-raw req dat timeout: timeout)
		   ((timeout)(set! success #f) #f)))
	 (key     (if success 
		      (vector-ref result 1)
		      #f)))
    (debug:print 0 "success=" success ", key=" key ", expected-key=" expected-key ", equal? " (equal? key expected-key))
    (if (and success
	     (or (not expected-key) ;; just getting a reply is good enough then
		 (equal? key expected-key)))
	(if return-socket
	    req
	    (begin
	      (if (not socket)(nn-close req)) ;; don't want a side effect of closing socket if handed it
	      #t))
	(begin
	  (if (not socket)(nn-close req)) ;; failed to ping, close socket as side effect
	  #f))))

;; send data to server, wait max of timeout seconds for a response.
;; return #( success/fail result )
;;
;; for effiency it is easier to do the obj->string and string->obj here.
;;
(define (nmsg-transport:client-api-send-receive-raw socreq indat #!key (enable-send #t)(timeout 25))
  (let* ((success     #f)
	 (result      #f)
	 (keepwaiting #t)
	 (dat         (db:obj->string indat transport: 'nmsg))
	 (send-recv   (make-thread
		       (lambda ()
			 (nn-send socreq dat)
			 (let* ((res (nn-recv socreq)))
			   (set! success #t)
			   (set! result (db:string->obj res transport: 'nmsg))))
		       "send-recv"))
	 (timeout     (make-thread
		       (lambda ()
			 (let loop ((count 0))
			   (thread-sleep! 1)
			   (debug:print-info 1 "send-receive-raw, still waiting after " count " seconds...")
			   (if (and keepwaiting (< count timeout)) ;; yes, this is very aproximate
			       (loop (+ count 1))))
			 (if keepwaiting
			     (begin
			       (print "timeout waiting for ping")
			       (thread-terminate! send-recv))))
		       "timeout")))
    ;; replace with condition-case?
    (handle-exceptions
     exn
     (set! result "timeout")
     (thread-start! timeout)
     (thread-start! send-recv)
     (thread-join! send-recv)
     (if success (thread-terminate! timeout)))
    ;; raise timeout error if timed out
    (if success
	(if (and (vector? result)
		 (vector-ref result 0)) ;; did it fail at the server?
	    result                ;; nope, all good
	    (begin
	      (debug:print 0 "ERROR: error occured at server, info=" (vector-ref result 2))
	      (debug:print 0 " client call chain:")
	      (print-call-chain (current-error-port))
	      (debug:print 0 " server call chain:")
	      (pp (vector-ref result 1) (current-error-port))
	      (signal (vector-ref result 0))))
	(signal (make-composite-condition
		 (make-property-condition 'timeout 'message "nmsg-transport:client-api-send-receive-raw timed out talking to server"))))))

;; run nmsg-transport:keep-running in a parallel thread to monitor that the db is being 
;; used and to shutdown after sometime if it is not.
;;
(define (nmsg-transport:keep-running server-id run-id)
  ;; if none running or if > 20 seconds since 
  ;; server last used then start shutdown
  ;; This thread waits for the server to come alive
  (let* ((server-info (let loop ()
                        (let ((sdat #f))
                          (mutex-lock! *heartbeat-mutex*)
                          (set! sdat *server-info*)
                          (mutex-unlock! *heartbeat-mutex*)
                          (if sdat 
			      (begin
				(debug:print-info 0 "keep-running got sdat=" sdat)
				sdat)
                              (begin
                                (thread-sleep! 0.5)
                                (loop))))))
         (iface       (car server-info))
         (port        (cadr server-info))
         (last-access 0)
	 (tdbdat      (tasks:open-db))
	 (server-timeout (let ((tmo (configf:lookup  *configdat* "server" "timeout")))
			   (if (and (string? tmo)
				    (string->number tmo))
			       (* 60 60 (string->number tmo))
			       ;; (* 3 24 60 60) ;; default to three days
			       (* 60 1)         ;; default to one minute
			       ;; (* 60 60 25)      ;; default to 25 hours
			       ))))
    (print "Keep-running got server pid " server-id ", using iface " iface " and port " port)
    (let loop ((count 0))
      (thread-sleep! 4) ;; no need to do this very often
      ;; NB// sync currently does NOT return queue-length
      (let () ;; (queue-len (cdb:client-call server-info 'sync #t 1)))
      ;; (print "Server running, count is " count)
        (if (< count 1) ;; 3x3 = 9 secs aprox
            (loop (+ count 1)))
        
        (mutex-lock! *heartbeat-mutex*)
        (set! last-access *last-db-access*)
        (mutex-unlock! *heartbeat-mutex*)
	(db:sync-touched *inmemdb* run-id force-sync: #t)
        (if (and *server-run*
	       (> (+ last-access server-timeout)
		  (current-seconds)))
            (begin
              (debug:print-info 0 "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
              (loop 0))
            (begin
              (debug:print-info 0 "Starting to shutdown the server.")
              (set! *time-to-exit* #t)
	      (db:sync-touched *inmemdb* run-id force-sync: #t)
              (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running")
              (debug:print-info 0 "Server shutdown complete. Exiting")
              (exit)
	      ))))))

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

(define (nmsg-transport:client-connect iface portnum)
  (let* ((reqsoc      (nmsg-transport:ping iface portnum return-socket: #t)))
    (vector iface portnum #f #f #f (current-seconds) reqsoc)))

;; returns result, there is no sucess/fail flag - handled via excpections
;;
(define (nmsg-transport:client-api-send-receive run-id connection-info cmd param #!key (remtries 5))
  ;; NB// In the html version of this routine there is a call to 
  ;;      tasks:kill-server-run-id when there is an exception
  (mutex-lock! *http-mutex*)
  (let* ((packet  (vector cmd param))
	 (reqsoc  (http-transport:server-dat-get-socket connection-info))
	 (res     (nmsg-transport:client-api-send-receive-raw reqsoc packet)))
;;	 (status  (vector-ref rawres 0))
;;	 (result  (vector-ref rawres 1)))
    (mutex-unlock! *http-mutex*)
    res)) ;; (vector status (if status (db:string->obj result transport: 'nmsg) result))))
	
;;======================================================================
;; J U N K 
;;======================================================================

;; DO NOT USE
;;
(define (nmsg-transport:client-signal-handler signum)
  (handle-exceptions
   exn
   (debug:print " ... exiting ...")
   (let ((th1 (make-thread (lambda ()
			     (if (not *received-response*)
				 (receive-message* *runremote*))) ;; flush out last call if applicable
			   "eat response"))
	 (th2 (make-thread (lambda ()
			     (debug:print 0 "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.")
			     (thread-sleep! 3) ;; give the flush three seconds to do it's stuff
			     (debug:print 0 "       Done.")
			     (exit 4))
			   "exit on ^C timer")))
     (thread-start! th2)
     (thread-start! th1)
     (thread-join! th2))))

Added oldsrc/fs-transport.scm version [d187681c70].

























































































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

;; Copyright 2006-2012, 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.

(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 *megatest-db*) ;; we will require that (setup-for-run) has already been called
      (set! *megatest-db* (open-db)))
  (debug:print-info 11 "fs:process-queue-item called with packet=" packet)
  (db:process-queue-item *megatest-db* packet))
      

Added oldsrc/zmq-transport.scm version [1f9025d277].





























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
;;======================================================================
;; Copyright 2006-2012, 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.
;;======================================================================

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

(declare (unit zmq-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))

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

;; Transition to pub --> sub with pull <-- push
;;
;;   1. client sends request to server via push to the pull port
;;   2. server puts request in queue or processes immediately as appropriate
;;   3. server puts responses from completed requests into pub port 
;;
;; TODO
;;
;; Done Tested
;; [x]  [ ]    1. Add columns pullport pubport to servers table
;; [x]  [ ]    2. Add rm of monitor.db if older than 11/12/2012 
;; [x]  [ ]    3. Add create of pullport and pubport with finding of available ports
;; [x]  [ ]    4. Add client compose of request
;; [x]  [ ]        - name of client: testname/itempath-test_id-hostname 
;; [x]  [ ]        - name of request: callname, params
;; [x]  [ ]        - request key: f(clientname, callname, params)
;; [x]  [ ]    5. Add processing of subscription hits
;; [x]  [ ]        - done when get key 
;; [x]  [ ]        - return results
;; [x]  [ ]    6. Add timeout processing
;; [x]  [ ]        - after 60 seconds
;; [ ]  [ ]            i. check server alive, connect to new if necessary
;; [ ]  [ ]           ii. resend request
;; [ ]  [ ]    7. Turn self ping back on

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

(define *server-loop-heart-beat* (current-seconds))
(define *heartbeat-mutex* (make-mutex))

;;======================================================================
;; S E R V E R
;;======================================================================

(define-inline (zmqsock:get-pub  dat)(vector-ref dat 0))
(define-inline (zmqsock:get-pull dat)(vector-ref dat 1))
(define-inline (zmqsock:set-pub! dat s)(vector-set! dat s 0))
(define-inline (zmqsock:set-pull! dat s)(vector-set! dat s 0))

(define (zmq-transport:run hostn)
  (debug:print 2 "Attempting to start the server ...")
  (if (not *toppath*)
      (if (not (setup-for-run))
	  (begin
	    (debug:print 0 "ERROR: cannot find megatest.config, cannot start server, exiting")
	    (exit))))
  (let* ((db              (open-db)) ;; here we *do not* want to be opening and closing the db
	 (zmq-sdat1       #f)
	 (zmq-sdat2       #f)
	 (pull-socket     #f)
	 (pub-socket      #f)
	 (p1              #f)
	 (p2              #f)
	 (zmq-sockets-dat #f)
	 (iface           (if (string=? "-" hostn)
			      "*" ;; (get-host-name) 
			      hostn))
	 (hostname        (get-host-name))
	 (ipaddrstr       (let ((ipstr (if (string=? "-" hostn)
					   (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
					   #f)))
			    (if ipstr ipstr hostname)))
	 (last-run       0))
    (set! zmq-sockets-dat (zmq-transport:setup-ports ipaddrstr (if (args:get-arg "-port")
			    (string->number (args:get-arg "-port"))
							    (+ 5000 (random 1001)))))

    (set! zmq-sdat1    (car   zmq-sockets-dat))
    (set! pull-socket  (cadr  zmq-sdat1)) ;; (iface s  port)
    (set! p1           (caddr zmq-sdat1))
    
    (set! zmq-sdat2    (cadr  zmq-sockets-dat))
    (set! pub-socket   (cadr  zmq-sdat2))
    (set! p2           (caddr zmq-sdat2))

    (set! *cache-on* #t)

    (set! *runremote* (vector pull-socket pub-socket)) ;; overloading the use of *runremote* BUG!?

    ;; what to do when we quit
    ;;
;;     (on-exit (lambda ()
;; 	       (if (and *toppath* *server-info*)
;; 		   (open-run-close tasks:server-deregister-self tasks:open-db (car *server-info*))
;; 		   (let loop () 
;; 		     (let ((queue-len 0))
;; 		       (thread-sleep! (random 5))
;; 		       (mutex-lock! *incoming-mutex*)
;; 		       (set! queue-len (length *incoming-data*))
;; 		       (mutex-unlock! *incoming-mutex*)
;; 		       (if (> queue-len 0)
;; 			   (begin
;; 			     (debug:print-info 0 "Queue not flushed, waiting ...")
;; 			     (loop))))))))

    ;; The heavy lifting
    ;;
    ;; make-vector-record cdb packet client-sig qtype immediate query-sig params qtime
    ;;
    (debug:print-info 11 "Server setup complete, start listening for messages")
    (let loop ((queue-lst '()))
      (let* ((rawmsg (receive-message* pull-socket))
	     (packet (db:string->obj rawmsg))
	     (qtype  (cdb:packet-get-qtype packet)))
	(debug:print-info 12 "server=> received packet=" packet)
	(if (not (member qtype '(sync ping)))
	    (begin
	      (mutex-lock! *heartbeat-mutex*)
	      (set! *last-db-access* (current-seconds))
	      (mutex-unlock! *heartbeat-mutex*)))
	(if #t ;; (cdb:packet-get-immediate packet) ;; process immediately or put in queue
	    (begin
	      (db:process-queue-item db packet)
	      ;; (open-run-close db:process-queue #f pub-socket (cons packet queue-lst))
	      
	      (loop '()))
	    (loop (cons packet queue-lst)))))))

;; run zmq-transport:keep-running in a parallel thread to monitor that the db is being 
;; used and to shutdown after sometime if it is not.
;;
(define (zmq-transport:keep-running)
  ;; if none running or if > 20 seconds since 
  ;; server last used then start shutdown
  ;; This thread waits for the server to come alive
  (let* ((server-info (let loop ()
			(let ((sdat #f))
			  (mutex-lock! *heartbeat-mutex*)
			  (set! sdat *server-info*)
			  (mutex-unlock! *heartbeat-mutex*)
			  (if sdat sdat
			      (begin
				(debug:print 12 "WARNING: server not started yet, waiting few seconds before trying again")
				(sleep 4)
				(loop))))))
	 (iface       (cadr server-info))
	 (pullport    (caddr server-info))
	 (pubport     (cadddr server-info)) ;; id interface pullport pubport)
	 ;; (zmq-sockets (zmq-transport:client-connect iface pullport pubport))
	 (last-access 0))
    (debug:print-info 11 "heartbeat started for zmq server on " iface " " pullport " " pubport)
    (let loop ((count 0))
      (thread-sleep! 4) ;; no need to do this very often
      ;; NB// sync currently does NOT return queue-length
      ;; GET REAL QUEUE LENGTH FROM THE VARIABLE
      (let ((queue-len 0)) ;; FOR NOW DO NOT DO THIS (cdb:client-call zmq-sockets 'sync #t 1)))
      ;; (print "Server running, count is " count)
	(if (< count 1) ;; 3x3 = 9 secs aprox
	    (loop (+ count 1)))

	;; NOTE: Get rid of this mechanism! It really is not needed...
	(open-run-close tasks:server-update-heartbeat tasks:open-db (car server-info))

	;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access
	(mutex-lock! *heartbeat-mutex*)
	(set! last-access *last-db-access*)
	(mutex-unlock! *heartbeat-mutex*)
	(if (> (+ last-access
		  ;; (* 50 60 60)    ;; 48 hrs
		  ;; 60              ;; one minute
		  ;; (* 60 60)       ;; one hour
		  (* 45 60)          ;; 45 minutes, until the db deletion bug is fixed.
		  )
	       (current-seconds))
	    (begin
	      (debug:print-info 2 "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
	      (loop 0))
	    (begin
	      (debug:print-info 0 "Starting to shutdown the server.")
	      ;; need to delete only *my* server entry (future use)
	      (set! *time-to-exit* #t)
	      (open-run-close tasks:server-deregister-self tasks:open-db (get-host-name))
	      (thread-sleep! 1)
	      (debug:print-info 0 "Max cached queries was " *max-cache-size*)
	      (debug:print-info 0 "Server shutdown complete. Exiting")
	      (exit)))))))

(define (zmq-transport:find-free-port-and-open iface s port stype #!key (trynum 50))
  (let ((s (if s s (make-socket stype)))
        (p (if (number? port) port 5555))
        (old-handler (current-exception-handler)))
    (handle-exceptions
     exn
     (begin
       (debug:print 0 "Failed to bind to port " p ", trying next port")
       (debug:print 0 "   EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
       ;; (old-handler)
       ;; (print-call-chain)
       (if (> trynum 0)
           (zmq-transport:find-free-port-and-open iface s (+ p 1) trynum: (- trynum 1))
           (debug:print-info 0 "Tried ports up to " p 
                             " but all were in use. Please try a different port range by starting the server with parameter \" -port N\" where N is the starting port number to use"))
       (exit)) ;; To exit or not? That is the question.
     (let ((zmq-url (conc "tcp://" iface ":" p)))
       (debug:print 2 "Trying to start server on " zmq-url)
       (bind-socket s zmq-url)
       (list iface s port)))))

(define (zmq-transport:setup-ports ipaddrstr startport)
  (let* ((s1 (zmq-transport:find-free-port-and-open ipaddrstr #f startport 'pull))
         (p1 (caddr s1))
         (s2 (zmq-transport:find-free-port-and-open ipaddrstr #f (+ 1 (if p1 p1 (+ startport 1))) 'pub))
         (p2 (caddr s2)))
    (set! *runremote* #f)
    (debug:print 0 "Server started on " ipaddrstr " ports " p1 " and " p2)
    (mutex-lock! *heartbeat-mutex*)
    (set! *server-info* (open-run-close tasks:server-register 
					tasks:open-db 
					(current-process-id) 
					ipaddrstr p1 
					0 
					'live
					'zmq
					pubport: p2))
    (debug:print-info 11 "*server-info* set to " *server-info*)
    (mutex-unlock! *heartbeat-mutex*)
    (list s1 s2)))

(define (zmq-transport:mk-signature)
  (message-digest-string (md5-primitive) 
			 (with-output-to-string
			   (lambda ()
			     (write (list (current-directory)
					  (argv)))))))

;;======================================================================
;; S E R V E R   U T I L I T I E S 
;;======================================================================

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

;; 
(define (zmq-transport:client-socket-connect iface port #!key (context #f)(type 'req)(subscriptions '()))
  (debug:print-info 3 "client-connect " iface ":" port ", type=" type ", subscriptions=" subscriptions)
  (let ((connect-ok #f)
	(zmq-socket (if context 
			(make-socket type context)
			(make-socket type)))
	(conurl     (zmq-transport:make-server-url (list iface port))))
    (if (socket? zmq-socket)
     (begin
	  ;; first apply subscriptions
	  (for-each (lambda (subscription)
		      (debug:print 2 "Subscribing to " subscription)
		      (socket-option-set! zmq-socket 'subscribe subscription))
		    subscriptions)
	  (connect-socket zmq-socket conurl)
	  zmq-socket)
	(begin
	  (debug:print 0 "ERROR: Failed to open socket to " conurl)
	  #f))))

(define (zmq-transport:client-connect iface pullport pubport)
  (let* ((push-socket (zmq-transport:client-socket-connect iface pullport type: 'push))
	 (sub-socket  (zmq-transport:client-socket-connect iface pubport
						    type: 'sub
						    subscriptions: (list (client:get-signature) "all")))
	 (zmq-sockets (vector push-socket sub-socket))
	 (login-res   #f))
    (debug:print-info 11 "zmq-transport:client-connect started. Next is login")
    (set! login-res (client:login serverdat zmq-sockets))
    (if (and (not (null? login-res))
	     (car login-res))
	(begin
	  (debug:print-info 2 "Logged in and connected to " iface ":" pullport "/" pubport ".")
	  (set! *runremote* zmq-sockets)
	  zmq-sockets)
	(begin
	  (debug:print-info 2 "Failed to login or connect to " conurl)
	  (set! *runremote* #f)
	  #f))))

;; run zmq-transport:keep-running in a parallel thread to monitor that the db is being 
;; used and to shutdown after sometime if it is not.
;;
(define (zmq-transport:keep-running)
  ;; if none running or if > 20 seconds since 
  ;; server last used then start shutdown
  ;; This thread waits for the server to come alive
  (let* ((server-info (let loop ()
                        (let ((sdat #f))
                          (mutex-lock! *heartbeat-mutex*)
                          (set! sdat *runremote*)
                          (mutex-unlock! *heartbeat-mutex*)
                          (if sdat sdat
                              (begin
                                (sleep 4)
                                (loop))))))
         (iface       (car server-info))
         (port        (cadr server-info))
         (last-access 0)
	 (tdb         (tasks:open-db))
	 (spid        (tasks:server-get-server-id tdb #f iface port #f)))
    (print "Keep-running got server pid " spid ", using iface " iface " and port " port)
    (let loop ((count 0))
      (thread-sleep! 4) ;; no need to do this very often
      ;; NB// sync currently does NOT return queue-length
      (let () ;; (queue-len (cdb:client-call server-info 'sync #t 1)))
      ;; (print "Server running, count is " count)
        (if (< count 1) ;; 3x3 = 9 secs aprox
            (loop (+ count 1)))
        
        ;; NOTE: Get rid of this mechanism! It really is not needed...
        (tasks:server-update-heartbeat tdb spid)
      
        ;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access
        (mutex-lock! *heartbeat-mutex*)
        (set! last-access *last-db-access*)
        (mutex-unlock! *heartbeat-mutex*)
        (if (> (+ last-access
                  ;; (* 50 60 60)    ;; 48 hrs
                  ;; 60              ;; one minute
                  ;; (* 60 60)       ;; one hour
                  (* 45 60)          ;; 45 minutes, until the db deletion bug is fixed.
                  )
               (current-seconds))
            (begin
              (debug:print-info 2 "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
              (loop 0))
            (begin
              (debug:print-info 0 "Starting to shutdown the server.")
              ;; need to delete only *my* server entry (future use)
              (set! *time-to-exit* #t)
              (tasks:server-deregister-self tdb (get-host-name))
              (thread-sleep! 1)
              (debug:print-info 0 "Max cached queries was " *max-cache-size*)
              (debug:print-info 0 "Server shutdown complete. Exiting")
              (exit)))))))

;; all routes though here end in exit ...
(define (zmq-transport:launch)
  (if (not *toppath*)
      (if (not (setup-for-run))
	  (begin
	    (debug:print 0 "ERROR: cannot find megatest.config, exiting")
	    (exit))))
  (debug:print-info 2 "Starting zmq server")
  (if *toppath* 
      (let* (;; (th1 (make-thread (lambda ()
	     ;;      	       (let ((server-info #f))
	     ;;      		 ;; wait for the server to be online and available
	     ;;      		 (let loop ()
	     ;;			   (debug:print-info 2 "Waiting for the server to come online before starting heartbeat")
	     ;;      		   (thread-sleep! 2)
	     ;;      		   (mutex-lock! *heartbeat-mutex*)
	     ;;      		   (set! server-info *server-info* )
	     ;;      		   (mutex-unlock! *heartbeat-mutex*)
	     ;;      		   (if (not server-info)(loop)))
	     ;;			 (debug:print 2 "Server alive, starting self-ping")
	     ;;      		 (zmq-transport:self-ping server-info)
	     ;;      		 ))
	     ;;      	     "Self ping"))
	     (th2 (make-thread (lambda ()
				 (zmq-transport:run 
				  (if (args:get-arg "-server")
				      (args:get-arg "-server")
				      "-"))) "Server run"))
	     ;; (th3 (make-thread (lambda ()(zmq-transport:keep-running)) "Keep running"))
	     )
	(set! *client-non-blocking-mode* #t)
	;; (thread-start! th1)
	(thread-start! th2)
	;; (thread-start! th3)
	(set! *didsomething* #t)
	;; (thread-join! th3)
	(thread-join! th2)
	)
      (debug:print 0 "ERROR: Failed to setup for megatest")))

(define (zmq-transport:client-signal-handler signum)
  (handle-exceptions
   exn
   (debug:print " ... exiting ...")
   (let ((th1 (make-thread (lambda ()
			     (if (not *received-response*)
				 (receive-message* *runremote*))) ;; flush out last call if applicable
			   "eat response"))
	 (th2 (make-thread (lambda ()
			     (debug:print 0 "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.")
			     (thread-sleep! 3) ;; give the flush three seconds to do it's stuff
			     (debug:print 0 "       Done.")
			     (exit 4))
			   "exit on ^C timer")))
     (thread-start! th2)
     (thread-start! th1)
     (thread-join! th2))))

(define (zmq-transport:client-launch)
  (set-signal-handler! signal/int zmq-transport:client-signal-handler)
   (if (zmq-transport:client-setup)
       (debug:print-info 2 "connected as client")
       (begin
	 (debug:print 0 "ERROR: Failed to connect as client")
	 (exit))))

;;======================================================================
;; Defunct functions
;;======================================================================

;; ping a server and return number of clients or #f (if no response)
;; NOT IN USE!
(define (zmq-transport:ping host port #!key (secs 10)(return-socket #f))
  (cdb:use-non-blocking-mode
   (lambda ()
     (let* ((res #f)
	    (th1 (make-thread
		  (lambda ()
		    (let* ((zmq-context (make-context 1))
			   (zmq-socket  (zmq-transport:client-connect host port context: zmq-context)))
		      (if zmq-socket
			  (if (zmq-transport:client-login zmq-socket)
			      (let ((numclients (cdb:num-clients zmq-socket)))
				(if (not return-socket)
				    (begin
				      (zmq-transport:client-logout zmq-socket)
				      (close-socket  zmq-socket)))
				(set! res (list #t numclients (if return-socket zmq-socket #f))))
			      (begin
				;; (close-socket zmq-socket)
				(set! res (list #f "CAN'T LOGIN" #f))))
			  (set! res (list #f "CAN'T CONNECT" #f)))))
		  "Ping: th1"))
	    (th2 (make-thread
		  (lambda ()
		    (let loop ((count 1))
		      (debug:print-info 1 "Ping " count " server on " host " at port " port)
		      (thread-sleep! 2)
		      (if (< count (/ secs 2))
			  (loop (+ count 1))))
		    ;; (thread-terminate! th1)
		    (set! res (list #f "TIMED OUT" #f)))
		  "Ping: th2")))
       (thread-start! th2)
       (thread-start! th1)
       (handle-exceptions
	exn
	(set! res (list #f "TIMED OUT" #f))
	(thread-join! th1 secs))
       res))))

;; (define (zmq-transport:self-ping server-info)
;;   ;; server-info: server-id interface pullport pubport
;;   (let ((iface    (list-ref server-info 1))
;; 	(pullport (list-ref server-info 2))
;; 	(pubport  (list-ref server-info 3)))
;;     (zmq-transport:client-connect iface pullport pubport)
;;     (let loop ()
;;       (thread-sleep! 2)
;;       (cdb:client-call *runremote* 'ping #t)
;;       (debug:print 4 "zmq-transport:self-ping - I'm alive on " iface ":" pullport "/" pubport "!")
;;       (mutex-lock! *heartbeat-mutex*)
;;       (set! *server-loop-heart-beat* (current-seconds))
;;       (mutex-unlock! *heartbeat-mutex*)
;;       (loop))))
    
(define (zmq-transport:reply pubsock target query-sig success/fail result)
  (debug:print-info 11 "zmq-transport:reply target=" target ", result=" result)
  (send-message pubsock target send-more: #t)
  (send-message pubsock (db:obj->string (vector success/fail query-sig result))))

Added portlogger.scm version [c19f5a6299].





































































































































































































































































































































































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

;; Copyright 2006-2014, 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.

(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   (file-exists? fname))
	 (db       (if avail 
		       (sqlite3:open-database fname)
		       (begin
			 (system (conc "rm -f " fname))
			 (sqlite3:open-database fname))))
	 (handler  (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,
         ;;                 update_time TIMESTAMP DEFAULT (strftime('%s','now')) );"))))
    (sqlite3:set-busy-handler! db handler)
    (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;")
    ;; (if (not exists) ;; needed with IF NOT EXISTS?
    (sqlite3:execute 
     db
     "CREATE TABLE IF NOT EXISTS ports (
            port INTEGER PRIMARY KEY,
            state TEXT DEFAULT 'not-used',
            fail_count INTEGER DEFAULT 0,
            update_time TIMESTAMP DEFAULT (strftime('%s','now')) );")
    db))

(define (portlogger:open-run-close proc . params)
  (let* ((fname  (conc "/tmp/." (current-user-name) "-portlogger.db"))
	 (avail  (tasks:wait-on-journal fname 10))) ;; wait up to about 10 seconds for the journal to go away
    (handle-exceptions
     exn
     (begin
       ;; (release-dot-lock fname)
       (debug:print 0 "ERROR: portlogger:open-run-close failed. " proc " " params)
       (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
       (debug:print 0 "exn=" (condition->list exn))
       (if (file-exists? fname)(delete-file fname)) ;; brutally get rid of it
       (print-call-chain (current-error-port)))
     (let* (;; (lock   (obtain-dot-lock fname 2 9 10))
	    (db     (portlogger:open-db fname))
	    (res    (apply proc db params)))
       (sqlite3:finalize! db)
       ;; (release-dot-lock fname)
       res))))

;; (fold-row PROC INIT DATABASE SQL . PARAMETERS) 
(define (portlogger:take-port db portnum)
  (let* ((qry1 (sqlite3:prepare db "INSERT INTO ports (port,state) VALUES (?,?);"))
	 (qry2 (sqlite3:prepare db "UPDATE ports SET state=?,update_time=strftime('%s','now') WHERE port=?;"))
	 (qry3 (sqlite3:prepare db "SELECT state FROM ports WHERE port=?;"))
	 (res  (sqlite3:with-transaction
		db
		(lambda ()
		  ;; (fold-row (lambda (var curr) (or var curr)) #f db "SELECT var FROM foo WHERE id=100;")
		  (let* ((curr #f)
			 (res  #f))
		    (set! curr (sqlite3:fold-row
				(lambda (var curr)
				  (or curr var curr))
				"not-tried"
				qry3
				portnum))
		    ;; (print "curr=" curr)
		    (set! res (case (string->symbol curr)
				((released)  (sqlite3:execute qry2 "taken" portnum) 'taken)
				((not-tried) (sqlite3:execute qry1 portnum "taken") 'taken)
				((taken)                                            'already-taken)
				((failed)                                           'failed)
				(else                                               'error)))
		    ;; (print "res=" res)
		    res)))))
    (sqlite3:finalize! qry1)
    (sqlite3:finalize! qry2)
    (sqlite3:finalize! qry3)
    res))

(define (portlogger:get-prev-used-port db)
  (handle-exceptions
   exn
   (begin
     (debug:print 0 "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db")
     (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
     (debug:print 0 "exn=" (condition->list exn))
     (print-call-chain (current-error-port))
     (debug:print 0 "Continuing anyway.")
     #f)
   (sqlite3:fold-row
    (lambda (var curr)
      (or curr var curr))
    #f
    db
    "SELECT (port) FROM ports WHERE state='released' LIMIT 1;")))

(define (portlogger:find-port db)
  (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 "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db")
       (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
       (debug:print 0 "exn=" (condition->list exn))
       (print-call-chain (current-error-port))
       (debug:print 0 "Continuing anyway."))
     (portlogger:take-port db portnum))
    portnum))

;; set port to "released", "failed" etc.
;; 
(define (portlogger:set-port db portnum value)
  (sqlite3:execute db "UPDATE ports SET state=?,update_time=strftime('%s','now') WHERE port=?;" value portnum))

;; set port to failed (attempted to take but got error)
;;
(define (portlogger:set-failed db portnum)
  (sqlite3:execute db "UPDATE ports SET state='failed',fail_count=fail_count+1,update_time=strftime('%s','now') WHERE port=?;" portnum))

;;======================================================================
;; MAIN
;;======================================================================

(define (portlogger:main . args)
  (let* ((dbfname (conc "/tmp/." (current-user-name) "-portlogger.db"))
	 (db      (portlogger:open-db dbfname))
	 (numargs (length args))
	 (result  
	  (handle-exceptions
	   exn
	   (begin
	     (debug:print 0 "EXCEPTION: portlogger database at " dbfname " probably overloaded or unreadable. Try removing it.")
	     (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
	     (print "exn=" (condition->list exn))
	     (debug:print 0 " status:  " ((condition-property-accessor 'sqlite3 'status) exn))
	     (print-call-chain (current-error-port)))
	   (cond
	    ((> numargs 1) ;; most commands
	     (case (string->symbol (car args)) ;; commands with two or more params
	       ((take)(portlogger:take-port db (string->number (cadr args))))
	       ((set) (portlogger:set-port db 
					   (string->number (cadr args))
					   (caddr args))
		(caddr args))
	       ((failed)(portlogger:set-failed db (string->number (cadr args))) 'failed)))))))
    (sqlite3:finalize! db)
    result))
     
;; (print (apply portlogger:main (cdr (argv))))

Modified process.scm from [88799f98f8] to [13bb37a3d1].

49
50
51
52
53
54
55


56
57
58
59
60
61
62

(define (cmd-run-proc-each-line cmd proc . params)
  ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params)
  (handle-exceptions
   exn
   (begin
     (print "ERROR:  Failed to run command: " cmd " " (string-intersperse params " "))


     #f)
   (let-values (((fh fho pid) (if (null? params)
				  (process cmd)
				  (process cmd params))))
       (let loop ((curr (read-line fh))
		(result  '()))
       (if (not (eof-object? curr))







>
>







49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64

(define (cmd-run-proc-each-line cmd proc . params)
  ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params)
  (handle-exceptions
   exn
   (begin
     (print "ERROR:  Failed to run command: " cmd " " (string-intersperse params " "))
     (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
     (print "exn=" (condition->list exn))
     #f)
   (let-values (((fh fho pid) (if (null? params)
				  (process cmd)
				  (process cmd params))))
       (let loop ((curr (read-line fh))
		(result  '()))
       (if (not (eof-object? curr))
97
98
99
100
101
102
103
104











105
106
107
108
109
110
111
112
            (loop (let ((l (read-line fh)))
                    (if (eof-object? l) l (proc l)))
                  (append result (list curr)))
            result))))

;; here is an example line where the shell is sh or bash
;; "find / -print 2&>1 > findall.log"
(define (run-n-wait cmdline)











  (let ((pid (process-run cmdline)))
    (let loop ((i 0))
      (let-values (((pid-val exit-status exit-code) (process-wait pid #t)))
         (if (eq? pid-val 0)
	     (begin
	       (thread-sleep! 2)
	       (loop (+ i 1)))
	     (values pid-val exit-status exit-code))))))







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







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
            (loop (let ((l (read-line fh)))
                    (if (eof-object? l) l (proc l)))
                  (append result (list curr)))
            result))))

;; here is an example line where the shell is sh or bash
;; "find / -print 2&>1 > findall.log"
(define (run-n-wait cmdline #!key (params #f)(print-cmd #f))
  (if print-cmd 
      (debug:print 0 
		   (if (string? print-cmd)
		       print-cmd
		       "")
		   cmdline
		   (if params
		       (string-intersperse params " ")
		       "")))
  (let ((pid (if params
		 (process-run cmdline params)
		 (process-run cmdline))))
    (let loop ((i 0))
      (let-values (((pid-val exit-status exit-code) (process-wait pid #t)))
         (if (eq? pid-val 0)
	     (begin
	       (thread-sleep! 2)
	       (loop (+ i 1)))
	     (values pid-val exit-status exit-code))))))
122
123
124
125
126
127
128
129









     (let loop ((inl (read-line))
		(res '()))
       (if (eof-object? inl)
	   (reverse res)
	   (let ((pid (string->number inl)))
	     (if proc (proc pid))
	     (loop (read-line) (cons pid res))))))))
       
















|
>
>
>
>
>
>
>
>
>
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
     (let loop ((inl (read-line))
		(res '()))
       (if (eof-object? inl)
	   (reverse res)
	   (let ((pid (string->number inl)))
	     (if proc (proc pid))
	     (loop (read-line) (cons pid res))))))))

(define (process:alive? pid)
  (handle-exceptions
   exn
   ;; possibly pid is a process not a child, look in /proc to see if it is running still
   (file-exists? (conc "/proc/" pid))
   (let-values (((rpid exit-type exit-signal)(process-wait pid #t)))
       (and (number? rpid)
	    (equal? rpid pid)))))
	 

Added rmt.scm version [841f80a9e9].

























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
;;======================================================================
;; Copyright 2006-2013, 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.
;;======================================================================

(use json format)

(declare (unit rmt))
(declare (uses api))
(declare (uses tdb))
(declare (uses http-transport))
(declare (uses nmsg-transport))

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

;; ;; For debugging add the following to ~/.megatestrc
;;a
;; (require-library trace)
;; (import trace)
;; (trace
;; rmt:send-receive
;; api:execute-requests
;; )

;; generate entries for ~/.megatestrc with the following
;;
;;  grep define ../rmt.scm | grep rmt: |perl -pi -e 's/\(define\s+\((\S+)\W.*$/\1/'|sort -u


;;======================================================================
;;  S U P P O R T   F U N C T I O N S
;;======================================================================

;; NOT USED?
;;
;; (define (rmt:call-transport run-id connection-info cmd jparams)
;;   (case (server:get-transport)
;;     ((rpc)  ( rpc-transport:client-api-send-receive run-id connection-info cmd jparams))
;;     ((http) (http-transport:client-api-send-receive run-id connection-info cmd jparams))
;;     ((fs)   ( fs-transport:client-api-send-receive run-id connection-info cmd jparams))
;;     ((zmq)  (zmq-transport:client-api-send-receive run-id connection-info cmd jparams))
;;     (else   ( rpc-transport:client-api-send-receive run-id connection-info cmd jparams))))

;;
(define (rmt:write-frequency-over-limit? cmd run-id)
  (and (not (member cmd api:read-only-queries))
       (let* ((tmprec (hash-table-ref/default *write-frequency* run-id #f))
	      (record (if tmprec tmprec 
			  (let ((v (vector (current-seconds) 0)))
			    (hash-table-set! *write-frequency* run-id v)
			    v)))
	      (count  (+ 1 (vector-ref record 1)))
	      (start  (vector-ref record 0))
	      (queries-per-second (/ (* count 1.0)
				     (max (- (current-seconds) start) 1))))
	 (vector-set! record 1 count)
	 (if (and (> count 10)
		  (> queries-per-second 10))
	     (begin
	       (debug:print-info 1 "db write rate too high, starting a server, count=" count " start=" start " run-id=" run-id " queries-per-second=" queries-per-second)
	       #t)
	     #f))))

;; if a server is either running or in the process of starting call client:setup
;; else return #f to let the calling proc know that there is no server available
;;
(define (rmt:get-connection-info run-id)
  (let ((cinfo (hash-table-ref/default *runremote* run-id #f)))
    (if cinfo
	cinfo
	;; NB// can cache the answer for server running for 10 seconds ...
	;;  ;; (and (not (rmt:write-frequency-over-limit? cmd run-id))
	(if (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id)
	    (client:setup run-id)
	    #f))))

(define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id
(define (rmt:send-receive cmd rid params #!key (attemptnum 1)) ;; start attemptnum at 1 so the modulo below works as expected
  ;; clean out old connections
  (mutex-lock! *db-multi-sync-mutex*)
  (let ((expire-time (- (current-seconds) (server:get-timeout) 10))) ;; don't forget the 10 second margin
    (for-each 
     (lambda (run-id)
       (let ((connection (hash-table-ref/default *runremote* run-id #f)))
         (if (and (vector? connection)
        	  (< (http-transport:server-dat-get-last-access connection) expire-time))
             (begin
               (debug:print-info 0 "Discarding connection to server for run-id " run-id ", too long between accesses")
               ;; SHOULD CLOSE THE CONNECTION HERE
	       (case *transport-type*
		 ((nmsg)(nn-close (http-transport:server-dat-get-socket 
				   (hash-table-ref *runremote* run-id)))))
               (hash-table-delete! *runremote* run-id)))))
     (hash-table-keys *runremote*)))
  (mutex-unlock! *db-multi-sync-mutex*)
  ;; (mutex-lock! *send-receive-mutex*)
  (let* ((run-id          (if rid rid 0))
	 (connection-info (rmt:get-connection-info run-id)))
    ;; the nmsg method does the encoding under the hood (the http method should be changed to do this also)
    (if connection-info
	;; use the server if have connection info
	(let* ((dat     (case *transport-type*
			  ((http)(condition-case
				  (http-transport:client-api-send-receive run-id connection-info cmd params)
				  ((commfail)(vector #f "communications fail"))
				  ((exn)(vector #f "other fail"))))
			  ((nmsg)(condition-case
				  (nmsg-transport:client-api-send-receive run-id connection-info cmd params)
				  ((timeout)(vector #f "timeout talking to server"))))
			  (else  (exit))))
	       (success (if (vector? dat) (vector-ref dat 0) #f))
	       (res     (if (vector? dat) (vector-ref dat 1) #f)))
	  (if (vector? connection-info)(http-transport:server-dat-update-last-access connection-info))
	  (if success
	      (begin
		;; (mutex-unlock! *send-receive-mutex*)
		(case *transport-type* 
		  ((http) res) ;; (db:string->obj res))
		  ((nmsg) res))) ;; (vector-ref res 1)))
	      (begin ;; let ((new-connection-info (client:setup run-id)))
		(debug:print 0 "WARNING: Communication failed, trying call to rmt:send-receive again.")
		;; (case *transport-type*
		;;   ((nmsg)(nn-close (http-transport:server-dat-get-socket connection-info))))
		(hash-table-delete! *runremote* run-id) ;; don't keep using the same connection
		;; NOTE: killing server causes this process to block forever. No idea why. Dec 2. 
		;; (if (eq? (modulo attemptnum 5) 0)
		;;     (tasks:kill-server-run-id run-id tag: "api-send-receive-failed"))
		;; (mutex-unlock! *send-receive-mutex*) ;; close the mutex here to allow other threads access to communications
		(tasks:start-and-wait-for-server (tasks:open-db) run-id 15)
		;; (nmsg-transport:client-api-send-receive run-id connection-info cmd param remtries: (- remtries 1))))))

		;; no longer killing the server in http-transport:client-api-send-receive
		;; may kill it here but what are the criteria?
		;; start with three calls then kill server
		;; (if (eq? attemptnum 3)(tasks:kill-server-run-id run-id))
		;; (thread-sleep! 2)
		(rmt:send-receive cmd run-id params attemptnum: (+ attemptnum 1)))))
	;; no connection info? try to start a server, or access locally if no
	;; server and the query is read-only
	;;
	;; Note: The tasks db was checked for a server in starting mode in the rmt:get-connection-info call
	;;
	(if (and (< attemptnum 15)
		 (member cmd api:write-queries))
	    (begin
	      (hash-table-delete! *runremote* run-id)
	      ;; (mutex-unlock! *send-receive-mutex*)
	      (tasks:start-and-wait-for-server (db:delay-if-busy (tasks:open-db)) run-id 10)
	      ;; (client:setup run-id) ;; client setup happens in rmt:get-connection-info
	      (thread-sleep! (random 5)) ;; give some time to settle and minimize collison?
	      (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1)))
	    (begin
	      ;; (debug:print 0 "ERROR: Communication failed!")
	      ;; (mutex-unlock! *send-receive-mutex*)
	      ;; (exit)
	      (rmt:open-qry-close-locally cmd run-id params)
	      )))))

(define (rmt:update-db-stats run-id rawcmd params duration)
  (mutex-lock! *db-stats-mutex*)
  (handle-exceptions
   exn
   (begin
     (debug:print 0 "WARNING: stats collection failed in update-db-stats")
     (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
     (print "exn=" (condition->list exn))
     #f) ;; if this fails we don't care, it is just stats
   (let* ((cmd      (conc "run-id=" run-id " " (if (eq? rawcmd 'general-call) (car params) rawcmd)))
	  (stat-vec (hash-table-ref/default *db-stats* cmd #f)))
     (if (not (vector? stat-vec))
	 (let ((newvec (vector 0 0)))
	   (hash-table-set! *db-stats* cmd newvec)
	   (set! stat-vec newvec)))
     (vector-set! stat-vec 0 (+ (vector-ref stat-vec 0) 1))
     (vector-set! stat-vec 1 (+ (vector-ref stat-vec 1) duration))))
  (mutex-unlock! *db-stats-mutex*))


(define (rmt:print-db-stats)
  (let ((fmtstr "~40a~7-d~9-d~20,2-f")) ;; "~20,2-f"
    (debug:print 18 "DB Stats\n========")
    (debug:print 18 (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg"))
    (for-each (lambda (cmd)
		(let ((cmd-dat (hash-table-ref *db-stats* cmd)))
		  (debug:print 18 (format #f fmtstr cmd (vector-ref cmd-dat 0) (vector-ref cmd-dat 1) (/ (vector-ref cmd-dat 1)(vector-ref cmd-dat 0))))))
	      (sort (hash-table-keys *db-stats*)
		    (lambda (a b)
		      (> (vector-ref (hash-table-ref *db-stats* a) 0)
			 (vector-ref (hash-table-ref *db-stats* b) 0)))))))

(define (rmt:get-max-query-average run-id)
  (mutex-lock! *db-stats-mutex*)
  (let* ((runkey (conc "run-id=" run-id " "))
	 (cmds   (filter (lambda (x)
			   (substring-index runkey x))
			 (hash-table-keys *db-stats*)))
	 (res    (if (null? cmds)
		     (cons 'none 0)
		     (let loop ((cmd (car cmds))
				(tal (cdr cmds))
				(max-cmd (car cmds))
				(res 0))
		       (let* ((cmd-dat (hash-table-ref *db-stats* cmd))
			      (tot     (vector-ref cmd-dat 0))
			      (curravg (/ (vector-ref cmd-dat 1) (vector-ref cmd-dat 0))) ;; count is never zero by construction
			      (currmax (max res curravg))
			      (newmax-cmd (if (> curravg res) cmd max-cmd)))
			 (if (null? tal)
			     (if (> tot 10)
				 (cons newmax-cmd currmax)
				 (cons 'none 0))
			     (loop (car tal)(cdr tal) newmax-cmd currmax)))))))
    (mutex-unlock! *db-stats-mutex*)
    res))
	  
(define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5))
  (let* ((dbstruct-local (if *dbstruct-db*
			     *dbstruct-db*
			     (let* ((dbdir (db:dbfile-path #f)) ;;  (conc    (configf:lookup *configdat* "setup" "linktree") "/.db"))
				    (db (make-dbr:dbstruct path:  dbdir local: #t)))
			       (set! *dbstruct-db* db)
			       db)))
	 (db-file-path   (db:dbfile-path 0))
	 ;; (read-only      (not (file-read-access? db-file-path)))
	 (start          (current-milliseconds))
	 (resdat         (api:execute-requests dbstruct-local (vector (symbol->string cmd) params)))
	 (success        (vector-ref resdat 0))
	 (res            (vector-ref resdat 1))
	 (duration       (- (current-milliseconds) start)))
    (if (not success)
	(if (> remretries 0)
	    (begin
	      (debug:print 0 "ERROR: 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 0 "ERROR: 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
	  (if (not (member cmd api:read-only-queries))
	      (let ((start-time (current-seconds)))
		(mutex-lock! *db-multi-sync-mutex*)
		;; (if (not (hash-table-ref/default *db-local-sync* run-id #f))
		;; just set it every time. Is a write more expensive than a read and does it matter?
		(hash-table-set! *db-local-sync* (or run-id 0) start-time) ;; the oldest "write"
		(mutex-unlock! *db-multi-sync-mutex*)))
	  res))))

(define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params)
  (let* ((run-id   (if run-id run-id 0))
	 ;; (jparams  (db:obj->string params)) ;; (rmt:dat->json-str params))
	 (res  	   (handle-exceptions
		    exn
		    #f
		    (http-transport:client-api-send-receive run-id connection-info cmd params))))
;;		    ((commfail) (vector #f "communications fail")))))
    (if (and res (vector-ref res 0))
	(vector-ref res 1) ;;; YES!! THIS IS CORRECT!! CHANGE IT HERE, THEN CHANGE rmt:send-receive ALSO!!!
	#f)))
;; 	(db:string->obj (vector-ref dat 1))
;; 	(begin
;; 	  (debug:print 0 "ERROR: rmt:send-receive-no-auto-client-setup failed, attempting to continue. Got " dat)
;; 	  dat))))

;; Wrap json library for strings (why the ports crap in the first place?)
(define (rmt:dat->json-str dat)
  (with-output-to-string 
    (lambda ()
      (json-write dat))))

(define (rmt:json-str->dat json-str)
  (with-input-from-string json-str
    (lambda ()
      (json-read))))

;;======================================================================
;;
;; A C T U A L   A P I   C A L L S  
;;
;;======================================================================

;;======================================================================
;;  S E R V E R
;;======================================================================

(define (rmt:kill-server run-id)
  (rmt:send-receive 'kill-server run-id (list run-id)))

(define (rmt:start-server run-id)
  (rmt:send-receive 'start-server 0 (list run-id)))

;;======================================================================
;;  M I S C
;;======================================================================

(define (rmt:login run-id)
  (rmt:send-receive 'login run-id (list *toppath* megatest-version run-id *my-client-signature*)))

;; This login does no retries under the hood - it acts a bit like a ping.
;; Deprecated for nmsg-transport.
;;
(define (rmt:login-no-auto-client-setup connection-info run-id)
  (case *transport-type*
    ((http)(rmt:send-receive-no-auto-client-setup connection-info 'login run-id (list *toppath* megatest-version run-id *my-client-signature*)))
    ((nmsg)(nmsg-transport:client-api-send-receive run-id connection-info 'login (list *toppath* megatest-version run-id *my-client-signature*)))))

;; hand off a call to one of the db:queries statements
;; added run-id to make looking up the correct db possible 
;;
(define (rmt:general-call stmtname run-id . params)
  (rmt:send-receive 'general-call run-id (append (list stmtname run-id) params)))

(define (rmt:sync-inmem->db run-id)
  (rmt:send-receive 'sync-inmem->db run-id '()))

(define (rmt:sdb-qry qry val run-id)
  ;; add caching if qry is 'getid or 'getstr
  (rmt:send-receive 'sdb-qry run-id (list qry val)))

;; NOT COMPLETED
(define (rmt:runtests user run-id testpatt params)
  (rmt:send-receive 'runtests run-id testpatt))

;;======================================================================
;;  K E Y S 
;;======================================================================

;; These require run-id because the values come from the run!
;;
(define (rmt:get-key-val-pairs run-id)
  (rmt:send-receive 'get-key-val-pairs run-id (list run-id)))

(define (rmt:get-keys)
  (rmt:send-receive 'get-keys #f '()))

;;======================================================================
;;  T E S T S
;;======================================================================

(define (rmt:get-test-id run-id testname item-path)
  (rmt:send-receive 'get-test-id run-id (list run-id testname item-path)))

(define (rmt:get-test-info-by-id run-id test-id)
  (if (and (number? run-id)(number? test-id))
      (rmt:send-receive 'get-test-info-by-id run-id (list run-id test-id))
      (begin
	(debug:print 0 "WARNING: Bad data handed to rmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id)
	(print-call-chain (current-error-port))
	#f)))

(define (rmt:test-get-rundir-from-test-id run-id test-id)
  (rmt:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id)))

(define (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f))
  (let* ((test-path (if (string? work-area)
			work-area
			(rmt:test-get-rundir-from-test-id run-id test-id))))
    (debug:print 3 "TEST PATH: " test-path)
    (open-test-db test-path)))

;; WARNING: This currently bypasses the transaction wrapped writes system
(define (rmt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment)
  (rmt:send-receive 'test-set-state-status-by-id run-id (list run-id test-id newstate newstatus newcomment)))

(define (rmt:set-tests-state-status run-id testnames currstate currstatus newstate newstatus)
  (rmt:send-receive 'set-tests-state-status run-id (list run-id testnames currstate currstatus newstate newstatus)))

(define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals)
  (if (number? run-id)
      (rmt:send-receive 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals))
      (begin
	(debug:print "ERROR: rmt:get-tests-for-run called with bad run-id=" run-id)
	(print-call-chain (current-error-port))
	'())))

;; get stuff via synchash 
(define (rmt:synchash-get run-id proc synckey keynum params)
  (rmt:send-receive 'synchash-get run-id (list run-id proc synckey keynum params)))

;; IDEA: Threadify these - they spend a lot of time waiting ...
;;
(define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in)
  (let ((multi-run-mutex (make-mutex))
	(run-id-list (if run-ids
			 run-ids
			 (rmt:get-all-run-ids)))
	(result      '()))
    (if (null? run-id-list)
	'()
	(let loop ((hed     (car run-id-list))
		   (tal     (cdr run-id-list))
		   (threads '()))
	  (if (> (length threads) 5)
	      (loop hed tal (filter (lambda (th)(not (member (thread-state th) '(terminated dead)))) threads))
	      (let* ((newthread (make-thread
				 (lambda ()
				   (let ((res (rmt:send-receive 'get-tests-for-run-mindata hed (list hed testpatt states status not-in))))
				     (if (list? res)
					 (begin
					   (mutex-lock! multi-run-mutex)
					   (set! result (append result res))
					   (mutex-unlock! multi-run-mutex))
					 (debug:print 0 "ERROR: 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.5) ;; 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 ...
;; ;;
;; (define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in)
;;   (let ((run-id-list (if run-ids
;; 			 run-ids
;; 			 (rmt:get-all-run-ids))))
;;     (apply append (map (lambda (run-id)
;; 			 (rmt:send-receive 'get-tests-for-run-mindata run-id (list run-ids testpatt states status not-in)))
;; 		       run-id-list))))

(define (rmt:delete-test-records run-id test-id)
  (rmt:send-receive 'delete-test-records run-id (list run-id test-id)))

;; This is not needed as test steps are deleted on test delete call
;;
;; (define (rmt:delete-test-step-records run-id test-id)
;;   (rmt:send-receive 'delete-test-step-records run-id (list run-id test-id)))

(define (rmt:test-set-status-state run-id test-id status state msg)
  (rmt:send-receive 'test-set-status-state run-id (list run-id test-id status state msg)))

(define (rmt:test-toplevel-num-items run-id test-name)
  (rmt:send-receive 'test-toplevel-num-items run-id (list run-id test-name)))

;; (define (rmt:get-previous-test-run-record run-id test-name item-path)
;;   (rmt:send-receive 'get-previous-test-run-record run-id (list run-id test-name item-path)))

(define (rmt:get-matching-previous-test-run-records run-id test-name item-path)
  (rmt:send-receive 'get-matching-previous-test-run-records run-id (list run-id test-name item-path)))

(define (rmt:test-get-logfile-info run-id test-name)
  (rmt:send-receive 'test-get-logfile-info run-id (list run-id test-name)))

(define (rmt:test-get-records-for-index-file run-id test-name)
  (rmt:send-receive 'test-get-records-for-index-file run-id (list run-id test-name)))

(define (rmt:get-testinfo-state-status run-id test-id)
  (rmt:send-receive 'get-testinfo-state-status run-id (list run-id test-id)))

(define (rmt:test-set-log! run-id test-id logf)
  (if (string? logf)(rmt:general-call 'test-set-log run-id logf test-id)))

(define (rmt:test-set-top-process-pid run-id test-id pid)
  (rmt:send-receive 'test-set-top-process-pid run-id (list run-id test-id pid)))

(define (rmt:test-get-top-process-pid run-id test-id)
  (rmt:send-receive 'test-get-top-process-pid run-id (list run-id test-id)))

(define (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt)
  (rmt:send-receive 'get-run-ids-matching-target #f (list keynames target res runname testpatt statepatt statuspatt)))

;; NOTE: This will open and access ALL run databases. 
;;
(define (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname)
  (let ((run-ids (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt)))
    (apply append 
	   (map (lambda (run-id)
		  (rmt:send-receive 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname)))
	   run-ids))))

(define (rmt:get-run-ids-matching keynames target res)
  (rmt:send-receive #f 'get-run-ids-matching (list keynames target res)))

(define (rmt:get-prereqs-not-met run-id waitons ref-item-path #!key (mode '(normal)))
  (rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-item-path mode)))

(define (rmt:get-count-tests-running-for-run-id run-id)
  (rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id)))

;; Statistical queries

(define (rmt:get-count-tests-running run-id)
  (rmt:send-receive 'get-count-tests-running run-id (list run-id)))

(define (rmt:get-count-tests-running-for-testname run-id testname)
  (rmt:send-receive 'get-count-tests-running-for-testname run-id (list run-id testname)))

(define (rmt:get-count-tests-running-in-jobgroup run-id jobgroup)
  (rmt:send-receive 'get-count-tests-running-in-jobgroup run-id (list run-id jobgroup)))

(define (rmt:roll-up-pass-fail-counts run-id test-name item-path status)
  (rmt:send-receive 'roll-up-pass-fail-counts run-id (list run-id test-name item-path status)))

(define (rmt:update-pass-fail-counts run-id test-name)
  (rmt:general-call 'update-fail-pass-counts run-id (list run-id test-name run-id test-name run-id test-name)))

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

(define (rmt:get-run-info run-id)
  (rmt:send-receive 'get-run-info run-id (list run-id)))

;; Use the special run-id == #f scenario here since there is no run yet
(define (rmt:register-run keyvals runname state status user)
  (rmt:send-receive 'register-run #f (list keyvals runname state status user)))
    
(define (rmt:get-run-name-from-id run-id)
  (rmt:send-receive 'get-run-name-from-id run-id (list run-id)))

(define (rmt:delete-run run-id)
  (rmt:send-receive 'delete-run run-id (list run-id)))

(define (rmt:delete-old-deleted-test-records)
  (rmt:send-receive 'delete-old-deleted-test-records #f '()))

(define (rmt:get-runs runpatt count offset keypatts)
  (rmt:send-receive 'get-runs #f (list runpatt count offset keypatts)))

(define (rmt:get-runs runpatt count offset keypatts)
  (rmt:send-receive 'get-runs #f (list runpatt count offset keypatts)))

(define (rmt:get-all-run-ids)
  (rmt:send-receive 'get-all-run-ids #f '()))

(define (rmt:get-prev-run-ids run-id)
  (rmt:send-receive 'get-prev-run-ids #f (list run-id)))

(define (rmt:lock/unlock-run run-id lock unlock user)
  (rmt:send-receive 'lock/unlock-run #f (list run-id lock unlock user)))

;; set/get status
(define (rmt:get-run-status run-id)
  (rmt:send-receive 'get-run-status #f (list run-id)))

(define (rmt:set-run-status run-id run-status #!key (msg #f))
  (rmt:send-receive 'set-run-status #f (list run-id run-status msg)))

(define (rmt:update-run-event_time run-id)
  (rmt:send-receive 'update-run-event_time #f (list run-id)))

(define (rmt:get-runs-by-patt  keys runnamepatt targpatt offset limit)
  (rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit)))

(define (rmt:find-and-mark-incomplete run-id ovr-deadtime)
  (if (rmt:send-receive 'have-incompletes? run-id (list run-id ovr-deadtime))
      (rmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime))))

;;======================================================================
;; M U L T I R U N   Q U E R I E S
;;======================================================================

;; Need to move this to multi-run section and make associated changes
(define (rmt:find-and-mark-incomplete-all-runs #!key (ovr-deadtime #f))
  (let ((run-ids (rmt:get-all-run-ids)))
    (for-each (lambda (run-id)
	       (rmt:find-and-mark-incomplete run-id ovr-deadtime))
	     run-ids)))

;; get the previous record for when this test was run where all keys match but runname
;; returns #f if no such test found, returns a single test record if found
;; 
;; Run this at the client end since we have to connect to multiple run-id dbs
;;
(define (rmt:get-previous-test-run-record run-id test-name item-path)
  (let* ((keyvals (rmt:get-key-val-pairs run-id))
	 (keys    (rmt:get-keys))
	 (selstr  (string-intersperse  keys ","))
	 (qrystr  (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")))
    (if (not keyvals)
	#f
	(let ((prev-run-ids (rmt:get-prev-run-ids run-id)))
	  ;; for each run starting with the most recent look to see if there is a matching test
	  ;; if found then return that matching test record
	  (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids)
	  (if (null? prev-run-ids) #f
	      (let loop ((hed (car prev-run-ids))
			 (tal (cdr prev-run-ids)))
		(let ((results (rmt:get-tests-for-run hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f)))
		  (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results)
		  (if (and (null? results)
			   (not (null? tal)))
		      (loop (car tal)(cdr tal))
		      (if (null? results) #f
			  (car results))))))))))

;;======================================================================
;;  S T E P S
;;======================================================================

;; Getting steps is more complicated.
;;
;; If given work area 
;;  1. Find the testdat.db file
;;  2. Open the testdat.db file and do the query
;; If not given the work area
;;  1. Do a remote call to get the test path
;;  2. Continue as above
;; 
;;(define (rmt:get-steps-for-test run-id test-id)
;;  (rmt:send-receive 'get-steps-data run-id (list test-id)))

(define (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile)
  (let* ((state     (items:check-valid-items "state" state-in))
	 (status    (items:check-valid-items "status" status-in)))
    (if (or (not state)(not status))
	(debug:print 3 "WARNING: Invalid " (if status "status" "state")
		     " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config"))
    (rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile))))

(define (rmt:get-steps-for-test run-id test-id)
  (rmt:send-receive 'get-steps-for-test run-id (list run-id test-id)))

;;======================================================================
;;  T E S T   D A T A 
;;======================================================================

(define (rmt:read-test-data run-id test-id categorypatt #!key (work-area #f)) 
  (let ((tdb  (rmt:open-test-db-by-test-id run-id test-id work-area: work-area)))
    (if tdb
	(tdb:read-test-data tdb test-id categorypatt)
	'())))

(define (rmt:testmeta-add-record testname)
  (rmt:send-receive 'testmeta-add-record #f (list testname)))

(define (rmt:testmeta-get-record testname)
  (rmt:send-receive 'testmeta-get-record #f (list testname)))

(define (rmt:testmeta-update-field test-name fld val)
  (rmt:send-receive 'testmeta-update-field #f (list test-name fld val)))

(define (rmt:test-data-rollup run-id test-id status)
  (rmt:send-receive 'test-data-rollup run-id (list run-id test-id status)))

(define (rmt:csv->test-data run-id test-id csvdata)
  (rmt:send-receive 'csv->test-data run-id (list run-id test-id csvdata)))

;;======================================================================
;;  T A S K S
;;======================================================================

(define (rmt:tasks-find-task-queue-records target run-name test-patt state-patt action-patt)
  (rmt:send-receive 'find-task-queue-records #f (list target run-name test-patt state-patt action-patt)))

(define (rmt:tasks-add action owner target runname testpatt params)
  (rmt:send-receive 'tasks-add #f (list action owner target runname testpatt params)))

(define (rmt:tasks-set-state-given-param-key param-key new-state)
  (rmt:send-receive 'tasks-set-state-given-param-key #f (list  param-key new-state)))

;;======================================================================
;; A R C H I V E S
;;======================================================================

(define (rmt:archive-get-allocations  testname itempath dneeded)
  (rmt:send-receive 'archive-get-allocations #f (list testname itempath dneeded)))

(define (rmt:archive-register-block-name bdisk-id archive-path)
  (rmt:send-receive 'archive-register-block-name #f (list bdisk-id archive-path)))

(define (rmt:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey)
  (rmt:send-receive 'archive-allocate-test-to-block #f (list  block-id testsuite-name areakey)))

(define (rmt:archive-register-disk bdisk-name bdisk-path df)
  (rmt:send-receive 'archive-register-disk #f (list bdisk-name bdisk-path df)))

(define (rmt:test-set-archive-block-id run-id test-id archive-block-id)
  (rmt:send-receive 'test-set-archive-block-id run-id (list run-id test-id archive-block-id)))

(define (rmt:test-get-archive-block-info archive-block-id)
  (rmt:send-receive 'test-get-archive-block-info #f (list archive-block-id)))

Added rmtdb.scm version [afdb905959].























>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
;;======================================================================
;; Copyright 2006-2013, 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.
;;======================================================================

Added rpc-transport.scm version [1e1f685d67].





































































































































































































































































































































































































































































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

;; Copyright 2006-2012, 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.

(require-extension (srfi 18) extras tcp s11n rpc)
(import (prefix rpc rpc:))

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

(declare (unit rpc-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")

;; procstr is the name of the procedure to be called as a string
(define (rpc-transport:autoremote procstr params)
  (handle-exceptions
   exn
   (begin
     (debug:print 1 "Remote failed for " proc " " params)
     (apply (eval (string->symbol procstr)) params))
   ;; (if *runremote*
   ;;    (apply (eval (string->symbol (conc "remote:" procstr))) params)
   (apply (eval (string->symbol procstr)) params)))

;; all routes though here end in exit ...
;;
;; start_server? 
;;
(define (rpc-transport:launch run-id)
  (set! *run-id*   run-id)
  (if (args:get-arg "-daemonize")
      (daemon:ize))
  (if (server:check-if-running run-id)
      (begin
	(debug:print 0 "INFO: Server for run-id " run-id " already running")
	(exit 0)))
  (let loop ((server-id (open-run-close tasks:server-lock-slot tasks:open-db run-id))
	     (remtries  4))
    (if (not server-id)
	(if (> remtries 0)
	    (begin
	      (thread-sleep! 2)
	      (loop (open-run-close tasks:server-lock-slot tasks:open-db run-id)
		    (- remtries 1)))
	    (begin
	      ;; since we didn't get the server lock we are going to clean up and bail out
	      (debug:print-info 2 "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue")
	      (open-run-close tasks:server-delete-records-for-this-pid tasks:open-db " rpc-transport:launch")))
	(begin
	  (rpc-transport:run (if (args:get-arg "-server")(args:get-arg "-server") "-") run-id server-id)
	  (exit)))))

(define (rpc-transport:run hostn run-id server-id)
  (debug:print 2 "Attempting to start the rpc server ...")
   ;; (trace rpc:publish-procedure!)

  (rpc:publish-procedure! 'server:login server:login)
  (rpc:publish-procedure! 'testing (lambda () "Just testing"))

  (let* ((db              #f)
	 (hostname        (get-host-name))
	 (ipaddrstr       (let ((ipstr (if (string=? "-" hostn)
					   ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
					   (server:get-best-guess-address hostname)
					   #f)))
			    (if ipstr ipstr hostn))) ;; hostname))) 
	 (start-port      (open-run-close tasks:server-get-next-port tasks:open-db))
	 (link-tree-path  (configf:lookup *configdat* "setup" "linktree"))
	 (rpc:listener    (rpc-transport:find-free-port-and-open (rpc:default-server-port)))
	 (th1             (make-thread
			   (lambda ()
			     ((rpc:make-server rpc:listener) #t))
			   "rpc:server"))
			   ;; (cute (rpc:make-server rpc:listener) "rpc:server")
			   ;; 'rpc:server))
	 (hostname        (if (string=? "-" hostn)
			      (get-host-name) 
			      hostn))
	 (ipaddrstr       (if (string=? "-" hostn)
			      (server:get-best-guess-address hostname) ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
			      #f))
	 (portnum         (rpc:default-server-port))
	 (host:port       (conc (if ipaddrstr ipaddrstr hostname) ":" portnum))
	 (tdb             (tasks:open-db)))
    (thread-start! th1)
    (set! db *inmemdb*)
    (open-run-close tasks:server-set-interface-port 
		    tasks:open-db 
		    server-id 
		    ipaddrstr portnum)
    (debug:print 0 "Server started on " host:port)
    
    ;; (trace rpc:publish-procedure!)
    ;; (rpc:publish-procedure! 'server:login server:login)
    ;; (rpc:publish-procedure! 'testing (lambda () "Just testing"))

    ;;======================================================================
    ;;	  ;; end of publish-procedure section
    ;;======================================================================
    ;;
    (on-exit (lambda ()
	       (open-run-close tasks:server-set-state! tasks:open-db server-id "stopped")))

    (set! *rpc:listener* rpc:listener)
    (tasks:server-set-state! tdb server-id "running")
    (set! *inmemdb*  (db:setup run-id))
    ;; if none running or if > 20 seconds since 
    ;; server last used then start shutdown
    (let loop ((count 0))
      (thread-sleep! 5) ;; no need to do this very often
      (let ((numrunning -1)) ;; (db:get-count-tests-running db)))
	(if (or (> numrunning 0)
		(> (+ *last-db-access* 60)(current-seconds)))
	    (begin
	      (debug:print-info 0 "Server continuing, tests running: " numrunning ", seconds since last db access: " (- (current-seconds) *last-db-access*))
	      (loop (+ 1 count)))
	    (begin
	      (debug:print-info 0 "Starting to shutdown the server side")
	      (open-run-close tasks:server-delete-record tasks:open-db server-id " rpc-transport:try-start-server stop")
	      (thread-sleep! 10)
	      (debug:print-info 0 "Max cached queries was " *max-cache-size*)
	      (debug:print-info 0 "Server shutdown complete. Exiting")
	      ))))))

(define (rpc-transport:find-free-port-and-open port)
  (handle-exceptions
   exn
	  (begin
     (print "Failed to bind to port " (rpc:default-server-port) ", trying next port")
     (rpc-transport:find-free-port-and-open (+ port 1)))
   (rpc:default-server-port port)
   (tcp-read-timeout 240000)
   (tcp-listen (rpc:default-server-port) 10000)))

(define (rpc-transport:ping run-id host port)
  (handle-exceptions
   exn
   (begin
     (print "SERVER_NOT_FOUND")
     (exit 1))
   (let ((login-res ((rpc:procedure 'server:login host port) *toppath*)))
     (if (and (list? login-res)
	      (car login-res))
	 (begin
	   (print "LOGIN_OK")
	   (exit 0))
	 (begin
	   (print "LOGIN_FAILED")
	   (exit 1))))))

(define (rpc-transport:client-setup run-id #!key (remtries 10))
  (if *runremote*
      (begin
	(debug:print 0 "ERROR: Attempt to connect to server but already connected")
	#f)
      (let* ((host-info (hash-table-ref/default *runremote* run-id #f))) ;; (open-run-close db:get-var #f "SERVER"))
	(if host-info
	    (let ((iface    (car host-info))
		  (port     (cadr host-info))
		  (ping-res ((rpc:procedure 'server:login host port) *toppath*)))
	      (if ping-res
		  (let ((server-dat (list iface port #f #f #f)))
		    (hash-table-set! *runremote* run-id server-dat)
		    server-dat)
		  (begin
		    (server:try-running run-id)
		    (thread-sleep! 2)
		    (rpc-transport:client-setup run-id (- remtries 1)))))
 	    (let* ((server-db-info (open-run-close tasks:get-server tasks:open-db run-id)))
 	      (debug:print-info 0 "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries)
	      (if server-db-info
 		  (let* ((iface     (tasks:hostinfo-get-interface server-db-info))
 			 (port      (tasks:hostinfo-get-port      server-db-info))
			 (server-dat (list iface port #f #f #f))
 			 (ping-res  ((rpc:procedure 'server:login host port) *toppath*)))
 		    (if start-res
 			(begin
 			  (hash-table-set! *runremote* run-id server-dat)
			  server-dat)
			(begin
			  (server:try-running run-id)
			  (thread-sleep! 2)
			  (rpc-transport:client-setup run-id (- remtries 1)))))
		  (begin
		    (server:try-running run-id)
		    (thread-sleep! 2)
		    (rpc-transport:client-setup run-id (- remtries 1)))))))))
;; 
;; 	     (port     (if (and hostinfo (> (length hostdat) 1))(cadr hostdat) #f)))
;; 	(if (and port
;; 		 (string->number port))
;; 	    (let ((portn (string->number port)))
;; 	      (debug:print-info 2 "Setting up to connect to host " host ":" port)
;; 	      (handle-exceptions
;; 	       exn
;; 	       (begin
;; 		 (debug:print 0 "ERROR: Failed to open a connection to the server at host: " host " port: " port)
;; 		 (debug:print 0 "   EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
;; 		 ;; (open-run-close 
;; 		 ;;  (lambda (db . param) 
;; 		 ;;    (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER'"))
;; 		 ;;  #f)
;; 		 (set! *runremote* #f))
;; 	       (if (and (not (args:get-arg "-server")) ;; no point in the server using the server using the server
;; 			((rpc:procedure 'server:login host portn) *toppath*))
;; 		   (begin
;; 		     (debug:print-info 2 "Logged in and connected to " host ":" port)
;; 		     (set! *runremote* (vector host portn)))
;; 		   (begin
;; 		     (debug:print-info 2 "Failed to login or connect to " host ":" port)
;; 		     (set! *runremote* #f)))))
;; 	    (debug:print-info 2 "no server available")))))

Modified runconfig.scm from [f1fb75b972] to [d97360c67a].

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
	 (sections (list "default" thekey)))
    (if (not *target*)(set! *target* thekey)) ;; may save a db access or two but repeats db:get-target code
    (debug:print 4 "Using key=\"" thekey "\"")

    (if change-env
	(for-each ;; NB// This can be simplified with new content of keyvals having all that is needed.
	 (lambda (keyval)
	   (setenv (car keyval)(cadr keyval)))
	 keyvals))
	
    (for-each 
     (lambda (section)
       (let ((section-dat (hash-table-ref/default confdat section #f)))
	 (if section-dat
	     (for-each 
	      (lambda (envvar)
		(let ((val (cadr (assoc envvar section-dat))))
		(hash-table-set! whatfound section (+ (hash-table-ref/default whatfound section 0) 1))
		(if (and (string? envvar)
			 (string? val)
			 change-env)
		    (setenv envvar val))
		(hash-table-set! finaldat envvar val)))
	      (map car section-dat)))))
     sections)
    (if already-seen
	(begin
	  (debug:print 2 "Key settings found in runconfig.config:")
	  (for-each (lambda (fullkey)







|













|







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
	 (sections (list "default" thekey)))
    (if (not *target*)(set! *target* thekey)) ;; may save a db access or two but repeats db:get-target code
    (debug:print 4 "Using key=\"" thekey "\"")

    (if change-env
	(for-each ;; NB// This can be simplified with new content of keyvals having all that is needed.
	 (lambda (keyval)
	   (safe-setenv (car keyval)(cadr keyval)))
	 keyvals))
	
    (for-each 
     (lambda (section)
       (let ((section-dat (hash-table-ref/default confdat section #f)))
	 (if section-dat
	     (for-each 
	      (lambda (envvar)
		(let ((val (cadr (assoc envvar section-dat))))
		(hash-table-set! whatfound section (+ (hash-table-ref/default whatfound section 0) 1))
		(if (and (string? envvar)
			 (string? val)
			 change-env)
		    (safe-setenv envvar val))
		(hash-table-set! finaldat envvar val)))
	      (map car section-dat)))))
     sections)
    (if already-seen
	(begin
	  (debug:print 2 "Key settings found in runconfig.config:")
	  (for-each (lambda (fullkey)

Modified runs.scm from [75aee75df2] to [61baf1971a].

17
18
19
20
21
22
23


24
25
26
27
28
29
30
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
(declare (uses server))
(declare (uses mt))



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








>
>







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

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
	  (toppath     *toppath*)
	  (envdat      keyvals) ;; initial values start with keyvals
	  (runconfig   #f)
	  (serverdat   (if (args:get-arg "-server")
			   *runremote*
			   #f)) ;; to be used later
	  (transport   (or (args:get-arg "-transport") 'http))
	  (db          (if (and mconfig
				(or (args:get-arg "-server")
				    (eq? transport 'fs)))
			   (open-db)
			   #f))
	  (run-id      #f))
    ;; Set all the environment vars we know so far, start with keys
    (for-each (lambda (keyval)
		(setenv (car keyval)(cadr keyval)))
	      keyvals)
    ;; Set up various and sundry known vars here
    (setenv "MT_RUN_AREA_HOME" toppath)
    (setenv "MT_RUNNAME" runname)
    (setenv "MT_TARGET"  target)

    (set! envdat (append 
		  envdat
		  (list (list "MT_RUN_AREA_HOME" toppath)
			(list "MT_RUNNAME"       runname)
			(list "MT_TARGET"        target))))
    ;; Now can read the runconfigs file
    ;; 
    (set! runconfig (read-config (conc  *toppath* "/runconfigs.config") #f #t sections: (list "default" target)))
    (if (not (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f))
	(begin
	  (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf)
	  (if db (sqlite3:finalize! db))
	  (exit 1)))
    ;; Now have runconfigs data loaded, set environment vars
    (for-each (lambda (section)
		(for-each (lambda (varval)
			    (set! envdat (append envdat (list varval)))
			    (setenv (car varval)(cadr varval)))
			  (configf:get-section runconfig section)))
	      (list "default" target))
    (vector target runname testpatt keys keyvals envdat mconfig runconfig serverdat transport db toppath run-id)))

(define (runs:set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f))
  (let* ((target    (or (common:args-get-target)
			(get-environment-variable "MT_TARGET")))
	 (keys      (if inkeys    inkeys    (cdb:remote-run db:get-keys #f)))
	 (keyvals   (if inkeyvals inkeyvals (keys:target->keyval keys target)))
	 (vals      (hash-table-ref/default *env-vars-by-run-id* run-id #f))
	 (link-tree (configf:lookup *configdat* "setup" "linktree")))
    ;; get the info from the db and put it in the cache
    (if link-tree
	(setenv "MT_LINKTREE" link-tree)
	(debug:print 0 "ERROR: linktree not set, should be set in megatest.config in [setup] section."))
    (if (not vals)
	(let ((ht (make-hash-table)))
	  (hash-table-set! *env-vars-by-run-id* run-id ht)
	  (set! vals ht)
	  (for-each
	   (lambda (key)
	     (hash-table-set! vals (car key) (cadr key))) ;; (cdb:remote-run db:get-run-key-val #f run-id (car key))))
	   keyvals)))
    ;; from the cached data set the vars
    (hash-table-for-each
     vals
     (lambda (key val)
       (debug:print 2 "setenv " key " " val)
       (if (and (string? key)
		(string? val))
	   (setenv key val)
	   (debug:print 0 "ERROR: Malformed environment variable definition: var=" var ", val=" val))))
    (if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target))
    (alist->env-vars (hash-table-ref/default *configdat* "env-override" '()))
    ;; Lets use this as an opportunity to put MT_RUNNAME in the environment


    (setenv "MT_RUNNAME" (if inrunname inrunname (cdb:remote-run db:get-run-name-from-id #f run-id)))

    (setenv "MT_RUN_AREA_HOME" *toppath*)))

(define (set-item-env-vars itemdat)
  (for-each (lambda (item)
	      (debug:print 2 "setenv " (car item) " " (cadr item))
	      (setenv (car item) (cadr item)))
	    itemdat))

;; Every time can-run-more-tests is called increment the delay
;;
;; NOTE: We run this server-side!! Do not use this global except in the runs:can-run-more-tests routine
;;
(define *last-num-running-tests* 0)
(define *runs:can-run-more-tests-count* 0)
(define (runs:shrink-can-run-more-tests-count) ;; the db is a dummy var so we can use cdb:remote-run
  (set! *runs:can-run-more-tests-count* 0)) ;; (/ *runs:can-run-more-tests-count* 2)))

;; Temporary globals. Move these into the logic or into common
;;
(define *seen-cant-run-tests* (make-hash-table)) ;; use to track tests that we suspect cannot be run
(define (runs:inc-cant-run-tests testname)
  (hash-table-set! *seen-cant-run-tests* testname
		   (+ (hash-table-ref/default *seen-cant-run-tests* testname 0) 1)))

(define (runs:can-keep-running? testname n)
  (< (hash-table-ref/default *seen-cant-run-tests* testname 0) n))

(define *runs:denoise* (make-hash-table)) ;; key => last-time-ran

(define (runs:lownoise key waitval)
  (let ((lasttime (hash-table-ref/default *runs:denoise* key 0))
	(currtime (current-seconds)))
    (if (> (- currtime lasttime) waitval)
	(begin
	  (hash-table-set! *runs:denoise* key currtime)
	  #t)
	#f)))

(define (runs:can-run-more-tests jobgroup max-concurrent-jobs)
  (thread-sleep! (cond
		  ((> *runs:can-run-more-tests-count* 20) 2);; obviously haven't had any work to do for a while



		  (else 0)))
  (let* ((num-running             (cdb:remote-run db:get-count-tests-running #f))
	 (num-running-in-jobgroup (cdb:remote-run db:get-count-tests-running-in-jobgroup #f jobgroup))
	 (job-group-limit         (let ((jobg-count (config-lookup *configdat* "jobgroups" jobgroup)))
				    (if (string? jobg-count)
					(string->number jobg-count)
					jobg-count))))
    (if (> (+ num-running num-running-in-jobgroup) 0)
	(set! *runs:can-run-more-tests-count* (+ *runs:can-run-more-tests-count* 1)))
    (if (not (eq? *last-num-running-tests* num-running))







<
<
<
<
<









>

















|







|













|






<
<
|
<



>
>
|
>














|








>














|

|
>
>
>
|
|
|







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
	  (toppath     *toppath*)
	  (envdat      keyvals) ;; initial values start with keyvals
	  (runconfig   #f)
	  (serverdat   (if (args:get-arg "-server")
			   *runremote*
			   #f)) ;; to be used later
	  (transport   (or (args:get-arg "-transport") 'http))





	  (run-id      #f))
    ;; Set all the environment vars we know so far, start with keys
    (for-each (lambda (keyval)
		(setenv (car keyval)(cadr keyval)))
	      keyvals)
    ;; Set up various and sundry known vars here
    (setenv "MT_RUN_AREA_HOME" toppath)
    (setenv "MT_RUNNAME" runname)
    (setenv "MT_TARGET"  target)
    (setenv "MT_TESTSUITENAME" (common:get-testsuite-name))
    (set! envdat (append 
		  envdat
		  (list (list "MT_RUN_AREA_HOME" toppath)
			(list "MT_RUNNAME"       runname)
			(list "MT_TARGET"        target))))
    ;; Now can read the runconfigs file
    ;; 
    (set! runconfig (read-config (conc  *toppath* "/runconfigs.config") #f #t sections: (list "default" target)))
    (if (not (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f))
	(begin
	  (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf)
	  (if db (sqlite3:finalize! db))
	  (exit 1)))
    ;; Now have runconfigs data loaded, set environment vars
    (for-each (lambda (section)
		(for-each (lambda (varval)
			    (set! envdat (append envdat (list varval)))
			    (safe-setenv (car varval)(cadr varval)))
			  (configf:get-section runconfig section)))
	      (list "default" target))
    (vector target runname testpatt keys keyvals envdat mconfig runconfig serverdat transport db toppath run-id)))

(define (runs:set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f))
  (let* ((target    (or (common:args-get-target)
			(get-environment-variable "MT_TARGET")))
	 (keys    (if inkeys    inkeys    (rmt:get-keys)))
	 (keyvals   (if inkeyvals inkeyvals (keys:target->keyval keys target)))
	 (vals      (hash-table-ref/default *env-vars-by-run-id* run-id #f))
	 (link-tree (configf:lookup *configdat* "setup" "linktree")))
    ;; get the info from the db and put it in the cache
    (if link-tree
	(setenv "MT_LINKTREE" link-tree)
	(debug:print 0 "ERROR: linktree not set, should be set in megatest.config in [setup] section."))
    (if (not vals)
	(let ((ht (make-hash-table)))
	  (hash-table-set! *env-vars-by-run-id* run-id ht)
	  (set! vals ht)
	  (for-each
	   (lambda (key)
	     (hash-table-set! vals (car key) (cadr key)))
	   keyvals)))
    ;; from the cached data set the vars
    (hash-table-for-each
     vals
     (lambda (key val)
       (debug:print 2 "setenv " key " " val)


       (safe-setenv key val)))

    (if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target))
    (alist->env-vars (hash-table-ref/default *configdat* "env-override" '()))
    ;; Lets use this as an opportunity to put MT_RUNNAME in the environment
    (let ((runname  (if inrunname inrunname (rmt:get-run-name-from-id run-id))))
      (if runname
	  (setenv "MT_RUNNAME" runname)
	  (debug:print 0 "ERROR: no value for runname for id " run-id)))
    (setenv "MT_RUN_AREA_HOME" *toppath*)))

(define (set-item-env-vars itemdat)
  (for-each (lambda (item)
	      (debug:print 2 "setenv " (car item) " " (cadr item))
	      (setenv (car item) (cadr item)))
	    itemdat))

;; Every time can-run-more-tests is called increment the delay
;;
;; NOTE: We run this server-side!! Do not use this global except in the runs:can-run-more-tests routine
;;
(define *last-num-running-tests* 0)
(define *runs:can-run-more-tests-count* 0)
(define (runs:shrink-can-run-more-tests-count)
  (set! *runs:can-run-more-tests-count* 0)) ;; (/ *runs:can-run-more-tests-count* 2)))

;; Temporary globals. Move these into the logic or into common
;;
(define *seen-cant-run-tests* (make-hash-table)) ;; use to track tests that we suspect cannot be run
(define (runs:inc-cant-run-tests testname)
  (hash-table-set! *seen-cant-run-tests* testname
		   (+ (hash-table-ref/default *seen-cant-run-tests* testname 0) 1)))

(define (runs:can-keep-running? testname n)
  (< (hash-table-ref/default *seen-cant-run-tests* testname 0) n))

(define *runs:denoise* (make-hash-table)) ;; key => last-time-ran

(define (runs:lownoise key waitval)
  (let ((lasttime (hash-table-ref/default *runs:denoise* key 0))
	(currtime (current-seconds)))
    (if (> (- currtime lasttime) waitval)
	(begin
	  (hash-table-set! *runs:denoise* key currtime)
	  #t)
	#f)))

(define (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)
  (thread-sleep! (cond
        	  ((> *runs:can-run-more-tests-count* 20)
		   (if (runs:lownoise "waiting on tasks" 60)
		       (debug:print-info 2 "waiting for tasks to complete, sleeping briefly ..."))
		   2);; obviously haven't had any work to do for a while
        	  (else 0)))
  (let* ((num-running             (rmt:get-count-tests-running run-id))
	 (num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup run-id jobgroup))
	 (job-group-limit         (let ((jobg-count (config-lookup *configdat* "jobgroups" jobgroup)))
				    (if (string? jobg-count)
					(string->number jobg-count)
					jobg-count))))
    (if (> (+ num-running num-running-in-jobgroup) 0)
	(set! *runs:can-run-more-tests-count* (+ *runs:can-run-more-tests-count* 1)))
    (if (not (eq? *last-num-running-tests* num-running))
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
				       (>= num-running-in-jobgroup job-group-limit))
				  (if (runs:lownoise (conc "maxjobgroup " jobgroup) 60)
				      (debug:print 1 "WARNING: number of jobs " num-running-in-jobgroup 
						   " in jobgroup \"" jobgroup "\" exceeds limit of " job-group-limit))
				  #t)
				 (else #f))))
	  (list (not can-not-run-more) num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit)))))


;;  test-names: Comma separated patterns same as test-patts but used in selection 
;;              of tests to run. The item portions are not respected.
;;              FIXME: error out if /patt specified
;;            
(define (runs:run-tests target runname test-patts user flags #!key (run-count 3)) ;; test-names
  (common:clear-caches) ;; clear all caches
  (let* ((keys               (keys:config-get-fields *configdat*))
	 (keyvals            (keys:target->keyval keys target))
	 (run-id             (cdb:remote-run db:register-run #f keyvals runname "new" "n/a" user))  ;;  test-name)))
	 (deferred          '()) ;; delay running these since they have a waiton clause
	 (runconfigf         (conc  *toppath* "/runconfigs.config"))
	 (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)  ;; (tests:filter-test-names all-test-names test-patts))
	 (required-tests     #f)) ;;(lset-intersection equal? (string-split test-patts ",") test-names))) ;; test-names)) ;; Added test-names as initial for required-tests but that failed to work




    ;; Update the synchronous setting in the db based on the default or what is set by the user
    ;; This is done once here on a call to run tests rather than on every call to open-db
    (cdb:remote-run db:set-sync #f)











    (runs:set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process
    (if (file-exists? runconfigf)
	(setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals target)
	(debug:print 0 "WARNING: You do not have a run config file: " runconfigf))

    ;; Now generate all the tests lists
    (set! all-tests-registry (tests:get-all))







>






<


|







|
>
>

>
|
<
|
>
>
>
>
>
>
>

>
>
>







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
				       (>= num-running-in-jobgroup job-group-limit))
				  (if (runs:lownoise (conc "maxjobgroup " jobgroup) 60)
				      (debug:print 1 "WARNING: number of jobs " num-running-in-jobgroup 
						   " in jobgroup \"" jobgroup "\" exceeds limit of " job-group-limit))
				  #t)
				 (else #f))))
	  (list (not can-not-run-more) num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit)))))


;;  test-names: Comma separated patterns same as test-patts but used in selection 
;;              of tests to run. The item portions are not respected.
;;              FIXME: error out if /patt specified
;;            
(define (runs:run-tests target runname test-patts user flags #!key (run-count 3)) ;; 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))  ;;  test-name)))
	 (deferred          '()) ;; delay running these since they have a waiton clause
	 (runconfigf         (conc  *toppath* "/runconfigs.config"))
	 (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)  ;; (tests:filter-test-names all-test-names test-patts))
	 (required-tests     #f)  ;;(lset-intersection equal? (string-split test-patts ",") test-names))) ;; test-names)) ;; Added test-names as initial for required-tests but that failed to work
	 (task-key           (conc (hash-table->alist flags) " " (get-host-name) " " (current-process-id)))
	 (tdbdat             (tasks:open-db)))

    (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10))


    (set-signal-handler! signal/int
			 (lambda (signum)
			   (signal-mask! signum)
			   (print "Received signal " signum ", cleaning up before exit. Please wait...")
			   (let ((tdbdat (tasks:open-db)))
			     (rmt:tasks-set-state-given-param-key task-key "killed"))
			   (print "Killed by signal " signum ". Exiting")
			   (exit)))

    ;; register this run in monitor.db
    (rmt:tasks-add "run-tests" user target runname test-patts task-key) ;; params)
    (rmt:tasks-set-state-given-param-key task-key "running")
    (runs:set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process
    (if (file-exists? runconfigf)
	(setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals target)
	(debug:print 0 "WARNING: You do not have a run config file: " runconfigf))

    ;; Now generate all the tests lists
    (set! all-tests-registry (tests:get-all))
241
242
243
244
245
246
247



248
249
250
251

252
253





254
255
256
257
258
259
260
    (debug:print-info 0 "all tests:  " (string-intersperse (sort all-test-names string<) " "))
    (debug:print-info 0 "test names: " (string-intersperse (sort test-names string<) " "))

    ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if
    ;; -keepgoing is specified
    (if (eq? *passnum* 0)
	(begin



	  ;; have to delete test records where NOT_STARTED since they can cause -keepgoing to 
	  ;; get stuck due to becoming inaccessible from a failed test. I.e. if test B depends 
	  ;; on test A but test B reached the point on being registered as NOT_STARTED and test
	  ;; A failed for some reason then on re-run using -keepgoing the run can never complete.

	  (cdb:delete-tests-in-state *runremote* run-id "NOT_STARTED")
	  (cdb:remote-run db:set-tests-state-status #f run-id test-names #f "FAIL" "NOT_STARTED" "FAIL")))






    ;; Ensure all tests are registered in the test_meta table
    (runs:update-all-test_meta #f)

    ;; now add non-directly referenced dependencies (i.e. waiton)
    ;;======================================================================
    ;; refactoring this block into tests:get-full-data







>
>
>




>
|
|
>
>
>
>
>







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
    (debug:print-info 0 "all tests:  " (string-intersperse (sort all-test-names string<) " "))
    (debug:print-info 0 "test names: " (string-intersperse (sort test-names string<) " "))

    ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if
    ;; -keepgoing is specified
    (if (eq? *passnum* 0)
	(begin
	  ;; Is this still necessary? I think not. Unreachable tests are marked as such and 
	  ;; should not cause problems here.
	  ;;
	  ;; have to delete test records where NOT_STARTED since they can cause -keepgoing to 
	  ;; get stuck due to becoming inaccessible from a failed test. I.e. if test B depends 
	  ;; on test A but test B reached the point on being registered as NOT_STARTED and test
	  ;; A failed for some reason then on re-run using -keepgoing the run can never complete.
	  ;;
	  ;; (rmt:general-call 'delete-tests-in-state run-id "NOT_STARTED")
	  
	  ;; Now convert FAIL and anything in allow-auto-rerun to NOT_STARTED
	  ;;
	  (for-each (lambda (state)
		      (rmt:set-tests-state-status run-id test-names state #f "NOT_STARTED" state))
		    (string-split (or (configf:lookup *configdat* "setup" "allow-auto-rerun") "")))))

    ;; Ensure all tests are registered in the test_meta table
    (runs:update-all-test_meta #f)

    ;; now add non-directly referenced dependencies (i.e. waiton)
    ;;======================================================================
    ;; refactoring this block into tests:get-full-data
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

    (if (not (null? required-tests))
	(debug:print-info 1 "Adding " required-tests " to the run queue"))
    ;; NOTE: these are all parent tests, items are not expanded yet.
    (debug:print-info 4 "test-records=" (hash-table->alist test-records))
    (let ((reglen (configf:lookup *configdat* "setup" "runqueue")))
      (if (> (length (hash-table-keys test-records)) 0)





	  (begin





	    (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry)


















	    ;; if run-count > 0 call, set -preclean and -rerun STUCK/DEAD
	    (if (> run-count 0)
		(begin
		  (if (not (hash-table-ref/default flags "-preclean" #f))
		      (hash-table-set! flags "-preclean" #t))
		  (if (not (hash-table-ref/default flags "-rerun" #f))
		      (hash-table-set! flags "-rerun" "STUCK/DEAD,n/a,ZERO_ITEMS"))
		  (runs:run-tests target runname test-patts user flags run-count: (- run-count 1)))))
	  (debug:print-info 0 "No tests to run")))
    (debug:print-info 4 "All done by here")


    ))


;; loop logic. These are used in runs:run-tests-queue to make it a bit more readable.
;;
;; If reg not full and have items in tal then loop with (car tal)(cdr tal) reg reruns
;; If reg is full (i.e. length >= n







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










>
>







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

    (if (not (null? required-tests))
	(debug:print-info 1 "Adding " required-tests " to the run queue"))
    ;; NOTE: these are all parent tests, items are not expanded yet.
    (debug:print-info 4 "test-records=" (hash-table->alist test-records))
    (let ((reglen (configf:lookup *configdat* "setup" "runqueue")))
      (if (> (length (hash-table-keys test-records)) 0)
	  (let* ((keep-going        #t)
		 (run-queue-retries 5)
		 (th1        (make-thread (lambda ()
					    (handle-exceptions
					     exn
					     (begin
					       (print-call-chain (current-error-port))
					       (debug:print 0 "ERROR: failure in runs:run-tests-queue thread, error: " ((condition-property-accessor 'exn 'message) exn))
					       (if (> run-queue-retries 0)
						   (begin
						     (set! run-queue-retries (- run-queue-retries 1))
						     (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry))))
					     (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry)))
					  "runs:run-tests-queue"))
		 (th2        (make-thread (lambda ()				    
					    ;; (rmt:find-and-mark-incomplete-all-runs))))) CAN'T INTERRUPT IT ...
					    (let ((run-ids (rmt:get-all-run-ids)))
					      (for-each (lambda (run-id)
							  (if keep-going
							      (handle-exceptions
							       exn
							       (debug:print 0 "error in calling find-and-mark-incomplete for run-id " run-id)
							       (rmt:find-and-mark-incomplete run-id #f)))) ;; ovr-deadtime)))
							run-ids)))
					  "runs: mark-incompletes")))
	    (thread-start! th1)
	    (thread-start! th2)
	    (thread-join! th1)
	    (set! keep-going #f)
	    (thread-join! th2)
	    ;; if run-count > 0 call, set -preclean and -rerun STUCK/DEAD
	    (if (> run-count 0)
		(begin
		  (if (not (hash-table-ref/default flags "-preclean" #f))
		      (hash-table-set! flags "-preclean" #t))
		  (if (not (hash-table-ref/default flags "-rerun" #f))
		      (hash-table-set! flags "-rerun" "STUCK/DEAD,n/a,ZERO_ITEMS"))
		  (runs:run-tests target runname test-patts user flags run-count: (- run-count 1)))))
	  (debug:print-info 0 "No tests to run")))
    (debug:print-info 4 "All done by here")
    (rmt:tasks-set-state-given-param-key task-key "done")
    ;; (sqlite3:finalize! tasks-db)
    ))


;; loop logic. These are used in runs:run-tests-queue to make it a bit more readable.
;;
;; If reg not full and have items in tal then loop with (car tal)(cdr tal) reg reruns
;; If reg is full (i.e. length >= n
404
405
406
407
408
409
410

411
412
413
414
415
416
417
418
	  '()
	  reg)))

(define runs:nothing-left-in-queue-count 0)

(define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmap)
  (let* ((loop-list       (list hed tal reg reruns))

	 (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap))
	 (fails           (runs:calc-fails prereqs-not-met))
	 (prereq-fails    (runs:calc-prereq-fail prereqs-not-met))
	 (non-completed   (runs:calc-not-completed prereqs-not-met))
	 (runnables       (runs:calc-runnable prereqs-not-met)))
    (debug:print-info 4 "START OF INNER COND #2 "
		      "\n can-run-more:    " can-run-more
		      "\n testname:        " hed







>
|







457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
	  '()
	  reg)))

(define runs:nothing-left-in-queue-count 0)

(define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmap)
  (let* ((loop-list       (list hed tal reg reruns))
	 (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons item-path testmode itemmap: itemmap))
	 ;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap))
	 (fails           (runs:calc-fails prereqs-not-met))
	 (prereq-fails    (runs:calc-prereq-fail prereqs-not-met))
	 (non-completed   (runs:calc-not-completed prereqs-not-met))
	 (runnables       (runs:calc-runnable prereqs-not-met)))
    (debug:print-info 4 "START OF INNER COND #2 "
		      "\n can-run-more:    " can-run-more
		      "\n testname:        " hed
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
		      "\n can-run-more:    " can-run-more)

    (cond
     ;; all prereqs met, fire off the test
     ;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch

     ((and (not (member 'toplevel testmode))
	   (member (hash-table-ref/default test-registry (runs:make-full-test-name hed item-path) 'n/a)
		   '(DONOTRUN removed CANNOTRUN))) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) ;; try to catch repeat processing of COMPLETED tests here
      (debug:print-info 1 "Test " hed " set to \"" (hash-table-ref test-registry (runs:make-full-test-name hed item-path)) "\". Removing it from the queue")
      (if (or (not (null? tal))
	      (not (null? reg)))
	  (list (runs:queue-next-hed tal reg reglen regfull)
		(runs:queue-next-tal tal reg reglen regfull)
		(runs:queue-next-reg tal reg reglen regfull)
		reruns)
	  (begin







|

|







482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
		      "\n can-run-more:    " can-run-more)

    (cond
     ;; all prereqs met, fire off the test
     ;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch

     ((and (not (member 'toplevel testmode))
	   (member (hash-table-ref/default test-registry (db:test-make-full-name hed item-path) 'n/a)
		   '(DONOTRUN removed CANNOTRUN))) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) ;; try to catch repeat processing of COMPLETED tests here
      (debug:print-info 1 "Test " hed " set to \"" (hash-table-ref test-registry (db:test-make-full-name hed item-path)) "\". Removing it from the queue")
      (if (or (not (null? tal))
	      (not (null? reg)))
	  (list (runs:queue-next-hed tal reg reglen regfull)
		(runs:queue-next-tal tal reg reglen regfull)
		(runs:queue-next-reg tal reg reglen regfull)
		reruns)
	  (begin
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
	(setenv "MT_TEST_NAME" test-name) ;; 
	(setenv "MT_RUNNAME"   runname)
	(runs:set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process
	(let ((items-list (items:get-items-from-config tconfig)))
	  (if (list? items-list)
	      (begin
		(if (null? items-list)
		    (let ((test-id (cdb:remote-run db:get-test-id-cached #f run-id test-name "")))
		      (mt:test-set-state-status-by-id test-id "NOT_STARTED" "ZERO_ITEMS" "Failed to run due to failed prerequisites")))
		(tests:testqueue-set-items! test-record items-list)
		(list hed tal reg reruns))
	      (begin
		(debug:print 0 "ERROR: The proc from reading the items table did not yield a list - please report this")
		(exit 1))))))

     ((and (null? fails)







|
|







516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
	(setenv "MT_TEST_NAME" test-name) ;; 
	(setenv "MT_RUNNAME"   runname)
	(runs:set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process
	(let ((items-list (items:get-items-from-config tconfig)))
	  (if (list? items-list)
	      (begin
		(if (null? items-list)
		    (let ((test-id (rmt:get-test-id run-id test-name "")))
		      (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "ZERO_ITEMS" "Failed to run due to failed prerequisites"))))
		(tests:testqueue-set-items! test-record items-list)
		(list hed tal reg reruns))
	      (begin
		(debug:print 0 "ERROR: The proc from reading the items table did not yield a list - please report this")
		(exit 1))))))

     ((and (null? fails)
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

	(if (and give-up
		 (not (and (null? tal)(null? reg))))
	    (let ((trimmed-tal (mt:discard-blocked-tests run-id hed tal test-records))
		  (trimmed-reg (mt:discard-blocked-tests run-id hed reg test-records)))
	      (debug:print 1 "WARNING: test " hed " has discarded prerequisites, removing it from the queue")

	      (let ((test-id (cdb:remote-run db:get-test-id-cached #f run-id hed "")))
		(mt:test-set-state-status-by-id test-id "NOT_STARTED" "PREQ_DISCARDED" "Failed to run due to discarded prerequisites"))
	      
	      (if (and (null? trimmed-tal)
		       (null? trimmed-reg))
		  #f
		  (list (runs:queue-next-hed trimmed-tal trimmed-reg reglen regfull)
			(runs:queue-next-tal trimmed-tal trimmed-reg reglen regfull)
			(runs:queue-next-reg trimmed-tal trimmed-reg reglen regfull)
			reruns)))
	      (list (car newtal)(append (cdr newtal) reg) '() reruns))))

     ((and (null? fails)
	   (null? prereq-fails)
	   (null? non-completed))
      (if  (runs:can-keep-running? hed 5)
	  (begin
	    (runs:inc-cant-run-tests hed)
	    (debug:print-info 1 "no fails in prerequisites for " hed " but also none running, keeping " hed " for now. Try count: " (hash-table-ref/default *seen-cant-run-tests* hed 0))


	    ;; num-retries code was here
	    ;; we use this opportunity to move contents of reg to tal
	    (list (car newtal)(append (cdr newtal) reg) '() reruns)) ;; an issue with prereqs not yet met?
	  (begin
	    (debug:print-info 1 "no fails in prerequisites for " hed " but nothing seen running in a while, dropping test " hed " from the run queue")
	    (let ((test-id (cdb:remote-run db:get-test-id-cached #f run-id hed "")))
	      (mt:test-set-state-status-by-id test-id "NOT_STARTED" "TIMED_OUT" "Nothing seen running in a while."))
	    (list (runs:queue-next-hed tal reg reglen regfull)
		  (runs:queue-next-tal tal reg reglen regfull)
		  (runs:queue-next-reg tal reg reglen regfull)
		  reruns))))

     ((and 
       (or (not (null? fails))
	   (not (null? prereq-fails)))
       (member 'normal testmode))
      (debug:print-info 1 "test "  hed " (mode=" testmode ") has failed prerequisite(s); "
			(string-intersperse (map (lambda (t)(conc (db:test-get-testname t) ":" (db:test-get-state t)"/"(db:test-get-status t))) fails) ", ")
			", removing it from to-do list")
      (let ((test-id (cdb:remote-run db:get-test-id-cached #f run-id hed "")))

	(if (not (null? prereq-fails))
	    (mt:test-set-state-status-by-id test-id "NOT_STARTED" "PREQ_DISCARDED" "Failed to run due to prior failed prerequisites")
	    (mt:test-set-state-status-by-id test-id "NOT_STARTED" "PREQ_FAIL"      "Failed to run due to failed prerequisites")))
      (if (or (not (null? reg))(not (null? tal)))
	  (begin
	    (hash-table-set! test-registry hed 'CANNOTRUN)
	    (list (runs:queue-next-hed tal reg reglen regfull)
		  (runs:queue-next-tal tal reg reglen regfull)
		  (runs:queue-next-reg tal reg reglen regfull)
		  (cons hed reruns)))







|
|













|



>
>





|
|












|
>
|
|
|







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

	(if (and give-up
		 (not (and (null? tal)(null? reg))))
	    (let ((trimmed-tal (mt:discard-blocked-tests run-id hed tal test-records))
		  (trimmed-reg (mt:discard-blocked-tests run-id hed reg test-records)))
	      (debug:print 1 "WARNING: test " hed " has discarded prerequisites, removing it from the queue")

	      (let ((test-id (rmt:get-test-id run-id hed "")))
		(if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_DISCARDED" "Failed to run due to discarded prerequisites")))
	      
	      (if (and (null? trimmed-tal)
		       (null? trimmed-reg))
		  #f
		  (list (runs:queue-next-hed trimmed-tal trimmed-reg reglen regfull)
			(runs:queue-next-tal trimmed-tal trimmed-reg reglen regfull)
			(runs:queue-next-reg trimmed-tal trimmed-reg reglen regfull)
			reruns)))
	      (list (car newtal)(append (cdr newtal) reg) '() reruns))))

     ((and (null? fails)
	   (null? prereq-fails)
	   (null? non-completed))
      (if  (runs:can-keep-running? hed 20)
	  (begin
	    (runs:inc-cant-run-tests hed)
	    (debug:print-info 1 "no fails in prerequisites for " hed " but also none running, keeping " hed " for now. Try count: " (hash-table-ref/default *seen-cant-run-tests* hed 0))
	    ;; getting here likely means the system is way overloaded, kill a full minute before continuing
	    (thread-sleep! 60)
	    ;; num-retries code was here
	    ;; we use this opportunity to move contents of reg to tal
	    (list (car newtal)(append (cdr newtal) reg) '() reruns)) ;; an issue with prereqs not yet met?
	  (begin
	    (debug:print-info 1 "no fails in prerequisites for " hed " but nothing seen running in a while, dropping test " hed " from the run queue")
	    (let ((test-id (rmt:get-test-id run-id hed "")))
	      (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "TIMED_OUT" "Nothing seen running in a while.")))
	    (list (runs:queue-next-hed tal reg reglen regfull)
		  (runs:queue-next-tal tal reg reglen regfull)
		  (runs:queue-next-reg tal reg reglen regfull)
		  reruns))))

     ((and 
       (or (not (null? fails))
	   (not (null? prereq-fails)))
       (member 'normal testmode))
      (debug:print-info 1 "test "  hed " (mode=" testmode ") has failed prerequisite(s); "
			(string-intersperse (map (lambda (t)(conc (db:test-get-testname t) ":" (db:test-get-state t)"/"(db:test-get-status t))) fails) ", ")
			", removing it from to-do list")
      (let ((test-id (rmt:get-test-id run-id hed "")))
	(if test-id
	    (if (not (null? prereq-fails))
		(mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_DISCARDED" "Failed to run due to prior failed prerequisites")
		(mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL"      "Failed to run due to failed prerequisites"))))
      (if (or (not (null? reg))(not (null? tal)))
	  (begin
	    (hash-table-set! test-registry hed 'CANNOTRUN)
	    (list (runs:queue-next-hed tal reg reglen regfull)
		  (runs:queue-next-tal tal reg reglen regfull)
		  (runs:queue-next-reg tal reg reglen regfull)
		  (cons hed reruns)))
582
583
584
585
586
587
588
589
590
591
592
593
594

595
596
597
598
599
600
601
602
	      ((string? t)
	       t)
	      (else 
	       (conc t))))
	   inlst)))

(define (runs:process-expanded-tests hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry itemmap)
  (let* ((run-limits-info         (runs:can-run-more-tests jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running
	 (have-resources          (car run-limits-info))
	 (num-running             (list-ref run-limits-info 1))
	 (num-running-in-jobgroup (list-ref run-limits-info 2)) 
	 (max-concurrent-jobs     (list-ref run-limits-info 3))
	 (job-group-limit         (list-ref run-limits-info 4))

	 (prereqs-not-met         (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap))
	 (fails                   (runs:calc-fails prereqs-not-met))
	 (non-completed           (runs:calc-not-completed prereqs-not-met))
	 (loop-list               (list hed tal reg reruns))
	 ;; configure the load runner
	 (numcpus                 (common:get-num-cpus))
	 (maxload                 (string->number (or (configf:lookup *configdat* "jobtools" "maxload") "3")))
	 (waitdelay               (string->number (or (configf:lookup *configdat* "jobtools" "waitdelay") "60"))))







|





>
|







639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
	      ((string? t)
	       t)
	      (else 
	       (conc t))))
	   inlst)))

(define (runs:process-expanded-tests hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry itemmap)
  (let* ((run-limits-info         (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running
	 (have-resources          (car run-limits-info))
	 (num-running             (list-ref run-limits-info 1))
	 (num-running-in-jobgroup (list-ref run-limits-info 2)) 
	 (max-concurrent-jobs     (list-ref run-limits-info 3))
	 (job-group-limit         (list-ref run-limits-info 4))
	 (prereqs-not-met         (rmt:get-prereqs-not-met run-id waitons item-path testmode itemmap: itemmap))
	 ;; (prereqs-not-met         (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap))
	 (fails                   (runs:calc-fails prereqs-not-met))
	 (non-completed           (runs:calc-not-completed prereqs-not-met))
	 (loop-list               (list hed tal reg reruns))
	 ;; configure the load runner
	 (numcpus                 (common:get-num-cpus))
	 (maxload                 (string->number (or (configf:lookup *configdat* "jobtools" "maxload") "3")))
	 (waitdelay               (string->number (or (configf:lookup *configdat* "jobtools" "waitdelay") "60"))))
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
		(runs:queue-next-tal tal reg reglen regfull)
		(runs:queue-next-reg tal reg reglen regfull)
		reruns)
	  #f))
     
     ;; Register tests 
     ;;
     ((not (hash-table-ref/default test-registry (runs:make-full-test-name test-name item-path) #f))
      (debug:print-info 4 "Pre-registering test " test-name "/" item-path " to create placeholder" )
      (if (eq? *transport-type* 'fs) ;; no point in parallel registration if use fs





	  (begin
	    (cdb:tests-register-test *runremote* run-id test-name item-path)
	    (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'done))
	  (let ((th (make-thread (lambda ()
				   (mutex-lock! registry-mutex)
				   (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'start)
				   (mutex-unlock! registry-mutex)
				   ;; If haven't done it before register a top level test if this is an itemized test
				   (if (not (eq? (hash-table-ref/default test-registry (runs:make-full-test-name test-name "") #f) 'done))

				       (cdb:tests-register-test *runremote* run-id test-name ""))
				   (cdb:tests-register-test *runremote* run-id test-name item-path)
				   (mutex-lock! registry-mutex)
				   (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'done)
				   (mutex-unlock! registry-mutex))
				 (conc test-name "/" item-path))))
	    (thread-start! th)))
      (runs:shrink-can-run-more-tests-count)   ;; DELAY TWEAKER (still needed?)
      (if (and (null? tal)(null? reg))
	  (list hed tal (append reg (list hed)) reruns)
	  (list (runs:queue-next-hed tal reg reglen regfull)
		(runs:queue-next-tal tal reg reglen regfull)
		;; NB// Here we are building reg as we register tests
		;; if regfull we must pop the front item off reg
		(if regfull
		    (append (cdr reg) (list hed))
		    (append reg (list hed)))
		reruns)))
     
     ;; At this point hed test registration must be completed.
     ;;
     ((eq? (hash-table-ref/default test-registry (runs:make-full-test-name test-name item-path) #f)
	   'start)
      (debug:print-info 0 "Waiting on test registration(s): "
			(string-intersperse 
			 (filter (lambda (x)
				   (eq? (hash-table-ref/default test-registry x #f) 'start))
				 (hash-table-keys test-registry))
			 ", "))
      (thread-sleep! 0.1)
      (list hed tal reg reruns))
     
     ;; 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 "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! 1)
      ;; 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)
	       (and (eq? testmode 'toplevel)
		    (null? non-completed))))
      ;; (hash-table-delete! *max-tries-hash* (runs:make-full-test-name test-name item-path))
      ;; we are going to reset all the counters for test retries by setting a new hash table
      ;; this means they will increment only when nothing can be run
      (set! *max-tries-hash* (make-hash-table))
      ;; well, first lets see if cpu load throttling is enabled. If so wait around until the
      ;; average cpu load is under the threshold before continuing
      (if (configf:lookup *configdat* "jobtools" "maxload") ;; only gate if maxload is specified
	  (common:wait-for-cpuload maxload numcpus waitdelay))
      (run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry)
      (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'running)
      (runs:shrink-can-run-more-tests-count)  ;; DELAY TWEAKER (still needed?)
      ;; (thread-sleep! *global-delta*)
      (if (or (not (null? tal))(not (null? reg)))
	  (list (runs:queue-next-hed tal reg reglen regfull)
		(runs:queue-next-tal tal reg reglen regfull)
		(runs:queue-next-reg tal reg reglen regfull)
		reruns)







|

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














|







|



















|








|







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
		(runs:queue-next-tal tal reg reglen regfull)
		(runs:queue-next-reg tal reg reglen regfull)
		reruns)
	  #f))
     
     ;; Register tests 
     ;;
     ((not (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f))
      (debug:print-info 4 "Pre-registering test " test-name "/" item-path " to create placeholder" )
      ;; always do firm registration now in v1.60 and greater ;; (eq? *transport-type* 'fs) ;; no point in parallel registration if use fs
      (let register-loop ((numtries 15))
	(rmt:general-call 'register-test run-id run-id test-name item-path)
	(if (rmt:get-test-id run-id test-name item-path)
	    (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'done)
	    (if (> numtries 0)
		(begin


		  (thread-sleep! 0.5)
		  (register-loop (- numtries 1)))
		(debug:print 0 "ERROR: failed to register test " (db:test-make-full-name test-name item-path)))))


      (if (not (eq? (hash-table-ref/default test-registry (db:test-make-full-name test-name "") #f) 'done))
	  (begin
	    (rmt:general-call 'register-test run-id run-id test-name "")
	    (if (rmt:get-test-id run-id test-name "")

		(hash-table-set! test-registry (db:test-make-full-name test-name "") 'done))))



      (runs:shrink-can-run-more-tests-count)   ;; DELAY TWEAKER (still needed?)
      (if (and (null? tal)(null? reg))
	  (list hed tal (append reg (list hed)) reruns)
	  (list (runs:queue-next-hed tal reg reglen regfull)
		(runs:queue-next-tal tal reg reglen regfull)
		;; NB// Here we are building reg as we register tests
		;; if regfull we must pop the front item off reg
		(if regfull
		    (append (cdr reg) (list hed))
		    (append reg (list hed)))
		reruns)))
     
     ;; At this point hed test registration must be completed.
     ;;
     ((eq? (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f)
	   'start)
      (debug:print-info 0 "Waiting on test registration(s): "
			(string-intersperse 
			 (filter (lambda (x)
				   (eq? (hash-table-ref/default test-registry x #f) 'start))
				 (hash-table-keys test-registry))
			 ", "))
      (thread-sleep! 0.051)
      (list hed tal reg reruns))
     
     ;; 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 "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! 1)
      ;; 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)
	       (and (eq? testmode 'toplevel)
		    (null? non-completed))))
      ;; (hash-table-delete! *max-tries-hash* (db:test-make-full-name test-name item-path))
      ;; we are going to reset all the counters for test retries by setting a new hash table
      ;; this means they will increment only when nothing can be run
      (set! *max-tries-hash* (make-hash-table))
      ;; well, first lets see if cpu load throttling is enabled. If so wait around until the
      ;; average cpu load is under the threshold before continuing
      (if (configf:lookup *configdat* "jobtools" "maxload") ;; only gate if maxload is specified
	  (common:wait-for-cpuload maxload numcpus waitdelay))
      (run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry)
      (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'running)
      (runs:shrink-can-run-more-tests-count)  ;; DELAY TWEAKER (still needed?)
      ;; (thread-sleep! *global-delta*)
      (if (or (not (null? tal))(not (null? reg)))
	  (list (runs:queue-next-hed tal reg reglen regfull)
		(runs:queue-next-tal tal reg reglen regfull)
		(runs:queue-next-reg tal reg reglen regfull)
		reruns)
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
	    (list (car newtal)(cdr newtal) reg reruns))
	  ;; the waiton is FAIL so no point in trying to run hed ever again
	  (if (or (not (null? reg))(not (null? tal)))
	      (if (vector? hed)
		  (begin
		    (debug:print 1 "WARNING: Dropping test " test-name "/" item-path
				 " from the launch list as it has prerequistes that are FAIL")
		    (let ((test-id (cdb:remote-run db:get-test-id-cached #f run-id hed "")))
		      (mt:test-set-state-status-by-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites"))
		    (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?)
		    ;; (thread-sleep! *global-delta*)
		    ;; This next is for the items
		    (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "BLOCKED" #f)
		    (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'removed)
		    (list (runs:queue-next-hed tal reg reglen regfull)
			  (runs:queue-next-tal tal reg reglen regfull)
			  (runs:queue-next-reg tal reg reglen regfull)
			  reruns ;; WAS: (cons hed reruns) ;; but that makes no sense?
			  ))
		  (let ((nth-try (hash-table-ref/default test-registry hed 0)))
		    (cond







|
|




|







790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
	    (list (car newtal)(cdr newtal) reg reruns))
	  ;; the waiton is FAIL so no point in trying to run hed ever again
	  (if (or (not (null? reg))(not (null? tal)))
	      (if (vector? hed)
		  (begin
		    (debug:print 1 "WARNING: Dropping test " test-name "/" item-path
				 " from the launch list as it has prerequistes that are FAIL")
		    (let ((test-id (rmt:get-test-id run-id hed "")))
		      (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites")))
		    (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?)
		    ;; (thread-sleep! *global-delta*)
		    ;; This next is for the items
		    (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "BLOCKED" #f)
		    (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'removed)
		    (list (runs:queue-next-hed tal reg reglen regfull)
			  (runs:queue-next-tal tal reg reglen regfull)
			  (runs:queue-next-reg tal reg reglen regfull)
			  reruns ;; WAS: (cons hed reruns) ;; but that makes no sense?
			  ))
		  (let ((nth-try (hash-table-ref/default test-registry hed 0)))
		    (cond
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
  ;; NB// Should expand items here and then insert into the run queue.
  (debug:print 5 "test-records: " test-records ", flags: " (hash-table->alist flags))

  ;; Do mark-and-find clean up of db before starting runing of quue
  ;;
  ;; (cdb:remote-run db:find-and-mark-incomplete #f)

  (let ((run-info              (cdb:remote-run db:get-run-info #f run-id))
	(tests-info            (mt:get-tests-for-run run-id #f '() '())) ;;  qryvals: "id,testname,item_path"))
	(sorted-test-names     (tests:sort-by-priority-and-waiton test-records))
	(test-registry         (make-hash-table))
	(registry-mutex        (make-mutex))
	(num-retries           0)
	(max-retries           (config-lookup *configdat* "setup" "maxretries"))
	(max-concurrent-jobs   (let ((mcj (config-lookup *configdat* "setup"     "max_concurrent_jobs")))
				 (if (and mcj (string->number mcj))
				     (string->number mcj)
				     1))) ;; length of the register queue ahead
	(reglen                (if (number? reglen-in) reglen-in 1))
	(last-time-incomplete  (- (current-seconds) 900)) ;; force at least one clean up cycle
	(last-time-some-running (current-seconds)))


    ;; Initialize the test-registery hash with tests that already have a record
    ;; convert state to symbol and use that as the hash value
    (for-each (lambda (trec)
		(let ((id (db:test-get-id        trec))
		      (tn (db:test-get-testname  trec))
		      (ip (db:test-get-item-path trec))
		      (st (db:test-get-state     trec)))
		  (if (not (equal? st "DELETED"))
		      (hash-table-set! test-registry (runs:make-full-test-name tn ip) (string->symbol st)))))
	      tests-info)
    (set! max-retries (if (and max-retries (string->number max-retries))(string->number max-retries) 100))

    (let loop ((hed         (car sorted-test-names))
	       (tal         (cdr sorted-test-names))
	       (reg         '()) ;; registered, put these at the head of tal 
	       (reruns      '()))

      (if (not (null? reruns))(debug:print-info 4 "reruns=" reruns))

      ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes


      (if (> (current-seconds)(+ last-time-incomplete 900))
          (begin
            (set! last-time-incomplete (current-seconds))
            (cdb:remote-run db:find-and-mark-incomplete #f)))


      ;; (print "Top of loop, hed=" hed ", tal=" tal " ,reruns=" reruns)
      (let* ((test-record (hash-table-ref test-records hed))
	     (test-name   (tests:testqueue-get-testname test-record))
	     (tconfig     (tests:testqueue-get-testconfig test-record))
	     (jobgroup    (config-lookup tconfig "test_meta" "jobgroup"))
	     (testmode    (let ((m (config-lookup tconfig "requirements" "mode")))
			    (if m (map string->symbol (string-split m)) '(normal))))
	     (itemmap     (configf:lookup tconfig "requirements" "itemmap"))
	     (waitons     (tests:testqueue-get-waitons    test-record))
	     (priority    (tests:testqueue-get-priority   test-record))
	     (itemdat     (tests:testqueue-get-itemdat    test-record)) ;; itemdat can be a string, list or #f
	     (items       (tests:testqueue-get-items      test-record))
	     (item-path   (item-list->path itemdat))
	     (tfullname   (runs:make-full-test-name test-name item-path))
	     (newtal      (append tal (list hed)))
	     (regfull     (>= (length reg) reglen))
	     (num-running (cdb:remote-run db:get-count-tests-running-for-run-id #f run-id #f)))






      (if (> num-running 0)
	  (set! last-time-some-running (current-seconds)))

      (if (> (current-seconds)(+ last-time-some-running 240))
	  (hash-table-set! *max-tries-hash* tfullname (+ (hash-table-ref/default *max-tries-hash* tfullname 0) 1)))
	;; (debug:print 0 "max-tries-hash: " (hash-table->alist *max-tries-hash*))

	;; Ensure all top level tests get registered. This way they show up as "NOT_STARTED" on the dashboard
	;; and it is clear they *should* have run but did not.
	(if (not (hash-table-ref/default test-registry (runs:make-full-test-name test-name "") #f))
	    (begin
	      (cdb:tests-register-test *runremote* run-id test-name "")
	      (hash-table-set! test-registry (runs:make-full-test-name test-name "") 'done)))
	
	;; Fast skip of tests that are already "COMPLETED" - NO! Cannot do that as the items may not have been expanded yet :(
	;;
	(if (member (hash-table-ref/default test-registry tfullname #f) 
		    '(DONOTRUN removed)) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE))
	    (begin
	      (if (runs:lownoise (conc "been marked do not run " tfullname) 60)







|












|
>









|











>
>



|
>














|


|

>
>
>
>
>
|








|

|
|







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
  ;; NB// Should expand items here and then insert into the run queue.
  (debug:print 5 "test-records: " test-records ", flags: " (hash-table->alist flags))

  ;; Do mark-and-find clean up of db before starting runing of quue
  ;;
  ;; (cdb:remote-run db:find-and-mark-incomplete #f)

  (let ((run-info              (rmt:get-run-info run-id))
	(tests-info            (mt:get-tests-for-run run-id #f '() '())) ;;  qryvals: "id,testname,item_path"))
	(sorted-test-names     (tests:sort-by-priority-and-waiton test-records))
	(test-registry         (make-hash-table))
	(registry-mutex        (make-mutex))
	(num-retries           0)
	(max-retries           (config-lookup *configdat* "setup" "maxretries"))
	(max-concurrent-jobs   (let ((mcj (config-lookup *configdat* "setup"     "max_concurrent_jobs")))
				 (if (and mcj (string->number mcj))
				     (string->number mcj)
				     1))) ;; length of the register queue ahead
	(reglen                (if (number? reglen-in) reglen-in 1))
	(last-time-incomplete  (- (current-seconds) 900)) ;; force at least one clean up cycle
	(last-time-some-running (current-seconds))
	(tdbdat                (tasks:open-db)))

    ;; Initialize the test-registery hash with tests that already have a record
    ;; convert state to symbol and use that as the hash value
    (for-each (lambda (trec)
		(let ((id (db:test-get-id        trec))
		      (tn (db:test-get-testname  trec))
		      (ip (db:test-get-item-path trec))
		      (st (db:test-get-state     trec)))
		  (if (not (equal? st "DELETED"))
		      (hash-table-set! test-registry (db:test-make-full-name tn ip) (string->symbol st)))))
	      tests-info)
    (set! max-retries (if (and max-retries (string->number max-retries))(string->number max-retries) 100))

    (let loop ((hed         (car sorted-test-names))
	       (tal         (cdr sorted-test-names))
	       (reg         '()) ;; registered, put these at the head of tal 
	       (reruns      '()))

      (if (not (null? reruns))(debug:print-info 4 "reruns=" reruns))

      ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes
      ;; moving this to a parallel thread and just run it once.
      ;;
      (if (> (current-seconds)(+ last-time-incomplete 900))
          (begin
            (set! last-time-incomplete (current-seconds))
            ;; (rmt:find-and-mark-incomplete-all-runs)
	    ))

      ;; (print "Top of loop, hed=" hed ", tal=" tal " ,reruns=" reruns)
      (let* ((test-record (hash-table-ref test-records hed))
	     (test-name   (tests:testqueue-get-testname test-record))
	     (tconfig     (tests:testqueue-get-testconfig test-record))
	     (jobgroup    (config-lookup tconfig "test_meta" "jobgroup"))
	     (testmode    (let ((m (config-lookup tconfig "requirements" "mode")))
			    (if m (map string->symbol (string-split m)) '(normal))))
	     (itemmap     (configf:lookup tconfig "requirements" "itemmap"))
	     (waitons     (tests:testqueue-get-waitons    test-record))
	     (priority    (tests:testqueue-get-priority   test-record))
	     (itemdat     (tests:testqueue-get-itemdat    test-record)) ;; itemdat can be a string, list or #f
	     (items       (tests:testqueue-get-items      test-record))
	     (item-path   (item-list->path itemdat))
	     (tfullname   (db:test-make-full-name test-name item-path))
	     (newtal      (append tal (list hed)))
	     (regfull     (>= (length reg) reglen))
	     (num-running (rmt:get-count-tests-running-for-run-id run-id)))

	;; every couple minutes verify the server is there for this run
	(if (and (common:low-noise-print 60 "try start server"  run-id)
		 (tasks:need-server run-id))
	    (tasks:start-and-wait-for-server tdbdat run-id 10)) ;; NOTE: delay and wait is done under the hood
	
	(if (> num-running 0)
	  (set! last-time-some-running (current-seconds)))

      (if (> (current-seconds)(+ last-time-some-running 240))
	  (hash-table-set! *max-tries-hash* tfullname (+ (hash-table-ref/default *max-tries-hash* tfullname 0) 1)))
	;; (debug:print 0 "max-tries-hash: " (hash-table->alist *max-tries-hash*))

	;; Ensure all top level tests get registered. This way they show up as "NOT_STARTED" on the dashboard
	;; and it is clear they *should* have run but did not.
	(if (not (hash-table-ref/default test-registry (db:test-make-full-name test-name "") #f))
	    (begin
	      (rmt:general-call 'register-test run-id run-id test-name "")
	      (hash-table-set! test-registry (db:test-make-full-name test-name "") 'done)))
	
	;; Fast skip of tests that are already "COMPLETED" - NO! Cannot do that as the items may not have been expanded yet :(
	;;
	(if (member (hash-table-ref/default test-registry tfullname #f) 
		    '(DONOTRUN removed)) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE))
	    (begin
	      (if (runs:lownoise (conc "been marked do not run " tfullname) 60)
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
	  (for-each
	   (lambda (my-itemdat)
	     (let* ((new-test-record (let ((newrec (make-tests:testqueue)))
				       (vector-copy! test-record newrec)
				       newrec))
		    (my-item-path (item-list->path my-itemdat)))
	       (if (tests:match test-patts hed my-item-path required: required-tests) ;; (patt-list-match my-item-path item-patts)           ;; yes, we want to process this item, NOTE: Should not need this check here!
		   (let ((newtestname (runs:make-full-test-name hed my-item-path)))    ;; test names are unique on testname/item-path
		     (tests:testqueue-set-items!     new-test-record #f)
		     (tests:testqueue-set-itemdat!   new-test-record my-itemdat)
		     (tests:testqueue-set-item_path! new-test-record my-item-path)
		     (hash-table-set! test-records newtestname new-test-record)
		     (set! tal (append tal (list newtestname))))))) ;; since these are itemized create new test names testname/itempath
	   items)








|







1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
	  (for-each
	   (lambda (my-itemdat)
	     (let* ((new-test-record (let ((newrec (make-tests:testqueue)))
				       (vector-copy! test-record newrec)
				       newrec))
		    (my-item-path (item-list->path my-itemdat)))
	       (if (tests:match test-patts hed my-item-path required: required-tests) ;; (patt-list-match my-item-path item-patts)           ;; yes, we want to process this item, NOTE: Should not need this check here!
		   (let ((newtestname (db:test-make-full-name hed my-item-path)))    ;; test names are unique on testname/item-path
		     (tests:testqueue-set-items!     new-test-record #f)
		     (tests:testqueue-set-itemdat!   new-test-record my-itemdat)
		     (tests:testqueue-set-item_path! new-test-record my-item-path)
		     (hash-table-set! test-records newtestname new-test-record)
		     (set! tal (append tal (list newtestname))))))) ;; since these are itemized create new test names testname/itempath
	   items)

1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
	      #f
	      (loop (car tal)(cdr tal) reg reruns)))
	    
	 ;; if items is a proc then need to run items:get-items-from-config, get the list and loop 
	 ;;    - but only do that if resources exist to kick off the job
	 ;; EXPAND ITEMS
	 ((or (procedure? items)(eq? items 'have-procedure))
	  (let ((can-run-more    (runs:can-run-more-tests jobgroup max-concurrent-jobs)))
	    (if (and (list? can-run-more)
		     (car can-run-more))
		(let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmap)))
		  (if loop-list
		      (apply loop loop-list)))
		;; if can't run more just loop with next possible test
		(loop (car newtal)(cdr newtal) reg reruns))))







|







1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
	      #f
	      (loop (car tal)(cdr tal) reg reruns)))
	    
	 ;; if items is a proc then need to run items:get-items-from-config, get the list and loop 
	 ;;    - but only do that if resources exist to kick off the job
	 ;; EXPAND ITEMS
	 ((or (procedure? items)(eq? items 'have-procedure))
	  (let ((can-run-more    (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)))
	    (if (and (list? can-run-more)
		     (car can-run-more))
		(let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmap)))
		  (if loop-list
		      (apply loop loop-list)))
		;; if can't run more just loop with next possible test
		(loop (car newtal)(cdr newtal) reg reruns))))
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
	 ((not (null? reg)) ;; could we get here with leftovers?
	  (debug:print-info 0 "Have leftovers!")
	  (loop (car reg)(cdr reg) '() reruns))
	 (else
	  (debug:print-info 4 "Exiting loop with...\n  hed=" hed "\n  tal=" tal "\n  reruns=" reruns))
	 )))
    ;; now *if* -run-wait we wait for all tests to be done
    
    ;; if run-wait mode then wait 15 seconds for db to stabilize
    (if (or (args:get-arg "-run-wait")
	    (equal? (configf:lookup *configdat* "setup" "run-wait") "yes"))
	(thread-sleep! 15))
    ;; Now wait for any RUNNING tests to complete (if in run-wait mode)
    (let wait-loop ((num-running      (cdb:remote-run db:get-count-tests-running-for-run-id #f run-id #f))
		    (prev-num-running 0))
      ;; (debug:print 0 "num-running=" num-running ", prev-num-running=" prev-num-running)
      (if (and (or (args:get-arg "-run-wait")
		   (equal? (configf:lookup *configdat* "setup" "run-wait") "yes"))
	       (> num-running 0))
	  (begin
	    ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes
	    ;; (debug:print 0 "Got here eh! num-running=" num-running " (> num-running 0) " (> num-running 0))
	    (if (> (current-seconds)(+ last-time-incomplete 900))
		(begin
		  (debug:print-info 0 "Marking stuck tests as INCOMPLETE while waiting for run " run-id ". Running as pid " (current-process-id) " on " (get-host-name))
		  (set! last-time-incomplete (current-seconds))
		  (cdb:remote-run db:find-and-mark-incomplete #f)))
	    (if (not (eq? num-running prev-num-running))
		(debug:print-info 0 "run-wait specified, waiting on " num-running " tests in RUNNING, REMOTEHOSTSTART or LAUNCHED state at " (time->string (seconds->local-time (current-seconds)))))
	    (thread-sleep! 15)
	    (wait-loop (cdb:remote-run db:get-count-tests-running-for-run-id #f run-id #f) num-running))))

    ;; LET* ((test-record
    ;; we get here on "drop through". All done!
    (debug:print-info 1 "All tests launched")))

(define (runs:calc-fails prereqs-not-met)
  (filter (lambda (test)
	    (and (vector? test) ;; not (string? test))







<
<
<
<
<

|












|


|
|
>







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
	 ((not (null? reg)) ;; could we get here with leftovers?
	  (debug:print-info 0 "Have leftovers!")
	  (loop (car reg)(cdr reg) '() reruns))
	 (else
	  (debug:print-info 4 "Exiting loop with...\n  hed=" hed "\n  tal=" tal "\n  reruns=" reruns))
	 )))
    ;; now *if* -run-wait we wait for all tests to be done





    ;; Now wait for any RUNNING tests to complete (if in run-wait mode)
    (let wait-loop ((num-running      (rmt:get-count-tests-running-for-run-id run-id))
		    (prev-num-running 0))
      ;; (debug:print 0 "num-running=" num-running ", prev-num-running=" prev-num-running)
      (if (and (or (args:get-arg "-run-wait")
		   (equal? (configf:lookup *configdat* "setup" "run-wait") "yes"))
	       (> num-running 0))
	  (begin
	    ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes
	    ;; (debug:print 0 "Got here eh! num-running=" num-running " (> num-running 0) " (> num-running 0))
	    (if (> (current-seconds)(+ last-time-incomplete 900))
		(begin
		  (debug:print-info 0 "Marking stuck tests as INCOMPLETE while waiting for run " run-id ". Running as pid " (current-process-id) " on " (get-host-name))
		  (set! last-time-incomplete (current-seconds))
		  (rmt:find-and-mark-incomplete run-id #f)))
	    (if (not (eq? num-running prev-num-running))
		(debug:print-info 0 "run-wait specified, waiting on " num-running " tests in RUNNING, REMOTEHOSTSTART or LAUNCHED state at " (time->string (seconds->local-time (current-seconds)))))
	    (thread-sleep! 5)
	    ;; (wait-loop (rmt:get-count-tests-running-for-run-id run-id) num-running))))
	    (wait-loop (rmt:get-count-tests-running-for-run-id run-id) num-running))))
    ;; LET* ((test-record
    ;; we get here on "drop through". All done!
    (debug:print-info 1 "All tests launched")))

(define (runs:calc-fails prereqs-not-met)
  (filter (lambda (test)
	    (and (vector? test) ;; not (string? test))
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
(define (runs:pretty-string lst)
  (map (lambda (t)
	 (if (not (vector? t))
	     (conc t)
	     (conc (db:test-get-testname t) ":" (db:test-get-state t) "/" (db:test-get-status t))))
       lst))

(define (runs:make-full-test-name testname itempath)
  (if (equal? itempath "") testname (conc testname "/" itempath)))

;; parent-test is there as a placeholder for when parent-tests can be run as a setup step
(define (run:test run-id run-info keyvals runname test-record flags parent-test test-registry all-tests-registry)
  ;; All these vars might be referenced by the testconfig file reader
  (let* ((test-name    (tests:testqueue-get-testname   test-record))
	 (test-waitons (tests:testqueue-get-waitons    test-record))
	 (test-conf    (tests:testqueue-get-testconfig test-record))
	 (itemdat      (tests:testqueue-get-itemdat    test-record))
	 (test-path    (hash-table-ref all-tests-registry test-name)) ;; (conc *toppath* "/tests/" test-name)) ;; could use tests:get-testconfig here ...
	 (force        (hash-table-ref/default flags "-force" #f))
	 (rerun        (hash-table-ref/default flags "-rerun" #f))
	 (keepgoing    (hash-table-ref/default flags "-keepgoing" #f))
	 (incomplete-timeout (string->number (or (configf:lookup *configdat* "setup" "incomplete-timeout") "x")))
	 (item-path     "")
	 (db           #f)
	 (full-test-name #f))

    ;; setting itemdat to a list if it is #f
    (if (not itemdat)(set! itemdat '()))
    (set! item-path (item-list->path itemdat))
    (set! full-test-name (runs:make-full-test-name test-name item-path))
    (debug:print-info 4
		      "\nTESTNAME: " full-test-name 
		      "\n   test-config: " (hash-table->alist test-conf)
		      "\n   itemdat: " itemdat
		      )
    (debug:print 2 "Attempting to launch test " full-test-name)
    (setenv "MT_TEST_NAME" test-name) ;; 







<
<
<



















|







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
(define (runs:pretty-string lst)
  (map (lambda (t)
	 (if (not (vector? t))
	     (conc t)
	     (conc (db:test-get-testname t) ":" (db:test-get-state t) "/" (db:test-get-status t))))
       lst))




;; parent-test is there as a placeholder for when parent-tests can be run as a setup step
(define (run:test run-id run-info keyvals runname test-record flags parent-test test-registry all-tests-registry)
  ;; All these vars might be referenced by the testconfig file reader
  (let* ((test-name    (tests:testqueue-get-testname   test-record))
	 (test-waitons (tests:testqueue-get-waitons    test-record))
	 (test-conf    (tests:testqueue-get-testconfig test-record))
	 (itemdat      (tests:testqueue-get-itemdat    test-record))
	 (test-path    (hash-table-ref all-tests-registry test-name)) ;; (conc *toppath* "/tests/" test-name)) ;; could use tests:get-testconfig here ...
	 (force        (hash-table-ref/default flags "-force" #f))
	 (rerun        (hash-table-ref/default flags "-rerun" #f))
	 (keepgoing    (hash-table-ref/default flags "-keepgoing" #f))
	 (incomplete-timeout (string->number (or (configf:lookup *configdat* "setup" "incomplete-timeout") "x")))
	 (item-path     "")
	 (db           #f)
	 (full-test-name #f))

    ;; setting itemdat to a list if it is #f
    (if (not itemdat)(set! itemdat '()))
    (set! item-path (item-list->path itemdat))
    (set! full-test-name (db:test-make-full-name test-name item-path))
    (debug:print-info 4
		      "\nTESTNAME: " full-test-name 
		      "\n   test-config: " (hash-table->alist test-conf)
		      "\n   itemdat: " itemdat
		      )
    (debug:print 2 "Attempting to launch test " full-test-name)
    (setenv "MT_TEST_NAME" test-name) ;; 
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
    (if (not (hash-table-ref/default *test-meta-updated* test-name #f))
        (begin
	   (hash-table-set! *test-meta-updated* test-name #t)
           (runs:update-test_meta test-name test-conf)))
    
    ;; itemdat => ((ripeness "overripe") (temperature "cool") (season "summer"))
    (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/"))
	   (test-id       (cdb:remote-run db:get-test-id-cached #f  run-id test-name item-path))
	   (testdat       (if test-id (cdb:get-test-info-by-id *runremote* test-id) #f)))
      (if (not testdat)
	  (let loop ()
	    ;; ensure that the path exists before registering the test
	    ;; NOPE: Cannot! Don't know yet which disk area will be assigned....
	    ;; (system (conc "mkdir -p " new-test-path))
	    ;;
	    ;; (open-run-close tests:register-test db run-id test-name item-path)
	    ;;
	    ;; NB// for the above line. I want the test to be registered long before this routine gets called!
	    ;;
	    (if (not test-id)(set! test-id (cdb:remote-run db:get-test-id-cached #f run-id test-name item-path)))
	    (if (not test-id)
		(begin
		  (debug:print 2 "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id)
		  (cdb:tests-register-test *runremote* run-id test-name item-path)
		  (set! test-id (cdb:remote-run db:get-test-id-cached #f run-id test-name item-path))))
	    (debug:print-info 4 "test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"")
	    (set! testdat (cdb:get-test-info-by-id *runremote* test-id))
	    (if (not testdat)
		(begin
		  (debug:print-info 0 "WARNING: server is overloaded, trying again in one second")
		  (thread-sleep! 1)
		  (loop)))))
      (if (not testdat) ;; should NOT happen
	  (debug:print 0 "ERROR: failed to get test record for test-id " test-id))







|
|










|



|
|

|







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
    (if (not (hash-table-ref/default *test-meta-updated* test-name #f))
        (begin
	   (hash-table-set! *test-meta-updated* test-name #t)
           (runs:update-test_meta test-name test-conf)))
    
    ;; itemdat => ((ripeness "overripe") (temperature "cool") (season "summer"))
    (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/"))
	   (test-id       (rmt:get-test-id run-id test-name item-path))
	   (testdat       (if test-id (rmt:get-test-info-by-id run-id test-id) #f)))
      (if (not testdat)
	  (let loop ()
	    ;; ensure that the path exists before registering the test
	    ;; NOPE: Cannot! Don't know yet which disk area will be assigned....
	    ;; (system (conc "mkdir -p " new-test-path))
	    ;;
	    ;; (open-run-close tests:register-test db run-id test-name item-path)
	    ;;
	    ;; NB// for the above line. I want the test to be registered long before this routine gets called!
	    ;;
	    (if (not test-id)(set! test-id (rmt:get-test-id run-id test-name item-path)))
	    (if (not test-id)
		(begin
		  (debug:print 2 "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id)
		  (rmt:general-call 'register-test run-id run-id test-name item-path)
		  (set! test-id (rmt:get-test-id run-id test-name item-path))))
	    (debug:print-info 4 "test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"")
	    (set! testdat (rmt:get-test-info-by-id run-id test-id))
	    (if (not testdat)
		(begin
		  (debug:print-info 0 "WARNING: server is overloaded, trying again in one second")
		  (thread-sleep! 1)
		  (loop)))))
      (if (not testdat) ;; should NOT happen
	  (debug:print 0 "ERROR: failed to get test record for test-id " test-id))
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
	       (let ((skip-test   #f)
		     (skip-check  (configf:get-section test-conf "skip")))
		 (cond 
		  ;; Have to check for skip conditions. This one skips if there are same-named tests
		  ;; currently running
		  ((and skip-check
			(configf:lookup test-conf "skip" "prevrunning"))

		   (let ((running-tests (cdb:remote-run db:get-tests-for-runs-mindata #f #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f)))
		     (if (not (null? running-tests)) ;; have to skip 
			 (set! skip-test "Skipping due to previous tests running"))))
		  ((and skip-check
			(configf:lookup test-conf "skip" "fileexists"))
		   (if (file-exists? (configf:lookup test-conf "skip" "fileexists"))
		       (set! skip-test (conc "Skipping due to existance of file " (configf:lookup test-conf "skip" "fileexists"))))))
		 (if skip-test
		     (begin
		       (mt:test-set-state-status-by-id test-id "COMPLETED" "SKIP" skip-test)
		       (debug:print-info 1 "SKIPPING Test " full-test-name " due to " skip-test))
		     (if (not (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat flags))
			 (begin
			   (print "ERROR: Failed to launch the test. Exiting as soon as possible")
			   (set! *globalexitstatus* 1) ;; 
			   (process-signal (current-process-id) signal/kill))))))))
	((KILLED) 
	 (debug:print 1 "NOTE: " full-test-name " is already running or was explictly killed, use -force to launch it.")
	 (hash-table-set! test-registry (runs:make-full-test-name test-name test-path) 'DONOTRUN)) ;; KILLED))
	((LAUNCHED REMOTEHOSTSTART RUNNING)  

	 (if (> (- (current-seconds)(+ (db:test-get-event_time testdat)
				       (db:test-get-run_duration testdat)))
		(or incomplete-timeout
		    6000)) ;; i.e. no update for more than 6000 seconds
	     (begin
	       (debug:print 0 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD")

	       (tests:test-set-status! test-id "INCOMPLETE" "STUCK/DEAD" "" #f))
	     (debug:print 2 "NOTE: " test-name " is already running")))
	(else      
	 (debug:print 0 "ERROR: Failed to launch test " full-test-name ". Unrecognised state " (test:get-state testdat))
	 (case (string->symbol (test:get-state testdat)) 
	   ((COMPLETED INCOMPLETE)
	    (hash-table-set! test-registry (runs:make-full-test-name test-name test-path) 'DONOTRUN))
	   (else
	    (hash-table-set! test-registry (runs:make-full-test-name test-name test-path) 'DONOTRUN))))))))

;;======================================================================
;; END OF NEW STUFF
;;======================================================================

(define (get-dir-up-n dir . params) 
  (let ((dparts  (string-split dir "/"))







>
|








|








|

>
|
|
|
|
|
|
>
|
|




|

|







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
	       (let ((skip-test   #f)
		     (skip-check  (configf:get-section test-conf "skip")))
		 (cond 
		  ;; Have to check for skip conditions. This one skips if there are same-named tests
		  ;; currently running
		  ((and skip-check
			(configf:lookup test-conf "skip" "prevrunning"))
		   ;; run-ids = #f means *all* runs
		   (let ((running-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f)))
		     (if (not (null? running-tests)) ;; have to skip 
			 (set! skip-test "Skipping due to previous tests running"))))
		  ((and skip-check
			(configf:lookup test-conf "skip" "fileexists"))
		   (if (file-exists? (configf:lookup test-conf "skip" "fileexists"))
		       (set! skip-test (conc "Skipping due to existance of file " (configf:lookup test-conf "skip" "fileexists"))))))
		 (if skip-test
		     (begin
		       (mt:test-set-state-status-by-id run-id test-id "COMPLETED" "SKIP" skip-test)
		       (debug:print-info 1 "SKIPPING Test " full-test-name " due to " skip-test))
		     (if (not (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat flags))
			 (begin
			   (print "ERROR: Failed to launch the test. Exiting as soon as possible")
			   (set! *globalexitstatus* 1) ;; 
			   (process-signal (current-process-id) signal/kill))))))))
	((KILLED) 
	 (debug:print 1 "NOTE: " full-test-name " is already running or was explictly killed, use -force to launch it.")
	 (hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)) ;; KILLED))
	((LAUNCHED REMOTEHOSTSTART RUNNING)  
	 (debug:print 2 "NOTE: " test-name " is already running"))
	;; (if (> (- (current-seconds)(+ (db:test-get-event_time testdat)
	;; 			       (db:test-get-run_duration testdat)))
	;; 	(or incomplete-timeout
	;; 	    6000)) ;; i.e. no update for more than 6000 seconds
	;;      (begin
	;;        (debug:print 0 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD")
	;;        (tests:test-set-status! run-id test-id "INCOMPLETE" "STUCK/DEAD" "" #f))
	;;        ;; (tests:test-set-status! test-id "INCOMPLETE" "STUCK/DEAD" "" #f))
	;;      (debug:print 2 "NOTE: " test-name " is already running")))
	(else      
	 (debug:print 0 "ERROR: Failed to launch test " full-test-name ". Unrecognised state " (test:get-state testdat))
	 (case (string->symbol (test:get-state testdat)) 
	   ((COMPLETED INCOMPLETE)
	    (hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN))
	   (else
	    (hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN))))))))

;;======================================================================
;; END OF NEW STUFF
;;======================================================================

(define (get-dir-up-n dir . params) 
  (let ((dparts  (string-split dir "/"))
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362

1363
1364
1365
1366
1367
1368
1369
1370
;; fields are passing in through 
;; action:
;;    'remove-runs
;;    'set-state-status
;;
;; NB// should pass in keys?
;;
(define (runs:operate-on action target runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f)(remove-data-only #f))
  (common:clear-caches) ;; clear all caches
  (let* ((db           #f)

	 (keys         (cdb:remote-run db:get-keys db))
	 (rundat       (mt:get-runs-by-patt keys runnamepatt target))
	 (header       (vector-ref rundat 0))
	 (runs         (vector-ref rundat 1))
	 (states       (if state  (string-split state  ",") '()))
	 (statuses     (if status (string-split status ",") '()))
	 (state-status (if (string? new-state-status) (string-split new-state-status ",") '(#f #f))))
    (debug:print-info 4 "runs:operate-on => Header: " header " action: " action " new-state-status: " new-state-status)







|


>
|







1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
;; fields are passing in through 
;; action:
;;    'remove-runs
;;    'set-state-status
;;
;; NB// should pass in keys?
;;
(define (runs:operate-on action target runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f)(mode 'remove-all)(options '()))
  (common:clear-caches) ;; clear all caches
  (let* ((db           #f)
	 (tdbdat       (tasks:open-db))
	 (keys         (rmt:get-keys))
	 (rundat       (mt:get-runs-by-patt keys runnamepatt target))
	 (header       (vector-ref rundat 0))
	 (runs         (vector-ref rundat 1))
	 (states       (if state  (string-split state  ",") '()))
	 (statuses     (if status (string-split status ",") '()))
	 (state-status (if (string? new-state-status) (string-split new-state-status ",") '(#f #f))))
    (debug:print-info 4 "runs:operate-on => Header: " header " action: " action " new-state-status: " new-state-status)
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
						    testpatt states statuses
						    not-in:  #f
						    sort-by: (case action
							       ((remove-runs) 'rundir)
							       (else          'event_time))))))
	 (let* ((run-id    (db:get-value-by-header run header "id"))
		(run-state (db:get-value-by-header run header "state"))

		(tests     (if (not (equal? run-state "locked"))
			       (proc-get-tests run-id)
			       '()))
		(lasttpath "/does/not/exist/I/hope"))

	   (debug:print-info 4 "runs:operate-on run=" run ", header=" header)
	   (if (not (null? tests))
	       (begin
		 (case action
		   ((remove-runs)





		    (debug:print 1 "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname")))
		   ((set-state-status)

		    (debug:print 1 "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname")))
		   ((print-run)
		    (debug:print 1 "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header)
		    action)
		   ((run-wait)
		    (debug:print 1 "Waiting for run " runkey ", run=" runnamepatt " to complete"))






		   (else





		    (debug:print-info 0 "action not recognised " action)))



		 (let ((sorted-tests     (sort tests (lambda (a b)(let ((dira (db:test-get-rundir a))




									(dirb (db:test-get-rundir b)))
								    (if (and (string? dira)(string? dirb))
									(> (string-length dira)(string-length dirb))
									#f)))))
		       (toplevel-retries (make-hash-table)) ;; try three times to loop through and remove top level tests
		       (test-retry-time  (make-hash-table))
		       (allow-run-time   10)) ;; seconds to allow for killing tests before just brutally killing 'em
		   (let loop ((test (car sorted-tests))
			      (tal  (cdr sorted-tests)))
		     (let* ((test-id       (db:test-get-id test))
			    (new-test-dat  (cdb:get-test-info-by-id *runremote* test-id)))
		       (if (not new-test-dat)
			   (begin
			     (debug:print 0 "ERROR: We have a test-id of " test-id " but no record was found. NOTE: No locking of records is done between processes, do not simultaneously remove the same run from two processes!")
			     (if (not (null? tal))
				 (loop (car tal)(cdr tal))))
			   (let* ((item-path     (db:test-get-item-path new-test-dat))
				  (test-name     (db:test-get-testname new-test-dat))



				  (test-state    (db:test-get-state new-test-dat))
				  (test-fulln    (db:test-get-fullname new-test-dat))
				  (uname         (db:test-get-uname    new-test-dat))
				  (toplevel-with-children (and (db:test-get-is-toplevel test)
							       (> (cdb:remote-run db:test-toplevel-num-items db run-id test-name) 0))))
			     (case action
			       ((remove-runs)
				;; if the test is a toplevel-with-children issue an error and do not remove
				(if toplevel-with-children
				    (begin
				      (debug:print 0 "WARNING: skipping removal of " test-fulln " with run-id " run-id " as it has sub tests")
				      (hash-table-set! toplevel-retries test-fulln (+ (hash-table-ref/default toplevel-retries test-fulln 0) 1))







>



|
>





>
>
>
>
>


>






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

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






|







>
>
>




|







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
						    testpatt states statuses
						    not-in:  #f
						    sort-by: (case action
							       ((remove-runs) 'rundir)
							       (else          'event_time))))))
	 (let* ((run-id    (db:get-value-by-header run header "id"))
		(run-state (db:get-value-by-header run header "state"))
		(run-name  (db:get-value-by-header run header "runname"))
		(tests     (if (not (equal? run-state "locked"))
			       (proc-get-tests run-id)
			       '()))
		(lasttpath "/does/not/exist/I/hope")
		(worker-thread #f))
	   (debug:print-info 4 "runs:operate-on run=" run ", header=" header)
	   (if (not (null? tests))
	       (begin
		 (case action
		   ((remove-runs)
		    (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10))
		    ;; seek and kill in flight -runtests with % as testpatt here
		    (if (equal? testpatt "%")
			(tasks:kill-runner target run-name)
			(debug:print 0 "not attempting to kill any run launcher processes as testpatt is " testpatt))
		    (debug:print 1 "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname")))
		   ((set-state-status)
		    (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10))
		    (debug:print 1 "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname")))
		   ((print-run)
		    (debug:print 1 "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header)
		    action)
		   ((run-wait)
		    (debug:print 1 "Waiting for run " runkey ", run=" runnamepatt " to complete"))
		   ((archive)
		    (debug:print 1 "Archiving/restoring (" (args:get-arg "-archive") ") data for run: " runkey " " (db:get-value-by-header run header "runname"))
		    (set! worker-thread (make-thread (lambda ()
						       (case (string->symbol (args:get-arg "-archive"))
							 ((save save-remove keep-html)(archive:run-bup (args:get-arg "-archive") run-id run-name tests))
							 ((restore)(archive:bup-restore (args:get-arg "-archive") run-id run-name tests))
							 (else 
							  (debug:print 0 "ERROR: unrecognised sub command to -archive. Run \"megatest\" to see help")
							  (exit))))
						     "archive-bup-thread"))
		    (thread-start! worker-thread))
		   (else
		    (debug:print-info 0 "action not recognised " action)))
		 
		 ;; actions that operate on one test at a time can be handled below
		 ;;
		 (let ((sorted-tests     (filter 
					  vector?
					  (sort tests (lambda (a b)(let ((dira ;; (rmt:sdb-qry 'getstr 
									  (db:test-get-rundir a)) ;; )  ;; (filedb:get-path *fdb* (db:test-get-rundir a)))
									 (dirb ;; (rmt:sdb-qry 'getstr 
									  (db:test-get-rundir b))) ;; ) ;; ((filedb:get-path *fdb* (db:test-get-rundir b))))
								     (if (and (string? dira)(string? dirb))
									 (> (string-length dira)(string-length dirb))
									 #f))))))
		       (toplevel-retries (make-hash-table)) ;; try three times to loop through and remove top level tests
		       (test-retry-time  (make-hash-table))
		       (allow-run-time   10)) ;; seconds to allow for killing tests before just brutally killing 'em
		   (let loop ((test (car sorted-tests))
			      (tal  (cdr sorted-tests)))
		     (let* ((test-id       (db:test-get-id test))
			    (new-test-dat  (rmt:get-test-info-by-id run-id test-id)))
		       (if (not new-test-dat)
			   (begin
			     (debug:print 0 "ERROR: We have a test-id of " test-id " but no record was found. NOTE: No locking of records is done between processes, do not simultaneously remove the same run from two processes!")
			     (if (not (null? tal))
				 (loop (car tal)(cdr tal))))
			   (let* ((item-path     (db:test-get-item-path new-test-dat))
				  (test-name     (db:test-get-testname new-test-dat))
				  (run-dir       ;;(filedb:get-path *fdb*
				   ;; (rmt:sdb-qry 'getid 
				   (db:test-get-rundir new-test-dat)) ;; )    ;; run dir is from the link tree
				  (test-state    (db:test-get-state new-test-dat))
				  (test-fulln    (db:test-get-fullname new-test-dat))
				  (uname         (db:test-get-uname    new-test-dat))
				  (toplevel-with-children (and (db:test-get-is-toplevel test)
							       (> (rmt:test-toplevel-num-items run-id test-name) 0))))
			     (case action
			       ((remove-runs)
				;; if the test is a toplevel-with-children issue an error and do not remove
				(if toplevel-with-children
				    (begin
				      (debug:print 0 "WARNING: skipping removal of " test-fulln " with run-id " run-id " as it has sub tests")
				      (hash-table-set! toplevel-retries test-fulln (+ (hash-table-ref/default toplevel-retries test-fulln 0) 1))
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
						  (hash-table-set! test-retry-time test-fulln (current-seconds))))
					    (if (> (- (current-seconds)(hash-table-ref test-retry-time test-fulln)) allow-run-time)
						;; This test is not in a correct state for cleaning up. Let's try some graceful shutdown steps first
						;; Set the test to "KILLREQ" and wait five seconds then try again. Repeat up to five times then give
						;; up and blow it away.
						(begin
						  (debug:print 0 "WARNING: could not gracefully remove test " test-fulln ", tried to kill it to no avail. Forcing state to FAILEDKILL and continuing")
						  (mt:test-set-state-status-by-id (db:test-get-id test) "FAILEDKILL" "n/a" #f)
						  (thread-sleep! 1))
						(begin
						  (mt:test-set-state-status-by-id (db:test-get-id test) "KILLREQ" "n/a" #f)
						  (thread-sleep! 1)))
					    ;; NOTE: This is suboptimal as the testdata will be used later and the state/status may have changed ...
					    (if (null? tal)
						(loop new-test-dat tal)
						(loop (car tal)(append tal (list new-test-dat)))))
					  (begin
					    (runs:remove-test-directory db new-test-dat remove-data-only)
					    (if (not (null? tal))
						(loop (car tal)(cdr tal))))))))
			       ((set-state-status)
				(debug:print-info 2 "new state " (car state-status) ", new status " (cadr state-status))
				(mt:test-set-state-status-by-id (db:test-get-id test) (car state-status)(cadr state-status) #f)
				(if (not (null? tal))
				    (loop (car tal)(cdr tal))))
			       ((run-wait)
				(debug:print-info 2 "still waiting, " (length tests) " tests still running")
				(thread-sleep! 10)
				(let ((new-tests (proc-get-tests run-id)))
				  (if (null? new-tests)
				      (debug:print-info 1 "Run completed according to zero tests matching provided criteria.")
				      (loop (car new-tests)(cdr new-tests))))))))








		       )))))


	   ;; remove the run if zero tests remain
	   (if (eq? action 'remove-runs)
	       (let ((remtests (mt:get-tests-for-run (db:get-value-by-header run header "id") #f '("DELETED") '("n/a") not-in: #t)))
		 (if (null? remtests) ;; no more tests remaining
		     (let* ((dparts  (string-split lasttpath "/"))
			    (runpath (conc "/" (string-intersperse 
						(take dparts (- (length dparts) 1))
						"/"))))
		       (debug:print 1 "Removing run: " runkey " " (db:get-value-by-header run header "runname") " and related record")
		       (cdb:remote-run db:delete-run db run-id)
		       ;; This is a pretty good place to purge old DELETED tests
		       (cdb:remote-run db:delete-tests-for-run db run-id)
		       (cdb:remote-run db:delete-old-deleted-test-records db)
		       (cdb:remote-run db:set-var db "DELETED_TESTS" (current-seconds))
		       ;; need to figure out the path to the run dir and remove it if empty
		       ;;    (if (null? (glob (conc runpath "/*")))
		       ;;        (begin
		       ;; 	 (debug:print 1 "Removing run dir " runpath)
		       ;; 	 (system (conc "rmdir -p " runpath))))
		       )))))
	 ))
     runs))


  #t)

(define (runs:remove-test-directory db test remove-data-only)
  (let* ((run-dir       (db:test-get-rundir test))    ;; run dir is from the link tree
	 (real-dir      (if (file-exists? run-dir)
			    (resolve-pathname run-dir)
			    #f)))

    (if (not remove-data-only)
	(mt:test-set-state-status-by-id (db:test-get-id test) "REMOVING" "LOCKED" #f))

    (debug:print-info 1 "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir)
    (if (and real-dir 
	     (> (string-length real-dir) 5)
	     (file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc.
	(begin ;; let* ((realpath (resolve-pathname run-dir)))
	  (debug:print-info 1 "Recursively removing " real-dir)
	  (if (file-exists? real-dir)







|


|






|




|








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









|
<
<
|
|







|
>
>


|




>
|
|
>







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
						  (hash-table-set! test-retry-time test-fulln (current-seconds))))
					    (if (> (- (current-seconds)(hash-table-ref test-retry-time test-fulln)) allow-run-time)
						;; This test is not in a correct state for cleaning up. Let's try some graceful shutdown steps first
						;; Set the test to "KILLREQ" and wait five seconds then try again. Repeat up to five times then give
						;; up and blow it away.
						(begin
						  (debug:print 0 "WARNING: could not gracefully remove test " test-fulln ", tried to kill it to no avail. Forcing state to FAILEDKILL and continuing")
					    (mt:test-set-state-status-by-id run-id (db:test-get-id test) "FAILEDKILL" "n/a" #f)
						  (thread-sleep! 1))
						(begin
					    (mt:test-set-state-status-by-id run-id (db:test-get-id test) "KILLREQ" "n/a" #f)
						  (thread-sleep! 1)))
					    ;; NOTE: This is suboptimal as the testdata will be used later and the state/status may have changed ...
					    (if (null? tal)
						(loop new-test-dat tal)
						(loop (car tal)(append tal (list new-test-dat)))))
					  (begin
					    (runs:remove-test-directory new-test-dat mode) ;; 'remove-all)
					    (if (not (null? tal))
						(loop (car tal)(cdr tal))))))))
			       ((set-state-status)
				(debug:print-info 2 "new state " (car state-status) ", new status " (cadr state-status))
				(mt:test-set-state-status-by-id run-id (db:test-get-id test) (car state-status)(cadr state-status) #f)
				(if (not (null? tal))
				    (loop (car tal)(cdr tal))))
			       ((run-wait)
				(debug:print-info 2 "still waiting, " (length tests) " tests still running")
				(thread-sleep! 10)
				(let ((new-tests (proc-get-tests run-id)))
				  (if (null? new-tests)
				      (debug:print-info 1 "Run completed according to zero tests matching provided criteria.")
				      (loop (car new-tests)(cdr new-tests)))))
			       ((archive)
				(if (not toplevel-with-children)
				    (case (string->symbol (args:get-arg "-archive"))
				      ((save save-remove keep-html)
				       (debug:print-info 0 "Estimating disk space usage for " test-fulln)
				       (debug:print-info 0 "   " (common:get-disk-space-used (conc run-dir "/"))))))
				(if (not (null? tal))
				    (loop (car tal)(cdr tal))))
			       )))
		       )
		     (if worker-thread (thread-join! worker-thread))))))
	   ;; remove the run if zero tests remain
	   (if (eq? action 'remove-runs)
	       (let ((remtests (mt:get-tests-for-run (db:get-value-by-header run header "id") #f '("DELETED") '("n/a") not-in: #t)))
		 (if (null? remtests) ;; no more tests remaining
		     (let* ((dparts  (string-split lasttpath "/"))
			    (runpath (conc "/" (string-intersperse 
						(take dparts (- (length dparts) 1))
						"/"))))
		       (debug:print 1 "Removing run: " runkey " " (db:get-value-by-header run header "runname") " and related record")
		       (rmt:delete-run run-id)


		       (rmt:delete-old-deleted-test-records)
		       ;; (cdb:remote-run db:set-var db "DELETED_TESTS" (current-seconds))
		       ;; need to figure out the path to the run dir and remove it if empty
		       ;;    (if (null? (glob (conc runpath "/*")))
		       ;;        (begin
		       ;; 	 (debug:print 1 "Removing run dir " runpath)
		       ;; 	 (system (conc "rmdir -p " runpath))))
		       )))))
	 ))
     runs)
    ;; (sqlite3:finalize! (db:delay-if-busy tdbdat))
    )
  #t)

(define (runs:remove-test-directory test mode) ;; remove-data-only)
  (let* ((run-dir       (db:test-get-rundir test))    ;; run dir is from the link tree
	 (real-dir      (if (file-exists? run-dir)
			    (resolve-pathname run-dir)
			    #f)))
    (case mode
      ((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 "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir)
    (if (and real-dir 
	     (> (string-length real-dir) 5)
	     (file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc.
	(begin ;; let* ((realpath (resolve-pathname run-dir)))
	  (debug:print-info 1 "Recursively removing " real-dir)
	  (if (file-exists? real-dir)
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
	(if (directory? run-dir)
	    (if (> (directory-fold (lambda (f x)(+ 1 x)) 0 run-dir) 0)
		(debug:print 0 "WARNING: refusing to remove " run-dir " as it is not empty")
		(handle-exceptions
		 exn
		 (debug:print 0 "ERROR:  Failed to remove directory " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue")
		 (delete-directory run-dir)))
	    (if run-dir

		(debug:print 0 "WARNING: not removing " run-dir " as it either doesn't exist or is not a symlink")
		(debug:print 0 "NOTE: the run dir for this test is undefined. Test may have already been deleted."))
	    ))
    ;; Only delete the records *after* removing the directory. If things fail we have a record 

    (if (not remove-data-only)

	(cdb:remote-run db:delete-test-records db #f (db:test-get-id test)))))

;;======================================================================
;; Routines for manipulating runs
;;======================================================================

;; Since many calls to a run require pretty much the same setup 
;; this wrapper is used to reduce the replication of code
(define (general-run-call switchname action-desc proc)
  (let ((runname (or (args:get-arg "-runname")(args:get-arg ":runname")))
	(target  (common:args-get-target)))
    (cond
     ((not target)
      (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the target with -target")
      (exit 3))
     ((not runname)
      (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the run name with -runname runname")
      (exit 3))
     (else
      (let ((db   #f)
	    (keys #f))
	(if (not (launch:setup-for-run))

	    (begin 
	      (debug:print 0 "Failed to setup, exiting")
	      (exit 1)))
	;; (if (args:get-arg "-server")
	;;     (cdb:remote-run server:start db (args:get-arg "-server")))
	(set! keys (keys:config-get-fields *configdat*))
	;; have enough to process -target or -reqtarg here
	(if (args:get-arg "-reqtarg")
	    (let* ((runconfigf (conc  *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL 
		   (runconfig  (read-config runconfigf #f #t environ-patt: #f)))
	      (if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f)
		  (keys:target-set-args keys (args:get-arg "-reqtarg") args:arg-hash)
		    
		  (begin
		    (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf)
		    (if db (sqlite3:finalize! db))
		    (exit 1))))

	    (if (args:get-arg "-target")
		(keys:target-set-args keys (args:get-arg "-target" args:arg-hash) args:arg-hash)))
	(if (not (car *configinfo*))
	    (begin
	      (debug:print 0 "ERROR: Attempted to " action-desc " but run area config file not found")
	      (exit 1))
	    ;; Extract out stuff needed in most or many calls
	    ;; here then call proc
	    (let* ((keyvals    (keys:target->keyval keys target)))
	      (proc target runname keys keyvals)))
	(if db (sqlite3:finalize! db))
	(set! *didsomething* #t))))))

;;======================================================================
;; Lock/unlock runs
;;======================================================================

(define (runs:handle-locking target keys runname lock unlock user)
  (let* ((db       #f)
	 (rundat   (mt:get-runs-by-patt keys runname target))
	 (header   (vector-ref rundat 0))
	 (runs     (vector-ref rundat 1)))
    (for-each (lambda (run)
		(let ((run-id (db:get-value-by-header run header "id")))
		  (if (or lock
			  (and unlock
			       (begin
				 (print "Do you really wish to unlock run " run-id "?\n   y/n: ")
				 (equal? "y" (read-line)))))
		      (cdb:remote-run db:lock/unlock-run db run-id lock unlock user)
		      (debug:print-info 0 "Skipping lock/unlock on " run-id))))
	      runs)))
;;======================================================================
;; Rollup runs
;;======================================================================

;; Update the test_meta table for this test
(define (runs:update-test_meta test-name test-conf)
  (let ((currrecord (cdb:remote-run db:testmeta-get-record #f test-name)))
    (if (not currrecord)
	(begin
	  (set! currrecord (make-vector 11 #f))
	  (cdb:remote-run db:testmeta-add-record #f test-name)))
    (for-each 
     (lambda (key)
       (let* ((idx (cadr key))
	      (fld (car  key))
	      (val (config-lookup test-conf "test_meta" fld)))
	 ;; (debug:print 5 "idx: " idx " fld: " fld " val: " val)
	 (if (and val (not (equal? (vector-ref currrecord idx) val)))
	     (begin
	       (print "Updating " test-name " " fld " to " val)
	       (cdb:remote-run db:testmeta-update-field #f test-name fld val)))))
     '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)("jobgroup" 10)))))

;; Update test_meta for all tests
(define (runs:update-all-test_meta db)
  (let ((test-names (tests:get-all))) ;; (tests:get-valid-tests)))
    (for-each 
     (lambda (test-name)
       (let* ((test-conf    (mt:lazy-read-test-config test-name)))
	 ;; use the cdb:remote-run instead of passing in db
	 (if test-conf (runs:update-test_meta test-name test-conf))))
     (hash-table-keys test-names))))

;; This could probably be refactored into one complex query ...


(define (runs:rollup-run keys runname user keyvals)
  (debug:print 4 "runs:rollup-run, keys: " keys " -runname " runname " user: " user)
  (let* ((db              #f)

	 (new-run-id      (cdb:remote-run db:register-run #f keyvals runname "new" "n/a" user))
	 (prev-tests      (cdb:remote-run test:get-matching-previous-test-run-records db new-run-id "%" "%"))
	 (curr-tests      (mt:get-tests-for-run new-run-id "%/%" '() '()))
	 (curr-tests-hash (make-hash-table)))
    (cdb:remote-run db:update-run-event_time db new-run-id)
    ;; index the already saved tests by testname and itemdat in curr-tests-hash
    (for-each
     (lambda (testdat)
       (let* ((testname  (db:test-get-testname testdat))
	      (item-path (db:test-get-item-path testdat))
	      (full-name (conc testname "/" item-path)))
	 (hash-table-set! curr-tests-hash full-name testdat)))
     curr-tests)
    ;; NOPE: Non-optimal approach. Try this instead.
    ;;   1. tests are received in a list, most recent first
    ;;   2. replace the rollup test with the new *always*
    (for-each 
     (lambda (testdat)
       (let* ((testname  (db:test-get-testname testdat))
	      (item-path (db:test-get-item-path testdat))
	      (full-name (conc testname "/" item-path))
	      (prev-test-dat (hash-table-ref/default curr-tests-hash full-name #f))
	      (test-steps    (cdb:remote-run db:get-steps-for-test db (db:test-get-id testdat)))
	      (new-test-record #f))
	 ;; replace these with insert ... select
	 (apply sqlite3:execute 
		db 
		(conc "INSERT OR REPLACE INTO tests (run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment) "
		      "VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?);")
		new-run-id (cddr (vector->list testdat)))







|
>




>
|
>
|


















|

|
>















|
|
>










|


















|








|



|









|








<




>
>



>
|
|


|

















|







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
	(if (directory? run-dir)
	    (if (> (directory-fold (lambda (f x)(+ 1 x)) 0 run-dir) 0)
		(debug:print 0 "WARNING: refusing to remove " run-dir " as it is not empty")
		(handle-exceptions
		 exn
		 (debug:print 0 "ERROR:  Failed to remove directory " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue")
		 (delete-directory run-dir)))
	    (if (and run-dir
		     (not (member run-dir (list "n/a" "/tmp/badname"))))
		(debug:print 0 "WARNING: not removing " run-dir " as it either doesn't exist or is not a symlink")
		(debug:print 0 "NOTE: the run dir for this test is undefined. Test may have already been deleted."))
	    ))
    ;; Only delete the records *after* removing the directory. If things fail we have a record 
    (case mode
      ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "NOT_STARTED" "n/a" #f))
      ((archive-remove)  (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVED" #f #f))
      (else (rmt:delete-test-records (db:test-get-run_id test) (db:test-get-id test))))))

;;======================================================================
;; Routines for manipulating runs
;;======================================================================

;; Since many calls to a run require pretty much the same setup 
;; this wrapper is used to reduce the replication of code
(define (general-run-call switchname action-desc proc)
  (let ((runname (or (args:get-arg "-runname")(args:get-arg ":runname")))
	(target  (common:args-get-target)))
    (cond
     ((not target)
      (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the target with -target")
      (exit 3))
     ((not runname)
      (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the run name with -runname runname")
      (exit 3))
     (else
      (let (;; (db   #f)
	    (keys #f))
	(if (launch:setup-for-run)
	    (launch:cache-config)
	    (begin 
	      (debug:print 0 "Failed to setup, exiting")
	      (exit 1)))
	;; (if (args:get-arg "-server")
	;;     (cdb:remote-run server:start db (args:get-arg "-server")))
	(set! keys (keys:config-get-fields *configdat*))
	;; have enough to process -target or -reqtarg here
	(if (args:get-arg "-reqtarg")
	    (let* ((runconfigf (conc  *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL 
		   (runconfig  (read-config runconfigf #f #t environ-patt: #f)))
	      (if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f)
		  (keys:target-set-args keys (args:get-arg "-reqtarg") args:arg-hash)
		    
		  (begin
		    (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf)
		    ;; (if db (sqlite3:finalize! db))
		    (exit 1)
		    )))
	    (if (args:get-arg "-target")
		(keys:target-set-args keys (args:get-arg "-target" args:arg-hash) args:arg-hash)))
	(if (not (car *configinfo*))
	    (begin
	      (debug:print 0 "ERROR: Attempted to " action-desc " but run area config file not found")
	      (exit 1))
	    ;; Extract out stuff needed in most or many calls
	    ;; here then call proc
	    (let* ((keyvals    (keys:target->keyval keys target)))
	      (proc target runname keys keyvals)))
	;; (if db (sqlite3:finalize! db))
	(set! *didsomething* #t))))))

;;======================================================================
;; Lock/unlock runs
;;======================================================================

(define (runs:handle-locking target keys runname lock unlock user)
  (let* ((db       #f)
	 (rundat   (mt:get-runs-by-patt keys runname target))
	 (header   (vector-ref rundat 0))
	 (runs     (vector-ref rundat 1)))
    (for-each (lambda (run)
		(let ((run-id (db:get-value-by-header run header "id")))
		  (if (or lock
			  (and unlock
			       (begin
				 (print "Do you really wish to unlock run " run-id "?\n   y/n: ")
				 (equal? "y" (read-line)))))
		      (rmt:lock/unlock-run run-id lock unlock user)
		      (debug:print-info 0 "Skipping lock/unlock on " run-id))))
	      runs)))
;;======================================================================
;; Rollup runs
;;======================================================================

;; Update the test_meta table for this test
(define (runs:update-test_meta test-name test-conf)
  (let ((currrecord (rmt:testmeta-get-record test-name)))
    (if (not currrecord)
	(begin
	  (set! currrecord (make-vector 11 #f))
	  (rmt:testmeta-add-record test-name)))
    (for-each 
     (lambda (key)
       (let* ((idx (cadr key))
	      (fld (car  key))
	      (val (config-lookup test-conf "test_meta" fld)))
	 ;; (debug:print 5 "idx: " idx " fld: " fld " val: " val)
	 (if (and val (not (equal? (vector-ref currrecord idx) val)))
	     (begin
	       (print "Updating " test-name " " fld " to " val)
	       (rmt:testmeta-update-field test-name fld val)))))
     '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)("jobgroup" 10)))))

;; Update test_meta for all tests
(define (runs:update-all-test_meta db)
  (let ((test-names (tests:get-all))) ;; (tests:get-valid-tests)))
    (for-each 
     (lambda (test-name)
       (let* ((test-conf    (mt:lazy-read-test-config test-name)))

	 (if test-conf (runs:update-test_meta test-name test-conf))))
     (hash-table-keys test-names))))

;; This could probably be refactored into one complex query ...
;; NOT PORTED - DO NOT USE YET
;;
(define (runs:rollup-run keys runname user keyvals)
  (debug:print 4 "runs:rollup-run, keys: " keys " -runname " runname " user: " user)
  (let* ((db              #f)
	 ;; register run operates on the main db
	 (new-run-id      (rmt:register-run keyvals runname "new" "n/a" user))
	 (prev-tests      (rmt:get-matching-previous-test-run-records new-run-id "%" "%"))
	 (curr-tests      (mt:get-tests-for-run new-run-id "%/%" '() '()))
	 (curr-tests-hash (make-hash-table)))
    (rmt:update-run-event_time new-run-id)
    ;; index the already saved tests by testname and itemdat in curr-tests-hash
    (for-each
     (lambda (testdat)
       (let* ((testname  (db:test-get-testname testdat))
	      (item-path (db:test-get-item-path testdat))
	      (full-name (conc testname "/" item-path)))
	 (hash-table-set! curr-tests-hash full-name testdat)))
     curr-tests)
    ;; NOPE: Non-optimal approach. Try this instead.
    ;;   1. tests are received in a list, most recent first
    ;;   2. replace the rollup test with the new *always*
    (for-each 
     (lambda (testdat)
       (let* ((testname  (db:test-get-testname testdat))
	      (item-path (db:test-get-item-path testdat))
	      (full-name (conc testname "/" item-path))
	      (prev-test-dat (hash-table-ref/default curr-tests-hash full-name #f))
	      (test-steps    (rmt:get-steps-for-test (db:test-get-id testdat)))
	      (new-test-record #f))
	 ;; replace these with insert ... select
	 (apply sqlite3:execute 
		db 
		(conc "INSERT OR REPLACE INTO tests (run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment) "
		      "VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?);")
		new-run-id (cddr (vector->list testdat)))

Modified sdb.scm from [3abf0b5c48] to [b5405355dd].

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

;; 
(define (sdb:open) ;;  (conc *toppath* "/megatest.db") (car *configinfo*)))
  (if (not *toppath*)
      (if (not (launch:setup-for-run))
	  (begin
	    (debug:print 0 "ERROR: Attempted to open db when not in megatest area. Exiting.")
	    (exit))))
  (let* ((dbpath    (conc *toppath* "/db/sdb.db")) ;; fname)
	 (dbexists  (let ((fe (file-exists? dbpath)))
		      (if fe 
			  fe
			  (begin
			    (create-directory (conc *toppath* "/db") #t)
			    #f))))
	 (sdb        (sqlite3:open-database dbpath))
	 (handler   (make-busy-timeout (if (args:get-arg "-override-timeout")
					   (string->number (args:get-arg "-override-timeout"))
					   136000))))
    (sqlite3:set-busy-handler! sdb handler)
    (if (not dbexists)
	(sdb:initialize sdb))
    (sqlite3:execute sdb "PRAGMA synchronous = 1;")
    sdb))

(define (sdb:initialize sdb)
  (sqlite3:execute sdb "CREATE TABLE IF NOT EXISTS strs
                           (id  INTEGER PRIMARY KEY,
                            str TEXT,
                        CONSTRAINT str UNIQUE (str));")
  (sqlite3:execute sdb "CREATE INDEX strindx ON strs (str);"))

;; (define sumup (let ((a 0))(lambda (x)(set! a (+ x a)) a)))

(define (sdb:register-string sdb str)
  (sqlite3:execute sdb "INSERT OR IGNORE INTO strs (str) VALUES (?);" str))

(define (sdb:string->id sdb str-cache str)







|
<
<
<
<
<
|
|



|

|
|
<
<











|







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

;; 
(define (sdb:open fname)





  (let* ((dbpath    (pathname-directory fname))
	 (dbexists  (let ((fe (file-exists? fname)))
		      (if fe 
			  fe
			  (begin
			    (create-directory dbpath #t)
			    #f))))
	 (sdb        (sqlite3:open-database fname))
	 (handler   (make-busy-timeout 136000)))


    (sqlite3:set-busy-handler! sdb handler)
    (if (not dbexists)
	(sdb:initialize sdb))
    (sqlite3:execute sdb "PRAGMA synchronous = 1;")
    sdb))

(define (sdb:initialize sdb)
  (sqlite3:execute sdb "CREATE TABLE IF NOT EXISTS strs
                           (id  INTEGER PRIMARY KEY,
                            str TEXT,
                        CONSTRAINT str UNIQUE (str));")
  (sqlite3:execute sdb "CREATE INDEX IF NOT EXISTS strindx ON strs (str);"))

;; (define sumup (let ((a 0))(lambda (x)(set! a (+ x a)) a)))

(define (sdb:register-string sdb str)
  (sqlite3:execute sdb "INSERT OR IGNORE INTO strs (str) VALUES (?);" str))

(define (sdb:string->id sdb str-cache str)
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
	 (lambda (istr)
	   (set! str istr)
	   (hash-table-set! id-cache id str))
	 sdb
	 "SELECT str FROM strs WHERE id=?;" id))
    str))



(define sdb:qry
  (let ((sdb    #f)
	(scache (make-hash-table))
	(icache (make-hash-table)))
    (lambda (cmd var)
      (if (not sdb)(set! sdb (sdb:open)))
      (case cmd
	((init)      (if (not sdb)(set! sdb (sdb:open))))





	((finalize!) (if sdb (sqlite3:finalize! sdb)))




	((getid)     (let ((id (sdb:string->id sdb scache var)))
		       (if id
			   id
			   (begin
			     (sdb:register-string sdb var)
			     (sdb:string->id sdb scache var)))))
	((getstr)    (if (or (number? var)
			     (string->number var))
			 (sdb:id->string sdb icache var)
			 var))


	(else #f)))))








>
>
|




<

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









>
>


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
	 (lambda (istr)
	   (set! str istr)
	   (hash-table-set! id-cache id str))
	 sdb
	 "SELECT str FROM strs WHERE id=?;" id))
    str))

;; Numbers get passed though in both directions
;;
(define (make-sdb:qry fname)
  (let ((sdb    #f)
	(scache (make-hash-table))
	(icache (make-hash-table)))
    (lambda (cmd var)

      (case cmd
	((setup)   (set! sdb (if (not sdb)
				 (sdb:open (if var var fname)))))
	((setdb)    (set! sdb var))
	((getdb)    sdb)
	((finalize) (if sdb
			(begin
			  (sqlite3:finalize! sdb)
			  (set! sdb #f))))
	((getid)     (let ((id (if (or (number? var)
				       (string->number var))
				   var
				   (sdb:string->id sdb scache var))))
		       (if id
			   id
			   (begin
			     (sdb:register-string sdb var)
			     (sdb:string->id sdb scache var)))))
	((getstr)    (if (or (number? var)
			     (string->number var))
			 (sdb:id->string sdb icache var)
			 var))
	((passid)    var)
	((passstr)   var)
	(else #f)))))

Modified server.scm from [c908dcbcbb] to [d9e8792ebb].

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

;; Copyright 2006-2012, 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.

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

(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)
;; (use zmq)

(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 zmq-transport))
(declare (uses daemon))

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

(define (server:make-server-url hostport)
  (if (not hostport)












|











>
>
|







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

;; Copyright 2006-2012, 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.

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

(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest directory-utils)
;; (use zmq)

(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 nmsg-transport))
(declare (uses launch))
(declare (uses daemon))

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

(define (server:make-server-url hostport)
  (if (not hostport)
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

;; S E R V E R
;;======================================================================

;; Call this to start the actual server
;;

;; all routes though here end in exit ...



(define (server:launch transport)
  (if (not *toppath*)
      (if (not (launch:setup-for-run))
	  (begin
	    (debug:print 0 "ERROR: cannot find megatest.config, exiting")
	    (exit))))
  (debug:print-info 2 "Starting server using " transport " transport")
  (set! *transport-type* transport)
  (case transport
    ((fs)   (exit)) ;; there is no "fs" server transport
    ((http) (http-transport:launch))
    ((zmq)  (zmq-transport:launch))
    (else
     (debug:print "WARNING: unrecognised transport " transport)
     (exit))))

;;======================================================================
;; Q U E U E   M A N A G E M E N T
;;======================================================================

;; We don't want to flush the queue if it was just flushed
(define *server:last-write-flush* (current-milliseconds))

;; Flush the queue every third of a second. Can we assume that setup-for-run 
;; has already been done?
(define (server:write-queue-handler)
  (if (launch:setup-for-run)
      (let ((db (open-db)))
	(let loop ()
	  (let ((last-write-flush-time #f))
	    (mutex-lock! *incoming-mutex*)
	    (set! last-write-flush-time *server:last-write-flush*)
	    (mutex-unlock! *incoming-mutex*)
	    (if (> (- (current-milliseconds) last-write-flush-time) 10)
		(begin
		  (mutex-lock! *db:process-queue-mutex*)
		  (db:process-cached-writes db)
		  (mutex-unlock! *db:process-queue-mutex*)
		  (thread-sleep! 0.005))))
	  (loop)))
      (begin
	(debug:print 0 "ERROR: failed to setup for Megatest in server:write-queue-handler")
	(exit 1))))
    
;;======================================================================
;; S E R V E R   U T I L I T I E S 
;;======================================================================












;; Generate a unique signature for this server
(define (server:mk-signature)
  (message-digest-string (md5-primitive) 
			 (with-output-to-string
			   (lambda ()
			     (write (list (current-directory)
					  (argv)))))))


;; When using zmq this would send the message back (two step process)
;; with spiffy or rpc this simply returns the return data to be returned
;; 
(define (server:reply return-addr query-sig success/fail result)
  (debug:print-info 11 "server:reply return-addr=" return-addr ", result=" result)
  ;; (send-message pubsock target send-more: #t)
  ;; (send-message pubsock 
  (case *transport-type*
    ((fs) result)
    ((http)(db:obj->string (vector success/fail query-sig result)))
    ((zmq)
     (let ((pub-socket (vector-ref *runremote* 1)))
       (send-message pub-socket return-addr send-more: #t)
       (send-message pub-socket (db:obj->string (vector success/fail query-sig result)))))

    (else 
     (debug:print 0 "ERROR: unrecognised transport type: " *transport-type*)
     result)))



































(define (server:ensure-running)




  (let loop ((servers  (open-run-close tasks:get-best-server tasks:open-db))

	     (trycount 0))


    (if (or (not servers)
	    (null? servers))

	(begin
	  (if (even? trycount) ;; just do the server start every other time through this loop (every 8 seconds)

	      (let ((cmdln (conc (if (getenv "MT_MEGATEST") (getenv "MT_MEGATEST") "megatest")





				 " -server - -daemonize")))
		(debug:print 0 "INFO: Starting server (" cmdln ") as none running ...")
		;; (server:launch (string->symbol (args:get-arg "-transport" "http"))))
		;; no need to use fork, no need to do the list-servers trick. Just start the damn server, it will exit on it's own



		;; if there is an existing server















		(system cmdln)



		(thread-sleep! 3)
		;; (process-run (car (argv)) (list "-server" "-" "-daemonize" "-transport" (args:get-arg "-transport" "http")))

		)











	      (begin




















		(debug:print-info 0 "Waiting for server to start")






		(thread-sleep! 4)))

	  (if (< trycount 10)




	      (loop (open-run-close tasks:get-best-server tasks:open-db) 
		    (+ trycount 1))








	      (debug:print 0 "WARNING: Couldn't start or find a server.")))

	(debug:print 2 "INFO: Server(s) running " servers)








	)))








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




>
>
>
>
>
>
>
>
>
>
>








<







|
|
|




>




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

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

>
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
;; S E R V E R
;;======================================================================

;; Call this to start the actual server
;;

;; all routes though here end in exit ...
;;
;; start_server
;;
(define (server:launch run-id)






  (case *transport-type*
    ((http)(http-transport:launch run-id))

    ((nmsg)(nmsg-transport:launch run-id))
    ((rpc)  (rpc-transport:launch run-id))



    (else (debug:print 0 "ERROR: unknown server type " *transport-type*))))



;;       (else   (debug:print 0 "ERROR: No known transport set, transport=" transport ", using rpc")


;; 	      (rpc-transport:launch run-id)))))





















;;======================================================================
;; S E R V E R   U T I L I T I E S 
;;======================================================================

;; Get the transport
(define (server:get-transport)
  (if *transport-type*
      *transport-type*
      (let ((ttype (string->symbol
		    (or (args:get-arg "-transport")
			(configf:lookup *configdat* "server" "transport")
			"rpc"))))
	(set! *transport-type* ttype)
	ttype)))
	    
;; Generate a unique signature for this server
(define (server:mk-signature)
  (message-digest-string (md5-primitive) 
			 (with-output-to-string
			   (lambda ()
			     (write (list (current-directory)
					  (argv)))))))


;; When using zmq this would send the message back (two step process)
;; with spiffy or rpc this simply returns the return data to be returned
;; 
(define (server:reply return-addr query-sig success/fail result)
  (debug:print-info 11 "server:reply return-addr=" return-addr ", result=" result)
  ;; (send-message pubsock target send-more: #t)
  ;; (send-message pubsock 
  (case (server:get-transport)
    ((rpc)  (db:obj->string (vector success/fail query-sig result)))
    ((http) (db:obj->string (vector success/fail query-sig result)))
    ((zmq)
     (let ((pub-socket (vector-ref *runremote* 1)))
       (send-message pub-socket return-addr send-more: #t)
       (send-message pub-socket (db:obj->string (vector success/fail query-sig result)))))
    ((fs)   result)
    (else 
     (debug:print 0 "ERROR: unrecognised transport type: " *transport-type*)
     result)))

;; Given a run id start a server process    ### NOTE ### > file 2>&1 
;; if the run-id is zero and the target-host is set 
;; try running on that host
;;
(define  (server:run run-id)
  (let* ((curr-host   (get-host-name))
	 (curr-ip     (server:get-best-guess-address curr-host))
	 (target-host (configf:lookup *configdat* "server" "homehost" ))
	 (testsuite   (common:get-testsuite-name))
	 (logfile     (conc *toppath* "/logs/" run-id ".log"))
	 (cmdln (conc (common:get-megatest-exe)
		      " -server " (or target-host "-") " -run-id " run-id (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes")
									      (conc " -daemonize -log " logfile)
									      "")
		      " -debug 4 testsuite:" testsuite))) ;; (conc " >> " logfile " 2>&1 &")))))
    (debug:print 0 "INFO: Starting server (" cmdln ") as none running ...")
    (push-directory *toppath*)
    (if (not (directory-exists? "logs"))(create-directory "logs"))
    ;; host.domain.tld match host?
    (if (and target-host 
	     ;; look at target host, is it host.domain.tld or ip address and does it 
	     ;; match current ip or hostname
	     (not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host))
	     (not (equal? curr-ip target-host)))
	(begin
	  (debug:print-info 0 "Starting server on " target-host ", logfile is " logfile)
	  (setenv "TARGETHOST" target-host)))
    (setenv "TARGETHOST_LOGF" logfile)
    (system (conc "nbfake " cmdln))
    (unsetenv "TARGETHOST_LOGF")
    (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST"))
    ;; (system cmdln)
    (pop-directory)))

(define (server:get-client-signature)
  (if *my-client-signature* *my-client-signature*
      (let ((sig (server:mk-signature)))
	(set! *my-client-signature* sig)
	*my-client-signature*)))

;; kind start up of servers, wait 40 seconds before allowing another server for a given
;; run-id to be launched
(define (server:kind-run run-id)
  (let ((last-run-time (hash-table-ref/default *server-kind-run* run-id #f)))
    (if (or (not last-run-time)

	    (> (- (current-seconds) last-run-time) 30))
	(begin
	  (server:run run-id)
	  (hash-table-set! *server-kind-run* run-id (current-seconds))))))

;; The generic run a server command. Dispatches the call to server 0 if run-id != 0
;; 
(define (server:try-running run-id)
  (if (eq? run-id 0)
      (server:run run-id)
      (rmt:start-server run-id)))

(define (server:check-if-running run-id)

  (let ((tdbdat (tasks:open-db)))
    (let loop ((server (tasks:get-server (db:delay-if-busy tdbdat) run-id))
	       (trycount 0))
    (if server
	;; note: client:start will set *runremote*. this needs to be changed
	;;       also, client:start will login to the server, also need to change that.
	;;
	;; client:start returns #t if login was successful.
	;;
	(let ((res (case *transport-type*
		     ((http)(server:ping-server run-id 
						(tasks:hostinfo-get-interface server)
						(tasks:hostinfo-get-port      server)))
		     ((nmsg)(nmsg-transport:ping (tasks:hostinfo-get-interface server)
						 (tasks:hostinfo-get-port      server)
						 timeout: 2)))))
	  ;; if the server didn't respond we must remove the record
	  (if res
	      #t
	      (begin
		(debug:print-info 0 "server at " server " not responding, removing record")
		(tasks:server-force-clean-running-records-for-run-id (db:delay-if-busy tdbdat) run-id 
				" server:check-if-running")
		res)))

	#f))))

;; called in megatest.scm, host-port is string hostname:port
;;
(define (server:ping run-id host:port)
  (let ((tdbdat (tasks:open-db)))
    (let* ((host-port (let ((slst (string-split   host:port ":")))
			(if (eq? (length slst) 2)
			    (list (car slst)(string->number (cadr slst)))
			    #f)))
	   (toppath       (launch:setup-for-run))
	   (server-db-dat (if (not host-port)(tasks:get-server (db:delay-if-busy tdbdat) run-id) #f)))
      (if (not run-id)
	  (begin
	    (debug:print 0 "ERROR: must specify run-id when doing ping, -run-id n")
	    (print "ERROR: No run-id")
	    (exit 1))
	  (if (and (not host-port)
		   (not server-db-dat))
	      (begin
		(print "ERROR: bad host:port")
		(exit 1))
	      (let* ((iface      (if host-port (car host-port) (tasks:hostinfo-get-interface server-db-dat)))
		     (port       (if host-port (cadr host-port)(tasks:hostinfo-get-port      server-db-dat)))
		     (server-dat (http-transport:client-connect iface port))
		     (login-res  (rmt:login-no-auto-client-setup server-dat run-id)))
		(if (and (list? login-res)
			 (car login-res))
		    (begin
		      (print "LOGIN_OK")
		      (exit 0))
		    (begin
		      (print "LOGIN_FAILED")
		      (exit 1)))))))))

;; run ping in separate process, safest way in some cases
;;
(define (server:ping-server run-id iface port)
  (with-input-from-pipe 
   (conc (common:get-megatest-exe) " -run-id " run-id " -ping " (conc iface ":" port))
   (lambda ()
     (let loop ((inl (read-line))
		(res "NOREPLY"))
       (if (eof-object? inl)
	   (case (string->symbol res)
	     ((NOREPLY)  #f)
	     ((LOGIN_OK) #t)
	     (else       #f))
	   (loop (read-line) inl))))))

(define (server:login toppath)
  (lambda (toppath)
    (set! *last-db-access* (current-seconds))
    (if (equal? *toppath* toppath)
	(begin
	  ;; (debug:print-info 2 "login successful")
	  #t)
	(begin
	  ;; (debug:print-info 2 "login failed")
	  #f))))

(define (server:get-timeout)
  (let ((tmo (configf:lookup  *configdat* "server" "timeout")))
    (if (and (string? tmo)
	     (string->number tmo))
	(* 60 60 (string->number tmo))
	;; (* 3 24 60 60) ;; default to three days
	(* 60 1)         ;; default to one minute
	;; (* 60 60 25)      ;; default to 25 hours
	)))

Modified synchash.scm from [68c033427e] to [67fbbc1d0f].

10
11
12
13
14
15
16
17

18
19
20
21
22
23
24
;;======================================================================

;;======================================================================
;; A hash of hashes that can be kept in sync by sending minial deltas
;;======================================================================

(use format)
(use srfi-1 srfi-69)


(declare (unit synchash))
(declare (uses db))
(declare (uses server))
(include "db_records.scm")

(define (synchash:make)







|
>







10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
;;======================================================================

;;======================================================================
;; A hash of hashes that can be kept in sync by sending minial deltas
;;======================================================================

(use format)
(use srfi-1 srfi-69 sqlite3)
(import (prefix sqlite3 sqlite3:))

(declare (unit synchash))
(declare (uses db))
(declare (uses server))
(include "db_records.scm")

(define (synchash:make)
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
    
;; (cdb:remote-run db:get-keys #f)  
;; (cdb:remote-run db:get-num-runs #f "%")
;; (cdb:remote-run db:get-runs #f runnamepatt numruns *start-run-offset* keypatts)
;;
;; keynum => the field to use as the unique key (usually 0 but can be other field)
;;
(define (synchash:client-get proc synckey keynum synchash . params)
  (let* ((data   (apply cdb:remote-run synchash:server-get #f proc synckey keynum params))
	 (newdat (car data))
	 (removs (cadr data))
	 (myhash (hash-table-ref/default synchash synckey #f)))
    (if (not myhash)
	(begin
	  (set! myhash (make-hash-table))
	  (hash-table-set! synchash synckey myhash)))







|
|







60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
    
;; (cdb:remote-run db:get-keys #f)  
;; (cdb:remote-run db:get-num-runs #f "%")
;; (cdb:remote-run db:get-runs #f runnamepatt numruns *start-run-offset* keypatts)
;;
;; keynum => the field to use as the unique key (usually 0 but can be other field)
;;
(define (synchash:client-get proc synckey keynum synchash run-id . params)
  (let* ((data   (rmt:synchash-get run-id proc synckey keynum params))
	 (newdat (car data))
	 (removs (cadr data))
	 (myhash (hash-table-ref/default synchash synckey #f)))
    (if (not myhash)
	(begin
	  (set! myhash (make-hash-table))
	  (hash-table-set! synchash synckey myhash)))
85
86
87
88
89
90
91
92
93


94
95
96
97
98
99
100
101
102
103
104
     removs)
    ;; WHICH ONE!?
    ;; data)) ;; return the changed and deleted list
    (list newdat removs))) ;; synchash))

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

(define (synchash:server-get db proc synckey keynum . params)
  ;; (debug:print-info 2 "synckey: " synckey ", keynum: " keynum ", params: " params)


  (let* ((synchash  (hash-table-ref/default *synchashes* synckey #f))
	 (newdat    (apply (case proc
			     ((db:get-runs)                   db:get-runs)
			     ((db:get-tests-for-runs-mindata) db:get-tests-for-runs-mindata)
			     ((db:get-test-info-by-ids)       db:get-test-info-by-ids)
			     (else
			      (print "ERROR: sync for hash " proc " not setup! Edits needed in synchash.scm")
			      print))
			   db params))
	 (postdat  #f)
	 (make-indexed (lambda (x)







|

>
>
|


|







86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
     removs)
    ;; WHICH ONE!?
    ;; data)) ;; return the changed and deleted list
    (list newdat removs))) ;; synchash))

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

(define (synchash:server-get dbstruct run-id proc synckey keynum params)
  ;; (debug:print-info 2 "synckey: " synckey ", keynum: " keynum ", params: " params)
  (let* ((dbdat     (db:get-db dbstruct run-id))
	 (db        (db:dbdat-get-db dbdat))
	 (synchash  (hash-table-ref/default *synchashes* synckey #f))
	 (newdat    (apply (case proc
			     ((db:get-runs)                   db:get-runs)
			     ((db:get-tests-for-run-mindata)  db:get-tests-for-run-mindata)
			     ((db:get-test-info-by-ids)       db:get-test-info-by-ids)
			     (else
			      (print "ERROR: sync for hash " proc " not setup! Edits needed in synchash.scm")
			      print))
			   db params))
	 (postdat  #f)
	 (make-indexed (lambda (x)
112
113
114
115
116
117
118

119
120
121
122
123
124
		       ;; (debug:print-info 2 "header: " header ", data: " data)
		       (cons (list "header" header)         ;; add the header keyed by the word "header"
			     (map make-indexed data))))        ;; add each element keyed by the keynum'th val
		    (else 
		     ;; (debug:print-info 2 "Non-get runs call")
		     (map make-indexed newdat))))
    ;; (debug:print-info 2 "postdat: " postdat)

    (if (not synchash)
	(begin
	  (set! synchash (make-hash-table))
	  (hash-table-set! *synchashes* synckey synchash)))
    (synchash:get-delta postdat synchash)))








>






115
116
117
118
119
120
121
122
123
124
125
126
127
128
		       ;; (debug:print-info 2 "header: " header ", data: " data)
		       (cons (list "header" header)         ;; add the header keyed by the word "header"
			     (map make-indexed data))))        ;; add each element keyed by the keynum'th val
		    (else 
		     ;; (debug:print-info 2 "Non-get runs call")
		     (map make-indexed newdat))))
    ;; (debug:print-info 2 "postdat: " postdat)
    ;; (if (not indb)(sqlite3:finalize! db))
    (if (not synchash)
	(begin
	  (set! synchash (make-hash-table))
	  (hash-table-set! *synchashes* synckey synchash)))
    (synchash:get-delta postdat synchash)))

Modified tasks.scm from [d7fb3bbbc7] to [590db5beef].

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

(include "task_records.scm")

;;======================================================================
;; Tasks db
;;======================================================================







































;; If file exists AND
;;    file readable
;;         ==> open it
;; If file exists AND
;;    file NOT readable
;;         ==> open in-mem version
;; If file NOT exists
;;    ==> open in-mem version
;;
(define (tasks:open-db)















  (let* ((dbpath       (conc *toppath* "/monitor.db"))


	 (exists       (file-exists? dbpath))
	 (write-access (file-write-access? dbpath))
	 (mdb          (cond

			((file-write-access? *toppath*)(sqlite3:open-database dbpath))
			((file-read-access? dbpath)    (sqlite3:open-database dbpath))
			(else (sqlite3:open-database ":memory:")))) ;; (never-give-up-open-db dbpath))
	 (handler      (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)
    (sqlite3:execute mdb (conc "PRAGMA synchronous = 0;"))
    (if (or (and (not exists)
		 (file-write-access? *toppath*))
	    (not (file-read-access? dbpath)))
	(begin



	  (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY,
                                action TEXT DEFAULT '',
                                owner TEXT,
                                state TEXT DEFAULT 'new',
                                target TEXT DEFAULT '',
                                name TEXT DEFAULT '',
                                test TEXT DEFAULT '',
                                item TEXT DEFAULT '',
                                keylock TEXT,
                                params TEXT,
                                creation_time TIMESTAMP,
                                execution_time TIMESTAMP);")
	  (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS monitors (id INTEGER PRIMARY KEY,
                                pid INTEGER,
                                start_time TIMESTAMP,
                                last_update TIMESTAMP,
                                hostname TEXT,
                                username TEXT,
                               CONSTRAINT monitors_constraint UNIQUE (pid,hostname));")
	  (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS servers (id INTEGER PRIMARY KEY,
                                  pid INTEGER,
                                  interface TEXT,
                                  hostname TEXT,
                                  port INTEGER,
                                  pubport INTEGER,
                                  start_time TIMESTAMP,
                                  priority INTEGER,
                                  state TEXT,
                                  mt_version TEXT,
                                  heartbeat TIMESTAMP,
                                  transport TEXT,

                               CONSTRAINT servers_constraint UNIQUE (pid,hostname,port));")
	  (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS clients (id INTEGER PRIMARY KEY,
                                  server_id INTEGER,
                                  pid INTEGER,
                                  hostname TEXT,
                                  cmdline TEXT,
                                  login_time TIMESTAMP,
                                  logout_time TIMESTAMP DEFAULT -1,
                                CONSTRAINT clients_constraint UNIQUE (pid,hostname));")
                                  
	  ))

    mdb))
    
;;======================================================================
;; Server and client management
;;======================================================================

;; make-vector-record tasks hostinfo id interface port pubport transport pid hostname
(define (tasks:hostinfo-get-id          vec)    (vector-ref  vec 0))
(define (tasks:hostinfo-get-interface   vec)    (vector-ref  vec 1))
(define (tasks:hostinfo-get-port        vec)    (vector-ref  vec 2))
(define (tasks:hostinfo-get-pubport     vec)    (vector-ref  vec 3))
(define (tasks:hostinfo-get-transport   vec)    (vector-ref  vec 4))
(define (tasks:hostinfo-get-pid         vec)    (vector-ref  vec 5))
(define (tasks:hostinfo-get-hostname    vec)    (vector-ref  vec 6))

;; state: 'live, 'shutting-down, 'dead
(define (tasks:server-register mdb pid interface port priority state transport #!key (pubport -1))







  (debug:print-info 11 "tasks:server-register " pid " " interface " " port " " priority " " state)


  (sqlite3:execute 
   mdb 
   "INSERT OR REPLACE INTO servers (pid,hostname,port,pubport,start_time,priority,state,mt_version,heartbeat,interface,transport)
                             VALUES(?,  ?,       ?,   ?,  strftime('%s','now'), ?, ?, ?, strftime('%s','now'),?,?);"

   pid (get-host-name) port pubport priority (conc state) 




   (common:version-signature)
   interface 
   (conc transport))
  (vector 
   (tasks:server-get-server-id mdb (get-host-name) interface port pid)
   interface
   port
   pubport
   transport

   ))










;; NB// two servers with same pid on different hosts will be removed from the list if pid: is used!
(define (tasks:server-deregister mdb hostname #!key (port #f)(pid #f)(action 'delete))







  (debug:print-info 11 "server-deregister " hostname ", port " port ", pid " pid)



  (if *db-write-access*


      (if pid
	  (case action



	    ((delete)(sqlite3:execute mdb "DELETE FROM servers WHERE pid=?;" pid))

	    (else    (sqlite3:execute mdb "UPDATE servers SET state='dead' WHERE pid=?;" pid)))

	  (if port







	      (case action


	    ((delete)(sqlite3:execute mdb "DELETE FROM servers WHERE (interface=? or hostname=?) AND port=?;" hostname hostname port))

	    (else    (sqlite3:execute mdb "UPDATE servers SET state='dead' WHERE (interface=? or hostname=?) AND port=?;" hostname hostname port)))
	      (debug:print 0 "ERROR: tasks:server-deregister called with neither pid nor port specified")))))




































(define (tasks:server-deregister-self mdb hostname)















  (tasks:server-deregister mdb hostname pid: (current-process-id)))


















;; need a simple call for robustly removing records given host and port
(define (tasks:server-delete mdb hostname port)


























  (tasks:server-deregister mdb hostname port: port action: 'delete))









(define (tasks:server-get-server-id mdb hostname iface port pid)
  (debug:print-info 12 "tasks:server-get-server-id " mdb " " hostname " " iface " " port " " pid)
  (let ((res #f))
    (sqlite3:for-each-row
     (lambda (id)
       (set! res id))
     mdb
     (cond
      ((and hostname  pid)  "SELECT id FROM servers WHERE hostname=?  AND pid=?;")
      ((and iface     port) "SELECT id FROM servers WHERE interface=? AND port=?;")
      ((and hostname  port) "SELECT id FROM servers WHERE hostname=?  AND port=?;")
      (else
       (begin
	 (debug:print 0 "ERROR: tasks:server-get-server-id needs (hostname and pid) OR (iface and port) OR (hostname and port)")
	 "SELECT id FROM servers WHERE pid=-999;")))
     (if hostname hostname iface)(if pid pid port))
    res))

(define (tasks:server-update-heartbeat mdb server-id)
  (debug:print-info 1 "Heart beat update of server id=" server-id)
  (handle-exceptions
   exn
   (begin
     (debug:print 0 "WARNING: probable timeout on monitor.db access")
     (thread-sleep! 1)
     (tasks:server-update-heartbeat mdb server-id))
   (sqlite3:execute mdb "UPDATE servers SET heartbeat=strftime('%s','now') WHERE id=?;" server-id)))

;; alive servers keep the heartbeat field upto date with seconds every 6 or so seconds
(define (tasks:server-alive? mdb server-id #!key (iface #f)(hostname #f)(port #f)(pid #f))
  (let* ((server-id  (if server-id 
			 server-id
			 (tasks:server-get-server-id mdb hostname iface port pid)))
	 (heartbeat-delta 99e9))
    (sqlite3:for-each-row
     (lambda (delta)
       (set! heartbeat-delta delta))
     mdb "SELECT strftime('%s','now')-heartbeat FROM servers WHERE id=?;" server-id)
    (< heartbeat-delta 10)))

(define (tasks:client-register mdb pid hostname cmdline)
  (sqlite3:execute
   mdb
   "INSERT OR REPLACE INTO clients (server_id,pid,hostname,cmdline,login_time) VALUES(?,?,?,?,strftime('%s','now'));")
  (tasks:server-get-server-id mdb hostname #f #f pid)
  pid hostname cmdline)

(define (tasks:client-logout mdb pid hostname cmdline)
  (sqlite3:execute
   mdb
   "UPDATE clients SET logout_time=strftime('%s','now') WHERE pid=? AND hostname=? AND cmdline=?;"
   pid hostname cmdline))

(define (tasks:get-logged-in-clients mdb server-id)
  (let ((res '()))
    (sqlite3:for-each-row 
     (lambda (id server-id pid hostname cmdline login-time logout-time)
       (set! res (cons (vector id server-id pid hostname cmdline login-time lougout-time) res)))
     mdb
     "SELECT id,server_id,pid,hostname,cmdline,login_time,logout_time FROM clients WHERE server_id=?;"
     server-id)))

(define (tasks:have-clients? mdb server-id)
  (null? (tasks:get-logged-in-clients mdb server-id)))

;; ping each server in the db and return first found that responds. 
;; remove any others. will not necessarily remove all!


(define (tasks:get-best-server mdb)


  (let ((res '())


	(best #f)
	(transport (if (and *transport-type*
			    (not (eq? *transport-type* 'fs)))
		       (conc *transport-type*)
		       "%")))
    (sqlite3:for-each-row
     (lambda (id interface port pubport transport pid hostname)
       (set! res (cons (vector id interface port pubport transport pid hostname) res))
       ;;(debug:print-info 2 "Found existing server " hostname ":" port " registered in db"))
       )
     mdb
     
     "SELECT id,interface,port,pubport,transport,pid,hostname FROM servers
          WHERE strftime('%s','now')-heartbeat < 10 
          AND mt_version=? AND transport LIKE ? 
          ORDER BY start_time DESC LIMIT 1;" (common:version-signature) transport)
    ;; for now we are keeping only one server registered in the db, return #f or first server found
    (if (null? res) #f (car res))))

;; BUG: This logic is probably needed unless methodology changes completely...
;;
;;     (if (null? res) #f
;; 	(let loop ((hed (car res))
;; 		   (tal (cdr res)))
;; 	  ;; (print "hed=" hed ", tal=" tal)
;; 	  (let* ((host     (list-ref hed 0))
;; 		 (iface    (list-ref hed 1))
;; 		 (port     (list-ref hed 2))
;; 		 (pid      (list-ref hed 4))
;; 		 (alive    (open-run-close tasks:server-alive? tasks:open-db #f hostname: host port: port)))
;; 	    (if alive
;; 		(begin
;; 		  (debug:print-info 2 "Found an existing, alive, server " host ", " port ".")
;; 		  (list host iface port))
;; 		(begin
;; 		  (debug:print-info 1 "Marking " host ":" port " as dead in server registry.")
;; 		  (if port
;; 		      (open-run-close tasks:server-deregister tasks:open-db host port: port)
;; 		      (open-run-close tasks:server-deregister tasks:open-db host pid:  pid))
;; 		  (if (null? tal)
;; 		      #f
;; 		      (loop (car tal)(cdr tal))))))))))

(define (tasks:remove-server-records mdb)
  (sqlite3:execute mdb "DELETE FROM servers;"))

(define (tasks:mark-server hostname port pid state transport)
  (if port
      (open-run-close tasks:server-deregister tasks:open-db hostname port: port)
      (open-run-close tasks:server-deregister tasks:open-db hostname pid:  pid)))


(define (tasks:kill-server status hostname port pid transport)
  (debug:print-info 1 "Removing defunct server record for " hostname ":" port)
  (if port
      (open-run-close tasks:server-deregister tasks:open-db hostname port: port)
      (open-run-close tasks:server-deregister tasks:open-db hostname pid:  pid))
  (if status ;; #t means alive

      (begin
	(if (equal? hostname (get-host-name))
	    (handle-exceptions
	     exn
	     (debug:print-info 0 "server may or may not be dead, check for megatest -server running as pid " pid "\n"
			       "  EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))

	     (debug:print 1 "Sending signal/term to " pid " on " hostname)
	     (process-signal pid signal/term)
	     (thread-sleep! 5) ;; give it five seconds to die peacefully then do a brutal kill
	     ;;(process-signal pid signal/kill)
	     ) ;; local machine, send sig term
	    (begin
	      ;;(debug:print-info 1 "Stopping remote servers not yet supported."))))
	      (debug:print-info 1 "Telling alive server on " hostname ":" port " to commit servercide")
	      (let ((serverdat (list hostname port)))
	      	(case (if (string? transport) (string->symbol transport) transport)
	      	  ((http)(http-transport:client-connect hostname port))
	      	  (else  (debug:print "ERROR: remote stopping servers of type " transport " not supported yet")))
	      	(cdb:kill-server serverdat pid)))))    ;; remote machine, try telling server to commit suicide
      (begin
	(if status 
	    (if (equal? hostname (get-host-name))
		(begin
		  (debug:print-info 1 "Sending signal/term to " pid " on " hostname)
		  (process-signal pid signal/term)  ;; local machine, send sig term
		  (thread-sleep! 5)                 ;; give it five seconds to die peacefully then do a brutal kill
		  (process-signal pid signal/kill)) 
		(debug:print 0 "WARNING: Can't kill frozen server on remote host " hostname))))))



(define (tasks:get-all-servers mdb)
  (let ((res '()))
    (sqlite3:for-each-row
     (lambda (id pid hostname interface port pubport start-time priority state mt-version last-update transport)

       (set! res (cons (vector id pid hostname interface port pubport start-time priority state mt-version last-update transport) res)))
     mdb
     "SELECT id,pid,hostname,interface,port,pubport,start_time,priority,state,mt_version,strftime('%s','now')-heartbeat AS last_update,transport FROM servers ORDER BY start_time DESC;")

    res))
       

;;======================================================================
;; Tasks and Task monitors
;;======================================================================


;;======================================================================
;; Tasks
;;======================================================================



;;======================================================================
;; Task Monitors
;;======================================================================

(define (tasks:register-monitor db mdb)
  (let* ((pid (current-process-id))
	 (hostname (get-host-name))
	 (userinfo (user-information (current-user-id)))
	 (username (car userinfo)))
    (print "Register monitor, pid: " pid ", hostname: " hostname ", username: " username)
    (sqlite3:execute mdb "INSERT INTO monitors (pid,start_time,last_update,hostname,username) VALUES (?,strftime('%s','now'),strftime('%s','now'),?,?);"
		     pid hostname username)))

(define (tasks:get-num-alive-monitors mdb)
  (let ((res 0))
    (sqlite3:for-each-row 
     (lambda (count)

       (set! res count))
     mdb
     "SELECT count(id) FROM monitors WHERE last_update < (strftime('%s','now') - 300) AND username=?;"

     (car (user-information (current-user-id))))
    res))

;; register a task
(define (tasks:add mdb action owner target runname test item params)
  (sqlite3:execute mdb "INSERT INTO tasks_queue (action,owner,state,target,name,test,item,params,creation_time,execution_time)
                       VALUES (?,?,'new',?,?,?,?,?,strftime('%s','now'),0);" 
		   action
		   owner
		   target
		   runname
		   test
		   item
		   (if params params "")))

(define (keys:key-vals-hash->target keys key-params)
  (let ((tmp (hash-table-ref/default key-params (vector-ref (car keys) 0) "")))
    (if (> (length keys) 1)
	(for-each (lambda (key)
		    (set! tmp (conc tmp "/" (hash-table-ref/default key-params (vector-ref key 0) ""))))
		  (cdr keys)))
    tmp))
								
;; for use from the gui
(define (tasks:add-from-params mdb action keys key-params var-params)
  (let ((target    (keys:key-vals-hash->target keys key-params))
	(owner     (car (user-information (current-user-id))))
	(runname   (hash-table-ref/default var-params "runname" #f))
	(testpatts (hash-table-ref/default var-params "testpatts" "%"))
	(params    (hash-table-ref/default var-params "params"    "")))
    (tasks:add mdb action owner target runname testpatts params)))

;; return one task from those who are 'new' OR 'waiting' AND more than 10sec old
;;
(define (tasks:snag-a-task mdb)
  (let ((res    #f)
	(keytxt (conc (current-process-id) "-" (get-host-name) "-" (car (user-information (current-user-id))))))

    ;; first randomly set a new to pid-hostname-hostname



    (sqlite3:execute
     mdb 
     "UPDATE tasks_queue SET keylock=? WHERE id IN
        (SELECT id FROM tasks_queue 
           WHERE state='new' OR 
                 (state='waiting' AND (strftime('%s','now')-execution_time) > 10) OR
                 state='reset'
           ORDER BY RANDOM() LIMIT 1);" keytxt)

    (sqlite3:for-each-row
     (lambda (id . rem)
       (set! res (apply vector id rem)))
     mdb
     "SELECT id,action,owner,state,target,name,test,item,params,creation_time,execution_time FROM tasks_queue WHERE keylock=? ORDER BY execution_time ASC LIMIT 1;" keytxt)
    (if res ;; yep, have work to be done
	(begin
	  (sqlite3:execute mdb "UPDATE tasks_queue SET state='inprogress',execution_time=strftime('%s','now') WHERE id=?;"
			   (tasks:task-get-id res))
	  res)
	#f)))

(define (tasks:reset-stuck-tasks mdb)
  (let ((res '()))
    (sqlite3:for-each-row
     (lambda (id delta)
       (set! res (cons id res)))
     mdb
     "SELECT id,strftime('%s','now')-execution_time AS delta FROM tasks_queue WHERE state='inprogress' AND delta>700 ORDER BY delta DESC LIMIT 2;")
    (sqlite3:execute 
     mdb 
     (conc "UPDATE tasks_queue SET state='reset' WHERE id IN ('" (string-intersperse (map conc res) "','") "');"))))

;; return all tasks in the tasks_queue table
;;
(define (tasks:get-tasks mdb types states)



  (let ((res '()))
    (sqlite3:for-each-row
     (lambda (id . rem)
       (set! res (cons (apply vector id rem) res)))
     mdb
     (conc "SELECT id,action,owner,state,target,name,test,item,params,creation_time,execution_time 


               FROM tasks_queue "


               ;; WHERE  
               ;;   state IN " statesstr " AND 
	       ;;   action IN " actionsstr 
	   " ORDER BY creation_time DESC;"))
    res))

;; remove tasks given by a string of numbers comma separated
(define (tasks:remove-queue-entries mdb task-ids)
  (sqlite3:execute mdb (conc "DELETE FROM tasks_queue WHERE id IN (" task-ids ");")))

;; 
(define (tasks:start-monitor db mdb)
  (if (> (tasks:get-num-alive-monitors mdb) 2) ;; have two running, no need for more
      (debug:print-info 1 "Not starting monitor, already have more than two running")
      (let* ((megatestdb     (conc *toppath* "/megatest.db"))
	     (monitordbf     (conc *toppath* "/monitor.db"))
	     (last-db-update 0)) ;; (file-modification-time megatestdb)))
	(task:register-monitor mdb)
	(let loop ((count      0)
		   (next-touch 0)) ;; next-touch is the time where we need to update last_update
	  ;; if the db has been modified we'd best look at the task queue
	  (let ((modtime (file-modification-time megatestdbpath )))
	    (if (> modtime last-db-update)
		(tasks:process-queue db mdb last-db-update megatestdb next-touch))
	    ;; WARNING: Possible race conditon here!!
	    ;; should this update be immediately after the task-get-action call above?
	    (if (> (current-seconds) next-touch)
		(begin
		  (tasks:monitors-update mdb)
		  (loop (+ count 1)(+ (current-seconds) 240)))
		(loop (+ count 1) next-touch)))))))
      
(define (tasks:process-queue db mdb)
  (let* ((task   (tasks:snag-a-task mdb))
	 (action (if task (tasks:task-get-action task) #f)))
    (if action (print "tasks:process-queue task: " task))
    (if action
	(case (string->symbol action)
	  ((run)       (tasks:start-run   db mdb task))
	  ((remove)    (tasks:remove-runs db mdb task))
	  ((lock)      (tasks:lock-runs   db mdb task))
	  ;; ((monitor)   (tasks:start-monitor db task))
	  ((rollup)    (tasks:rollup-runs db mdb task))
	  ((updatemeta)(tasks:update-meta db mdb task))
	  ((kill)      (tasks:kill-monitors db mdb task))))))

(define (tasks:get-monitors mdb)
  (let ((res '()))
    (sqlite3:for-each-row
     (lambda (a . rem)
       (set! res (cons (apply vector a rem) res)))
     mdb
     "SELECT id,pid,strftime('%m/%d/%Y %H:%M',datetime(start_time,'unixepoch'),'localtime'),strftime('%m/%d/%Y %H:%M:%S',datetime(last_update,'unixepoch'),'localtime'),hostname,username FROM monitors ORDER BY last_update ASC;")
    (reverse res)
    ))

(define (tasks:tasks->text tasks)
  (let ((fmtstr "~10a~10a~10a~12a~20a~12a~12a~10a"))
    (conc (format #f fmtstr "id" "action" "owner" "state" "target" "runname" "testpatts" "params") "\n"
	  (string-intersperse 
	   (map (lambda (task)
		  (format #f fmtstr
			  (tasks:task-get-id     task)
			  (tasks:task-get-action task)
			  (tasks:task-get-owner  task)
			  (tasks:task-get-state  task)
			  (tasks:task-get-target task)
			  (tasks:task-get-name   task)
			  (tasks:task-get-test   task)
			  ;; (tasks:task-get-item   task)
			  (tasks:task-get-params task)))
		tasks) "\n"))))
   
(define (tasks:monitors->text-table monitors)
  (let ((fmtstr "~4a~8a~20a~20a~10a~10a"))
    (conc (format #f fmtstr "id" "pid" "start time" "last update" "hostname" "user") "\n"
	  (string-intersperse 
	   (map (lambda (monitor)
		  (format #f fmtstr
			  (tasks:monitor-get-id          monitor)







>







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










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






|











>
|
|







|
|
>
|
|













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


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


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

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

|
<




|
<
<
<
<
<
<
<
|
<


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

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

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




|
>
|

|
>

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

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

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

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

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

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











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







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

(include "task_records.scm")

;;======================================================================
;; Tasks db
;;======================================================================

;; wait up to aprox n seconds for a journal to go away
;;
(define (tasks:wait-on-journal path n #!key (remove #f)(waiting-msg #f))
  (if (not (string? path))
      (debug:print 0 "ERROR: Called tasks:wait-on-journal with path=" path " (not a string)")
      (let ((fullpath (conc path "-journal")))
	(handle-exceptions
	 exn
	 (begin
	   (print-call-chain (current-error-port))
	   (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
	   (debug:print 0 " exn=" (condition->list exn))
	   (debug:print 0 "tasks:wait-on-journal failed. Continuing on, you can ignore this call-chain")
	   #t) ;; if stuff goes wrong just allow it to move on
	 (let loop ((journal-exists (file-exists? fullpath))
		    (count          n)) ;; wait ten times ...
	   (if journal-exists
	       (begin
		 (if (and waiting-msg
			  (eq? (modulo n 30) 0))
		     (debug:print 0 waiting-msg))
		 (if (> count 0)
		     (begin
		       (thread-sleep! 1)
		       (loop (file-exists? fullpath)
			     (- count 1)))
		     (begin
		       (if remove (system (conc "rm -rf " fullpath)))
		       #f)))
	       #t))))))

(define (tasks:get-task-db-path)
  (let* ((linktree     (configf:lookup *configdat* "setup" "linktree"))
	 (dbpath       (conc linktree "/.db")))
    dbpath))



;; If file exists AND
;;    file readable
;;         ==> open it
;; If file exists AND
;;    file NOT readable
;;         ==> open in-mem version
;; If file NOT exists
;;    ==> open in-mem version
;;
(define (tasks:open-db #!key (numretries 4))
  (if *task-db*
      *task-db*
      (handle-exceptions
       exn
       (if (> numretries 0)
	   (begin
	     (print-call-chain (current-error-port))
	     (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
	     (debug:print 0 " exn=" (condition->list exn))
	     (thread-sleep! 1)
	     (tasks:open-db numretries (- numretries 1)))
	   (begin
	     (print-call-chain (current-error-port))
	     (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
	     (debug:print 0 " exn=" (condition->list exn))))
       (let* ((dbpath       (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       (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      (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,
         ;;                        state TEXT DEFAULT 'new',
         ;;                        target TEXT DEFAULT '',
         ;;                        name TEXT DEFAULT '',
         ;;                        testpatt TEXT DEFAULT '',

         ;;                        keylock TEXT,
         ;;                        params TEXT,
         ;;                        creation_time TIMESTAMP,
         ;;                        execution_time TIMESTAMP);")
	 (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS monitors (id INTEGER PRIMARY KEY,
                                pid INTEGER,
                                start_time TIMESTAMP,
                                last_update TIMESTAMP,
                                hostname TEXT,
                                username TEXT,
                               CONSTRAINT monitors_constraint UNIQUE (pid,hostname));")
	 (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS servers (id INTEGER PRIMARY KEY,
                                  pid INTEGER,
                                  interface TEXT,
                                  hostname TEXT,
                                  port INTEGER,
                                  pubport INTEGER,
                                  start_time TIMESTAMP,
                                  priority INTEGER,
                                  state TEXT,
                                  mt_version TEXT,
                                  heartbeat TIMESTAMP,
                                  transport TEXT,
                                  run_id INTEGER);")
	 ;;                               CONSTRAINT servers_constraint UNIQUE (pid,hostname,port));")
	 (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS clients (id INTEGER PRIMARY KEY,
                                  server_id INTEGER,
                                  pid INTEGER,
                                  hostname TEXT,
                                  cmdline TEXT,
                                  login_time TIMESTAMP,
                                  logout_time TIMESTAMP DEFAULT -1,
                                CONSTRAINT clients_constraint UNIQUE (pid,hostname));")
	       
	       ;))
	 (set! *task-db* (cons mdb dbpath))
	 *task-db*))))

;;======================================================================
;; Server and client management
;;======================================================================

;; make-vector-record tasks hostinfo id interface port pubport transport pid hostname
(define (tasks:hostinfo-get-id          vec)    (vector-ref  vec 0))
(define (tasks:hostinfo-get-interface   vec)    (vector-ref  vec 1))
(define (tasks:hostinfo-get-port        vec)    (vector-ref  vec 2))
(define (tasks:hostinfo-get-pubport     vec)    (vector-ref  vec 3))
(define (tasks:hostinfo-get-transport   vec)    (vector-ref  vec 4))
(define (tasks:hostinfo-get-pid         vec)    (vector-ref  vec 5))
(define (tasks:hostinfo-get-hostname    vec)    (vector-ref  vec 6))


(define (tasks:server-lock-slot mdb run-id)
  (tasks:server-clean-out-old-records-for-run-id mdb run-id " tasks:server-lock-slot")
  (if (< (tasks:num-in-available-state mdb run-id) 4)
      (begin 
	(tasks:server-set-available mdb run-id)
	(thread-sleep! (/ (random 1500) 1000)) ;; (thread-sleep! 2) ;; Try removing this. It may not be needed.
	(tasks:server-am-i-the-server? mdb run-id))
      #f))
	
;; register that this server may come online (first to register goes though with the process)
(define (tasks:server-set-available mdb run-id)
  (sqlite3:execute 
   mdb 
   "INSERT INTO servers (pid,hostname,port,pubport,start_time,      priority,state,mt_version,heartbeat,   interface,transport,run_id)
                   VALUES(?, ?,       ?,   ?, strftime('%s','now'), ?,       ?,    ?,-1,?,        ?,        ?);"
   (current-process-id)          ;; pid
   (get-host-name)               ;; hostname
   -1                            ;; port
   -1                            ;; pubport
   (random 1000)                 ;; priority (used a tiebreaker on get-available)
   "available"                   ;; state
   (common:version-signature)    ;; mt_version
   -1                            ;; interface
   ;; (conc (server:get-transport)) ;; transport





   (conc *transport-type*)    ;; transport
   run-id
   ))

(define (tasks:num-in-available-state mdb run-id)
  (let ((res 0))
    (sqlite3:for-each-row
     (lambda (num-in-queue)
       (set! res num-in-queue))
     mdb
     "SELECT count(id) FROM servers WHERE run_id=? AND state = 'available' AND (strftime('%s','now') - start_time) < 30 ;"
     run-id)
    res))

(define (tasks:num-servers-non-zero-running mdb)
  (let ((res 0))
    (sqlite3:for-each-row
     (lambda (num-running)
       (set! res num-running))
     mdb
     "SELECT count(id) FROM servers WHERE run_id != 0 AND state = 'running';")
    res))

(define (tasks:server-clean-out-old-records-for-run-id mdb run-id tag)
  (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE state in ('available','dbprep','shutting-down') AND (strftime('%s','now') - start_time) > 50 AND run_id=?;"
		   (conc "defunct" tag) run-id))

(define (tasks:server-force-clean-running-records-for-run-id mdb run-id tag)
  (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE state = 'running' AND run_id=?;"
		   (conc "defunct" tag) run-id))

(define (tasks:server-force-clean-run-record mdb run-id iface port tag)
  (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE state = 'running' AND run_id=? AND interface=? AND port=?;"
		   (conc "defunct" tag) run-id iface port))

(define (tasks:server-delete-records-for-this-pid mdb tag)
  (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE hostname=? AND pid=?;"
		   (conc "defunct" tag) (get-host-name) (current-process-id)))

(define (tasks:server-delete-record mdb server-id tag) 
  (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE id=?;"
		   (conc "defunct" tag) server-id)
  ;; use this opportuntity to clean out records over one month old or over 10 minutes old with port = -1 (i.e. a never used placeholder)
  (sqlite3:execute mdb "DELETE FROM servers WHERE state not in ('running','shutting-down','dbprep') AND (strftime('%s','now') - start_time) > 2628000;")
  (sqlite3:execute mdb "DELETE FROM servers WHERE state like 'defunct%' AND port=-1 AND (strftime('%s','now') - start_time) > 600;")
  )

(define (tasks:server-set-state! mdb server-id state)
  (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE id=?;" state server-id))

(define (tasks:server-set-interface-port mdb server-id interface port)
  (sqlite3:execute mdb "UPDATE servers SET interface=?,port=?,heartbeat=strftime('%s','now') WHERE id=?;" interface port server-id))

;; Get random port not used in long time
;;
(define (tasks:server-get-next-port mdb)
  (let* ((lownum        30000)
	(highnum        64000)
	(used-ports     '())
	(get-rand-port  (lambda ()
			  (+ lownum (random (- highnum lownum)))))
	(port-param     (if (and (args:get-arg "-port")
				 (string->number (args:get-arg "-port")))
			    (string->number (args:get-arg "-port"))
			    #f))
	;; (config-port    (if (and (config-lookup  *configdat* "server" "port")
	;; 			 (string->number (config-lookup  *configdat* "server" "port")))
	;; 		    (string->number (config-lookup  *configdat* "server" "port"))
	;; 		    #f))
	)
    (sqlite3:for-each-row
     (lambda (port)
       (set! used-ports (cons port used-ports)))
     mdb
     "SELECT port FROM servers;")
    (cond
     ((and port-param res)   (if (> res port-param) res port-param))
     (port-param             port-param)
     ;; ((and config-port res)  (if (> res config-port) res config-port))
     ;; (config-port            config-port)
     (else
      (let loop ((port     (get-rand-port))
		 (remtries 100))
	(if (member port used-ports)
	    (if (> remtries 0)
		(loop (get-rand-port)(- remtries 1))
		(get-rand-port))
	    port))))))

(define (tasks:server-am-i-the-server? mdb run-id)
  (let* ((all    (tasks:server-get-servers-vying-for-run-id mdb run-id))
	 (first  (if (null? all)
		     #f;; (begin (debug:print 0 "ERROR: no servers listed, should be at least one by now.") 
		       ;;      (sqlite3:finalize! mdb)
		       ;;      (exit 1))
		     (car (db:get-rows all)))))
    (if first
	(let* ((header   (db:get-header all))
	       (id       (db:get-value-by-header first header "id"))
	       (hostname (db:get-value-by-header first header "hostname"))
	       (pid      (db:get-value-by-header first header "pid"))
	       (priority (db:get-value-by-header first header "priority")))
	  ;; (debug:print 0 "INFO: am-i-the-server got record " first)
	  ;; for now a basic check. add tiebreaking by priority later
	  (if (and (equal? hostname (get-host-name))
		   (equal? pid      (current-process-id)))
	      id
	      #f))
	#f)))
	     
;; Use: (db:get-value-by-header (car (db:get-rows dat)) (db:get-header dat) "fieldname")
;;  to extract info from the structure returned
;;
(define (tasks:server-get-servers-vying-for-run-id mdb run-id)
   (let* ((header (list "id" "hostname" "pid" "interface" "port" "pubport" "state" "run_id" "priority" "start_time"))
	  (selstr (string-intersperse header ","))
	  (res    '()))
    (sqlite3:for-each-row
     (lambda (a . b)
       (set! res (cons (apply vector a b) res)))
     mdb
     (conc "SELECT " selstr " FROM servers WHERE run_id=? AND state in ('available','running','dbprep') ORDER BY start_time DESC;")
     run-id)
    (vector header res)))

(define (tasks:get-server mdb run-id #!key (retries 10))
  (let ((res  #f)
	(best #f))
    (handle-exceptions
     exn
     (begin
       (print-call-chain (current-error-port))
       (debug:print 0 "WARNING: tasks:get-server db access error.")
       (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
       (debug:print 0 " for run " run-id)
       (print-call-chain (current-error-port))
       (if (> retries 0)
	   (begin
	     (debug:print 0 " trying call to tasks:get-server again in 10 seconds")
	     (thread-sleep! 10)
	     (tasks:get-server mdb run-id retries: (- retries 0)))
	   (debug:print 0 "10 tries of tasks:get-server all crashed and burned. Giving up and returning \"no server found\"")))
     (sqlite3:for-each-row
      (lambda (id interface port pubport transport pid hostname)
	(set! res (vector id interface port pubport transport pid hostname)))
      mdb
      ;; removed:
      ;; strftime('%s','now')-heartbeat < 10 AND mt_version = ?
      "SELECT id,interface,port,pubport,transport,pid,hostname FROM servers
          WHERE run_id=? AND state='running'
          ORDER BY start_time DESC LIMIT 1;" run-id) ;; (common:version-signature) run-id)
     res)))

(define (tasks:server-running-or-starting? mdb run-id)
  (let ((res #f))
    (sqlite3:for-each-row
     (lambda (id)
       (set! res id))
     mdb ;; NEEDS dbprep ADDED
     "SELECT id FROM servers WHERE run_id=? AND (state = 'running' OR (state = 'dbprep' AND  (strftime('%s','now') - start_time) < 60));" run-id)
    res))

(define (tasks:server-running? mdb run-id)

  (let ((res #f))
    (sqlite3:for-each-row
     (lambda (id)
       (set! res id))
     mdb ;; NEEDS dbprep ADDED







     "SELECT id FROM servers WHERE run_id=? AND state = 'running';" run-id)

    res))

(define (tasks:need-server run-id)








  (configf:lookup *configdat* "server" "required"))



































;; 	(maxqry (cdr (rmt:get-max-query-average run-id)))
;; 	(threshold   (string->number (or (configf:lookup *configdat* "server" "server-query-threshold") "10"))))


;;     (cond
;;      (forced 
;;       (if (common:low-noise-print 60 run-id "server required is set")
;; 	  (debug:print-info 0 "Server required is set, starting server for run-id " run-id "."))
;;       #t)
;;      ((> maxqry threshold)
;;       (if (common:low-noise-print 60 run-id "Max query time execeeded")
;; 	  (debug:print-info 0 "Max avg query time of " maxqry "ms exceeds limit of " threshold "ms, server needed for run-id " run-id "."))
;;       #t)

;;      (else

;;       #f))))






;; try to start a server and wait for it to be available








;;





















(define (tasks:start-and-wait-for-server tdbdat run-id delay-max-tries)


  ;; ensure a server is running for this run




  (let loop ((server-dat (tasks:get-server (db:delay-if-busy tdbdat) run-id))
	     (delay-time 0))


      (if (and (not server-dat)



	       (< delay-time delay-max-tries))
	  (begin





	    (if (common:low-noise-print 60 "tasks:start-and-wait-for-server" run-id)
		(debug:print 0 "Try starting server for run-id " run-id))

	    (thread-sleep! (/ (random 2000) 1000))





	    (server:kind-run run-id)













	    (thread-sleep! (min delay-time 1))
	    (loop (tasks:get-server (db:delay-if-busy tdbdat) run-id)(+ delay-time 1))))))

(define (tasks:get-all-servers mdb)
  (let ((res '()))
    (sqlite3:for-each-row
     (lambda (id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id)
       ;;                       0  1     2         3      4     5          6        7     8          9          10        11     12
       (set! res (cons (vector id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id) res)))
     mdb
     "SELECT id,pid,hostname,interface,port,pubport,start_time,priority,state,mt_version,strftime('%s','now')-heartbeat AS last_update,transport,run_id 
        FROM servers WHERE state NOT LIKE 'defunct%' ORDER BY start_time DESC;")
    res))


























(define (tasks:get-server-records mdb run-id)
  (let ((res '()))
    (sqlite3:for-each-row
     (lambda (id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id)
       ;;                       0  1     2         3      4     5          6        7     8          9          10        11     12
       (set! res (cons (vector id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id) res)))
     mdb
     "SELECT id,pid,hostname,interface,port,pubport,start_time,priority,state,mt_version,strftime('%s','now')-heartbeat AS last_update,transport,run_id 
        FROM servers WHERE run_id=? AND state NOT LIKE 'defunct%' ORDER BY start_time DESC;"
     run-id)

    (reverse res)))



















;; no elegance here ...










;;
(define (tasks:kill-server hostname pid)


  (debug:print-info 0 "Attempting to kill server process " pid " on host " hostname)
  (setenv "TARGETHOST" hostname)
  (setenv "TARGETHOST_LOGF" "server-kills.log")
  (system (conc "nbfake kill " pid))
  (unsetenv "TARGETHOST_LOGF")
  (unsetenv "TARGETHOST"))







 











;; look up a server by run-id and send it a kill, also delete the record for that server












;;
(define (tasks:kill-server-run-id run-id #!key (tag "default"))
  (let* ((tdbdat  (tasks:open-db))
	 (sdat    (tasks:get-server (db:delay-if-busy tdbdat) run-id)))
    (if sdat
	(let ((hostname (vector-ref sdat 6))
	      (pid      (vector-ref sdat 5))
	      (server-id (vector-ref sdat 0)))



	  (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "killed")
	  (debug:print-info 0 "Killing server " server-id " for run-id " run-id " on host " hostname " with pid " pid)
	  (tasks:kill-server hostname pid)
	  (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id tag) )
	(debug:print-info 0 "No server found for run-id " run-id ", nothing to kill"))
    ;; (sqlite3:finalize! tdb)



    ))
    
;;======================================================================
;; M O N I T O R S
;;======================================================================


(define (tasks:remove-monitor-record mdb)



  (sqlite3:execute mdb "DELETE FROM monitors WHERE pid=? AND hostname=?;"










		   (current-process-id)




		   (get-host-name)))














(define (tasks:get-monitors mdb)
  (let ((res '()))
    (sqlite3:for-each-row
     (lambda (a . rem)
       (set! res (cons (apply vector a rem) res)))
     mdb
     "SELECT id,pid,strftime('%m/%d/%Y %H:%M',datetime(start_time,'unixepoch'),'localtime'),strftime('%m/%d/%Y %H:%M:%S',datetime(last_update,'unixepoch'),'localtime'),hostname,username FROM monitors ORDER BY last_update ASC;")
    (reverse res)
    ))


















(define (tasks:monitors->text-table monitors)
  (let ((fmtstr "~4a~8a~20a~20a~10a~10a"))
    (conc (format #f fmtstr "id" "pid" "start time" "last update" "hostname" "user") "\n"
	  (string-intersperse 
	   (map (lambda (monitor)
		  (format #f fmtstr
			  (tasks:monitor-get-id          monitor)
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

     (lambda (id pid host last-update delta)
       (print "Going to delete stale record for monitor with pid " pid " on host " host " last updated " delta " seconds ago")
       (set! deadlist (cons id deadlist)))
     mdb 
     "SELECT id,pid,hostname,last_update,strftime('%s','now')-last_update AS delta FROM monitors WHERE delta > 700;")
    (sqlite3:execute mdb (conc "DELETE FROM monitors WHERE id IN ('" (string-intersperse (map conc deadlist) "','") "');")))
  )

(define (tasks:remove-monitor-record mdb)
  (sqlite3:execute mdb "DELETE FROM monitors WHERE pid=? AND hostname=?;"
		   (current-process-id)
		   (get-host-name)))






(define (tasks:set-state mdb task-id state)

  (sqlite3:execute mdb "UPDATE tasks_queue SET state=? WHERE id=?;" 






		   state 







		   task-id))














;;======================================================================
;; The routines to process tasks



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

;; NOTE: It might be good to add one more layer of checking to ensure
;;       that no task gets run in parallel.

(define (tasks:start-run db mdb task)
  (let ((flags (make-hash-table)))













    (hash-table-set! flags "-rerun" "NOT_STARTED")







    (if (not (string=? (tasks:task-get-params task) ""))




































	(hash-table-set! flags "-setvars" (tasks:task-get-params task)))


    (print "Starting run " task)














    ;; sillyness, just call the damn routine with the task vector and be done with it. FIXME SOMEDAY


















    (runs:run-tests db































		    (tasks:task-get-target task)
		    (tasks:task-get-name   task)
		    (tasks:task-get-test   task)
		    (tasks:task-get-item   task)
		    (tasks:task-get-owner  task)

		    flags)







    (tasks:set-state mdb (tasks:task-get-id task) "waiting")))










































































































(define (tasks:rollup-runs db mdb task)
  (let* ((flags (make-hash-table)) 
	 (keys  (db:get-keys db))
	 (keyvals (keys:target-keyval keys (tasks:task-get-target task))))
    ;; (hash-table-set! flags "-rerun" "NOT_STARTED")
    (print "Starting rollup " task)
    ;; sillyness, just call the damn routine with the task vector and be done with it. FIXME SOMEDAY
    (runs:rollup-run db
		     keys 
		     keyvals
		     (tasks:task-get-name  task)
		     (tasks:task-get-owner  task))
    (tasks:set-state mdb (tasks:task-get-id task) "waiting")))








<
|
<
|
|
>
>
>
>
>

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

|
>
>
>





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

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
>
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
     (lambda (id pid host last-update delta)
       (print "Going to delete stale record for monitor with pid " pid " on host " host " last updated " delta " seconds ago")
       (set! deadlist (cons id deadlist)))
     mdb 
     "SELECT id,pid,hostname,last_update,strftime('%s','now')-last_update AS delta FROM monitors WHERE delta > 700;")
    (sqlite3:execute mdb (conc "DELETE FROM monitors WHERE id IN ('" (string-intersperse (map conc deadlist) "','") "');")))
  )

(define (tasks:register-monitor db mdb)

  (let* ((pid (current-process-id))
	 (hostname (get-host-name))
	 (userinfo (user-information (current-user-id)))
	 (username (car userinfo)))
    (print "Register monitor, pid: " pid ", hostname: " hostname ", username: " username)
    (sqlite3:execute mdb "INSERT INTO monitors (pid,start_time,last_update,hostname,username) VALUES (?,strftime('%s','now'),strftime('%s','now'),?,?);"
		     pid hostname username)))

(define (tasks:get-num-alive-monitors mdb)
  (let ((res 0))
    (sqlite3:for-each-row 
     (lambda (count)
       (set! res count))
     mdb
     "SELECT count(id) FROM monitors WHERE last_update < (strftime('%s','now') - 300) AND username=?;"
     (car (user-information (current-user-id))))
    res))

;; 
(define (tasks:start-monitor db mdb)
  (if (> (tasks:get-num-alive-monitors mdb) 2) ;; have two running, no need for more
      (debug:print-info 1 "Not starting monitor, already have more than two running")
      (let* ((megatestdb     (conc *toppath* "/megatest.db"))
	     (monitordbf     (conc (db:dbfile-path #f) "/monitor.db"))
	     (last-db-update 0)) ;; (file-modification-time megatestdb)))
	(task:register-monitor mdb)
	(let loop ((count      0)
		   (next-touch 0)) ;; next-touch is the time where we need to update last_update
	  ;; if the db has been modified we'd best look at the task queue
	  (let ((modtime (file-modification-time megatestdbpath )))
	    (if (> modtime last-db-update)
		(tasks:process-queue db mdb last-db-update megatestdb next-touch))
	    ;; WARNING: Possible race conditon here!!
	    ;; should this update be immediately after the task-get-action call above?
	    (if (> (current-seconds) next-touch)
		(begin
		  (tasks:monitors-update mdb)
		  (loop (+ count 1)(+ (current-seconds) 240)))
		(loop (+ count 1) next-touch)))))))
      
;;======================================================================
;; T A S K S   Q U E U E
;;
;;   NOTE:: These operate on task_queue which is in main.db
;;
;;======================================================================

;; NOTE: It might be good to add one more layer of checking to ensure
;;       that no task gets run in parallel.



;; register a task
(define (tasks:add dbstruct action owner target runname testpatt params)
  (db:with-db 
   dbstruct #f #t
   (lambda (db)
     (sqlite3:execute db "INSERT INTO tasks_queue (action,owner,state,target,name,testpatt,params,creation_time,execution_time)
                             VALUES (?,?,'new',?,?,?,?,strftime('%s','now'),0);" 
		      action
		      owner
		      target
		      runname
		      testpatt
		      (if params params "")))))

(define (keys:key-vals-hash->target keys key-params)
  (let ((tmp (hash-table-ref/default key-params (vector-ref (car keys) 0) "")))
    (if (> (length keys) 1)
	(for-each (lambda (key)
		    (set! tmp (conc tmp "/" (hash-table-ref/default key-params (vector-ref key 0) ""))))
		  (cdr keys)))
    tmp))
								
;; for use from the gui, not ported
;;
;; (define (tasks:add-from-params mdb action keys key-params var-params)
;;   (let ((target    (keys:key-vals-hash->target keys key-params))
;; 	(owner     (car (user-information (current-user-id))))
;; 	(runname   (hash-table-ref/default var-params "runname" #f))
;; 	(testpatts (hash-table-ref/default var-params "testpatts" "%"))
;; 	(params    (hash-table-ref/default var-params "params"    "")))
;;     (tasks:add mdb action owner target runname testpatts params)))

;; return one task from those who are 'new' OR 'waiting' AND more than 10sec old
;;
(define (tasks:snag-a-task dbstruct)
  (let ((res    #f)
	(keytxt (conc (current-process-id) "-" (get-host-name) "-" (car (user-information (current-user-id))))))
    (db:with-db
     dbstruct #f #t
     (lambda (db)
       ;; first randomly set a new to pid-hostname-hostname
       (sqlite3:execute
	db 
	"UPDATE tasks_queue SET keylock=? WHERE id IN
           (SELECT id FROM tasks_queue 
              WHERE state='new' OR 
                    (state='waiting' AND (strftime('%s','now')-execution_time) > 10) OR
                    state='reset'
              ORDER BY RANDOM() LIMIT 1);" keytxt)

       (sqlite3:for-each-row
	(lambda (id . rem)
	  (set! res (apply vector id rem)))
	db
	"SELECT id,action,owner,state,target,name,test,item,params,creation_time,execution_time FROM tasks_queue WHERE keylock=? ORDER BY execution_time ASC LIMIT 1;" keytxt)
       (if res ;; yep, have work to be done
	   (begin
	     (sqlite3:execute db "UPDATE tasks_queue SET state='inprogress',execution_time=strftime('%s','now') WHERE id=?;"
			      (tasks:task-get-id res))
	     res)
	   #f)))))

(define (tasks:reset-stuck-tasks dbstruct)
  (let ((res '()))
    (db:with-db
     dbstruct #f #t
     (lambda (db)
       (sqlite3:for-each-row
	(lambda (id delta)
	  (set! res (cons id res)))
	db
	"SELECT id,strftime('%s','now')-execution_time AS delta FROM tasks_queue WHERE state='inprogress' AND delta>700 ORDER BY delta DESC LIMIT 2;")
       (sqlite3:execute 
	db 
	(conc "UPDATE tasks_queue SET state='reset' WHERE id IN ('" (string-intersperse (map conc res) "','") "');")
	)))))

;; return all tasks in the tasks_queue table
;;
(define (tasks:get-tasks dbstruct types states)
  (let ((res '()))
    (db:with-db
     dbstruct #f #f
     (lambda (db)
       (sqlite3:for-each-row
	(lambda (id . rem)
	  (set! res (cons (apply vector id rem) res)))
	db
	(conc "SELECT id,action,owner,state,target,name,test,item,params,creation_time,execution_time 
                  FROM tasks_queue "
	      ;; WHERE  
	      ;;   state IN " statesstr " AND 
	      ;;   action IN " actionsstr 
	      " ORDER BY creation_time DESC;"))
       res))))

;; remove tasks given by a string of numbers comma separated
(define (tasks:remove-queue-entries dbstruct task-ids)
  (db:with-db
   dbstruct #f #t
   (lambda (db)
     (sqlite3:execute db (conc "DELETE FROM tasks_queue WHERE id IN (" task-ids ");")))))

(define (tasks:process-queue dbstruct)
  (let* ((task   (tasks:snag-a-task dbstruct))
	 (action (if task (tasks:task-get-action task) #f)))
    (if action (print "tasks:process-queue task: " task))
    (if action
	(case (string->symbol action)
	  ((run)       (tasks:start-run     dbstruct task))
	  ((remove)    (tasks:remove-runs   dbstruct task))
	  ((lock)      (tasks:lock-runs     dbstruct task))
	  ;; ((monitor)   (tasks:start-monitor db task))
	  ((rollup)    (tasks:rollup-runs   dbstruct task))
	  ((updatemeta)(tasks:update-meta   dbstruct task))
	  ((kill)      (tasks:kill-monitors dbstruct task))))))

(define (tasks:tasks->text tasks)
  (let ((fmtstr "~10a~10a~10a~12a~20a~12a~12a~10a"))
    (conc (format #f fmtstr "id" "action" "owner" "state" "target" "runname" "testpatts" "params") "\n"
	  (string-intersperse 
	   (map (lambda (task)
		  (format #f fmtstr
			  (tasks:task-get-id     task)
			  (tasks:task-get-action task)
			  (tasks:task-get-owner  task)
			  (tasks:task-get-state  task)
			  (tasks:task-get-target task)
			  (tasks:task-get-name   task)
			  (tasks:task-get-test   task)
			  ;; (tasks:task-get-item   task)
			  (tasks:task-get-params task)))
		tasks) "\n"))))
   
(define (tasks:set-state dbstruct task-id state)
  (db:with-db 
   dbstruct #f #t
   (lambda (db)
     (sqlite3:execute db "UPDATE tasks_queue SET state=? WHERE id=?;" 
		      state 
		      task-id))))

;;======================================================================
;; Access using task key (stored in params; (hash-table->alist flags) hostname pid
;;======================================================================

(define (tasks:param-key->id dbstruct task-params)
  (db:with-db
   dbstruct #f #f
   (lambda (db)
     (handle-exceptions
      exn
      #f
      (sqlite3:first-result db "SELECT id FROM tasks_queue WHERE params LIKE ?;"
			    task-params)))))

(define (tasks:set-state-given-param-key dbstruct param-key new-state)
  (db:with-db
   dbstruct #f #t
   (lambda (db)
     (sqlite3:execute db "UPDATE tasks_queue SET state=? WHERE params LIKE ?;" new-state param-key))))

(define (tasks:get-records-given-param-key dbstruct param-key state-patt action-patt test-patt)
  (db:with-db
   dbstruct #f #f
   (lambda (db)
     (handle-exceptions
      exn
      '()
      (sqlite3:first-row db "SELECT id,action,owner,state,target,name,testpatt,keylock,params WHERE
                               params LIKE ? AND state LIKE ? AND action LIKE ? AND testpatt LIKE ?;"
			 param-key state-patt action-patt test-patt)))))


(define (tasks:find-task-queue-records dbstruct target run-name test-patt state-patt action-patt)
  ;; (handle-exceptions
  ;;  exn
  ;;  '()
  ;;  (sqlite3:first-row
  (let ((db (db:delay-if-busy (db:get-db dbstruct #f)))
	(res '()))
    (sqlite3:for-each-row 
     (lambda (a . b)
       (set! res (cons (cons a b) res)))
     db "SELECT id,action,owner,state,target,name,testpatt,keylock,params FROM tasks_queue 
           WHERE
              target = ? AND name = ? AND state LIKE ? AND action LIKE ? AND testpatt LIKE ?;"
     target run-name state-patt action-patt test-patt)
    res)) ;; )

;; kill any runner processes (i.e. processes handling -runtests) that match target/runname
;; 
;; do a remote call to get the task queue info but do the killing as self here.
;;
(define (tasks:kill-runner target run-name)
  (let ((records    (rmt:tasks-find-task-queue-records target run-name "%" "running" "run-tests"))
	(hostpid-rx (regexp "\\s+(\\w+)\\s+(\\d+)$"))) ;; host pid is at end of param string
    (if (null? records)
	(debug:print 0 "No run launching processes found for " target " / " run-name)
	(debug:print 0 "Found " (length records) " run(s) to kill."))
    (for-each 
     (lambda (record)
       (let* ((param-key (list-ref record 8))
	      (match-dat (string-search hostpid-rx param-key)))
	 (if match-dat
	     (let ((hostname  (cadr match-dat))
		   (pid       (string->number (caddr match-dat))))
	       (debug:print 0 "Sending SIGINT to process " pid " on host " hostname)
	       (if (equal? (get-host-name) hostname)
		   (if (process:alive? pid)
		       (begin
			 (handle-exceptions
			  exn
			  (begin
			    (debug:print 0 "Kill of process " pid " on host " hostname " failed.")
			    (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
			    #t)
			  (process-signal pid signal/int)
			  (thread-sleep! 5)
			  (if (process:alive? pid)
			      (process-signal pid signal/kill)))))
		   ;;  (call-with-environment-variables
		   (let ((old-targethost (getenv "TARGETHOST")))
		     (setenv "TARGETHOST" hostname)
		     (setenv "TARGETHOST_LOGF" "server-kills.log")
		     (system (conc "nbfake kill " pid))
		     (if old-targethost (setenv "TARGETHOST" old-targethost))
		     (unsetenv "TARGETHOST")
		     (unsetenv "TARGETHOST_LOGF"))))
	     (debug:print 0 "ERROR: no record or improper record for " target "/" run-name " in tasks_queue in main.db"))))
     records)))

;; (define (tasks:start-run dbstruct mdb task)
;;   (let ((flags (make-hash-table)))
;;     (hash-table-set! flags "-rerun" "NOT_STARTED")
;;     (if (not (string=? (tasks:task-get-params task) ""))
;; 	(hash-table-set! flags "-setvars" (tasks:task-get-params task)))
;;     (print "Starting run " task)
;;     ;; sillyness, just call the damn routine with the task vector and be done with it. FIXME SOMEDAY
;;     (runs:run-tests db
;; 		    (tasks:task-get-target task)
;; 		    (tasks:task-get-name   task)
;; 		    (tasks:task-get-test   task)
;; 		    (tasks:task-get-item   task)
;; 		    (tasks:task-get-owner  task)
;; 		    flags)
;;     (tasks:set-state mdb (tasks:task-get-id task) "waiting")))
;; 
;; (define (tasks:rollup-runs db mdb task)
;;   (let* ((flags (make-hash-table)) 
;; 	 (keys  (db:get-keys db))
;; 	 (keyvals (keys:target-keyval keys (tasks:task-get-target task))))
;;     ;; (hash-table-set! flags "-rerun" "NOT_STARTED")
;;     (print "Starting rollup " task)
;;     ;; sillyness, just call the damn routine with the task vector and be done with it. FIXME SOMEDAY
;;     (runs:rollup-run db
;; 		     keys 
;; 		     keyvals
;; 		     (tasks:task-get-name  task)
;; 		     (tasks:task-get-owner  task))
;;     (tasks:set-state mdb (tasks:task-get-id task) "waiting")))

Added tdb.scm version [6d49ce2a57].



























































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
;;======================================================================
;; Copyright 2006-2013, 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.
;;======================================================================

;;======================================================================
;; 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)
(define (open-test-db work-area) 
  (debug:print-info 11 "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            (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 "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   (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))
	(if (not dbexists)
	    (begin
	      (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = FULL;")
	      (debug:print-info 11 "Initialized test database " dbpath)
	      (tdb:testdb-initialize db)))
	;; (sqlite3:execute db "PRAGMA synchronous = 0;")
	(debug:print-info 11 "open-test-db END (sucessful)" work-area)
	;; now let's test that everything is correct
	(handle-exceptions
	 exn
	 (begin
	   (print-call-chain (current-error-port))
	   (debug:print 0 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test or remove the file " 
			dbpath ".\n  "
			((condition-property-accessor 'exn 'message) exn))
	   #f)
	 ;; Is there a cheaper single line operation that will check for existance of a table
	 ;; and raise an exception ?
	 (sqlite3:execute db "SELECT id FROM test_data LIMIT 1;"))
	db)
      ;; no work-area or not readable - create a placeholder to fake rest of world out
      (let ((baddb (sqlite3:open-database ":memory:")))
 	(debug:print-info 11 "open-test-db END (unsucessful)" work-area)
 	;; provide an in-mem db (this is dangerous!)
 	(tdb:testdb-initialize baddb)
 	baddb)))

;; find and open the testdat.db file for an existing test
(define (tdb:open-test-db-by-test-id test-id #!key (work-area #f))
  (let* ((test-path (if work-area
			work-area
			(rmt:test-get-rundir-from-test-id test-id))))
    (debug:print 3 "TEST PATH: " test-path)
    (open-test-db test-path)))

;; find and open the testdat.db file for an existing test
(define (tdb:open-test-db-by-test-id-local dbstruct run-id test-id #!key (work-area #f))
  (let* ((test-path (if work-area
			work-area
			(db:test-get-rundir-from-test-id dbstruct run-id test-id))))
    (debug:print 3 "TEST PATH: " test-path)
    (open-test-db test-path)))

;; find and open the testdat.db file for an existing test
(define (tdb:open-run-close-db-by-test-id-local dbstruct run-id test-id work-area proc . params)
  (let* ((test-path (if work-area
			work-area
			(db:test-get-rundir-from-test-id dbstruct run-id test-id)))
	 (tdb        (open-test-db test-path)))
    (apply proc tdb params)))

(define (tdb:testdb-initialize db)
  (debug:print 11 "db:testdb-initialize START")
  (sqlite3:with-transaction
   db
   (lambda ()
     (for-each
      (lambda (sqlcmd)
	(sqlite3:execute db sqlcmd))
      (list "CREATE TABLE IF NOT EXISTS test_rundat (
              id INTEGER PRIMARY KEY,
              update_time TIMESTAMP,
              cpuload INTEGER DEFAULT -1,
              diskfree INTEGER DEFAULT -1,
              diskusage INTGER DEFAULT -1,
              run_duration INTEGER DEFAULT 0);"
	    "CREATE TABLE IF NOT EXISTS test_data (
              id INTEGER PRIMARY KEY,
              test_id INTEGER,
              category TEXT DEFAULT '',
              variable TEXT,
	      value REAL,
	      expected REAL,
	      tol REAL,
              units TEXT,
              comment TEXT DEFAULT '',
              status TEXT DEFAULT 'n/a',
              type TEXT DEFAULT '',
              CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));"
	    "CREATE TABLE IF NOT EXISTS test_steps (
              id INTEGER PRIMARY KEY,
              test_id INTEGER, 
              stepname TEXT, 
              state TEXT DEFAULT 'NOT_STARTED', 
              status TEXT DEFAULT 'n/a',
              event_time TIMESTAMP,
              comment TEXT DEFAULT '',
              logfile TEXT DEFAULT '',
              CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));"
	    ;; test_meta can be used for handing commands to the test
	    ;; e.g. KILLREQ
	    ;;      the ackstate is set to 1 once the command has been completed
	    "CREATE TABLE IF NOT EXISTS test_meta (
              id INTEGER PRIMARY KEY,
              var TEXT,
              val TEXT,
              ackstate INTEGER DEFAULT 0,
              CONSTRAINT metadat_constraint UNIQUE (var));"))))
  (debug:print 11 "db:testdb-initialize END"))

(define (tdb:read-test-data tdb test-id categorypatt)
  (let ((res '()))
    (sqlite3:for-each-row 
     (lambda (id test_id category variable value expected tol units comment status type)
       (set! res (cons (vector id test_id category variable value expected tol units comment status type) res)))
     tdb
     "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt)
    (sqlite3:finalize! tdb)
    (reverse res)))

;;======================================================================
;; T E S T   D A T A 
;;======================================================================

;; ;; get a list of test_data records matching categorypatt
;; (define (tdb:read-test-data test-id categorypatt #!key (work-area #f))
;;   (let ((tdb  (tdb:open-test-db-by-test-id test-id work-area: work-area)))
;;     (if (sqlite3:database? tdb)
;; 	(let ((res '()))
;; 	  (sqlite3:for-each-row 
;; 	   (lambda (id test_id category variable value expected tol units comment status type)
;; 	     (set! res (cons (vector id test_id category variable value expected tol units comment status type) res)))
;; 	   tdb
;; 	   "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt)
;; 	  (sqlite3:finalize! tdb)
;; 	  (reverse res))
;; 	'())))

;; NOTE: Run this local with #f for db !!!
(define (tdb:load-test-data run-id test-id)
  (let loop ((lin (read-line)))
    (if (not (eof-object? lin))
	(begin
	  (debug:print 4 lin)
	  (rmt:csv->test-data run-id test-id lin)
	  (loop (read-line)))))
  ;; roll up the current results.
  ;; FIXME: Add the status too 
  (rmt:test-data-rollup run-id test-id #f))

(define (tdb:get-prev-tol-for-test tdb test-id category variable)
  ;; Finish me?
  (values #f #f #f))

;;======================================================================
;; S T E P S 
;;======================================================================

(define (tdb:step-get-time-as-string vec)
  (seconds->time-string (tdb:step-get-event_time vec)))

;; get a pretty table to summarize steps
;;
(define (tdb:get-steps-table steps);; organise the steps for better readability
  (let ((res (make-hash-table)))
    (for-each 
     (lambda (step)
       (debug:print 6 "step=" step)
       (let ((record (hash-table-ref/default 
		      res 
		      (tdb:step-get-stepname step) 
		      ;;        stepname                start end status Duration  Logfile 
		      (vector (tdb:step-get-stepname step) ""   "" ""     ""        ""))))
	 (debug:print 6 "record(before) = " record 
		      "\nid:       " (tdb:step-get-id step)
		      "\nstepname: " (tdb:step-get-stepname step)
		      "\nstate:    " (tdb:step-get-state step)
		      "\nstatus:   " (tdb:step-get-status step)
		      "\ntime:     " (tdb:step-get-event_time step))
	 (case (string->symbol (tdb:step-get-state step))
	   ((start)(vector-set! record 1 (tdb:step-get-event_time step))
	    (vector-set! record 3 (if (equal? (vector-ref record 3) "")
				      (tdb:step-get-status step)))
	    (if (> (string-length (tdb:step-get-logfile step))
		   0)
		(vector-set! record 5 (tdb:step-get-logfile step))))
	   ((end)  
	    (vector-set! record 2 (any->number (tdb:step-get-event_time step)))
	    (vector-set! record 3 (tdb:step-get-status step))
	    (vector-set! record 4 (let ((startt (any->number (vector-ref record 1)))
					(endt   (any->number (vector-ref record 2))))
				    (debug:print 4 "record[1]=" (vector-ref record 1) 
						 ", startt=" startt ", endt=" endt
						 ", get-status: " (tdb:step-get-status step))
				    (if (and (number? startt)(number? endt))
					(seconds->hr-min-sec (- endt startt)) "-1")))
	    (if (> (string-length (tdb:step-get-logfile step))
		   0)
		(vector-set! record 5 (tdb:step-get-logfile step))))
	   (else
	    (vector-set! record 2 (tdb:step-get-state step))
	    (vector-set! record 3 (tdb:step-get-status step))
	    (vector-set! record 4 (tdb:step-get-event_time step))))
	 (hash-table-set! res (tdb:step-get-stepname step) record)
	 (debug:print 6 "record(after)  = " record 
		      "\nid:       " (tdb:step-get-id step)
		      "\nstepname: " (tdb:step-get-stepname step)
		      "\nstate:    " (tdb:step-get-state step)
		      "\nstatus:   " (tdb:step-get-status step)
		      "\ntime:     " (tdb:step-get-event_time step))))
     ;; (else   (vector-set! record 1 (tdb:step-get-event_time step)))
     (sort steps (lambda (a b)
		   (cond
		    ((<   (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t)
		    ((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b)) 
		     (<   (tdb:step-get-id a)        (tdb:step-get-id b)))
		    (else #f)))))
    res))

;; Move this to steps.scm
;;
;; get a pretty table to summarize steps
;;
(define (tdb:get-steps-table-list steps)
  ;; organise the steps for better readability
  (let ((res (make-hash-table)))
    (for-each 
     (lambda (step)
       (debug:print 6 "step=" step)
       (let ((record (hash-table-ref/default 
		      res 
		      (tdb:step-get-stepname step) 
		      ;;        stepname                start end status    
		      (vector (tdb:step-get-stepname step) ""   "" ""     "" ""))))
	 (debug:print 6 "record(before) = " record 
		      "\nid:       " (tdb:step-get-id step)
		      "\nstepname: " (tdb:step-get-stepname step)
		      "\nstate:    " (tdb:step-get-state step)
		      "\nstatus:   " (tdb:step-get-status step)
		      "\ntime:     " (tdb:step-get-event_time step))
	 (case (string->symbol (tdb:step-get-state step))
	   ((start)(vector-set! record 1 (tdb:step-get-event_time step))
	    (vector-set! record 3 (if (equal? (vector-ref record 3) "")
				      (tdb:step-get-status step)))
	    (if (> (string-length (tdb:step-get-logfile step))
		   0)
		(vector-set! record 5 (tdb:step-get-logfile step))))
	   ((end)  
	    (vector-set! record 2 (any->number (tdb:step-get-event_time step)))
	    (vector-set! record 3 (tdb:step-get-status step))
	    (vector-set! record 4 (let ((startt (any->number (vector-ref record 1)))
					(endt   (any->number (vector-ref record 2))))
				    (debug:print 4 "record[1]=" (vector-ref record 1) 
						 ", startt=" startt ", endt=" endt
						 ", get-status: " (tdb:step-get-status step))
				    (if (and (number? startt)(number? endt))
					(seconds->hr-min-sec (- endt startt)) "-1")))
	    (if (> (string-length (tdb:step-get-logfile step))
		   0)
		(vector-set! record 5 (tdb:step-get-logfile step))))
	   (else
	    (vector-set! record 2 (tdb:step-get-state step))
	    (vector-set! record 3 (tdb:step-get-status step))
	    (vector-set! record 4 (tdb:step-get-event_time step))))
	 (hash-table-set! res (tdb:step-get-stepname step) record)
	 (debug:print 6 "record(after)  = " record 
		      "\nid:       " (tdb:step-get-id step)
		      "\nstepname: " (tdb:step-get-stepname step)
		      "\nstate:    " (tdb:step-get-state step)
		      "\nstatus:   " (tdb:step-get-status step)
		      "\ntime:     " (tdb:step-get-event_time step))))
     ;; (else   (vector-set! record 1 (tdb:step-get-event_time step)))
     (sort steps (lambda (a b)
		   (cond
		    ((<   (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t)
		    ((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b)) 
		     (<   (tdb:step-get-id a)        (tdb:step-get-id b)))
		    (else #f)))))
    res))

;;
;; Move to steps.scm
;;
(define (tdb:get-compressed-steps comprsteps) ;; from tdb:get-steps-table
  (map (lambda (x)
	 ;; take advantage of the \n on time->string
	 (vector
	  (vector-ref x 0)
	  (let ((s (vector-ref x 1)))
	    (if (number? s)(seconds->time-string s) s))
	  (let ((s (vector-ref x 2)))
	    (if (number? s)(seconds->time-string s) s))
	  (vector-ref x 3)    ;; status
	  (vector-ref x 4)
	  (vector-ref x 5)))  ;; time delta
       (sort (hash-table-values comprsteps)
	     (lambda (a b)
	       (let ((time-a (vector-ref a 1))
		     (time-b (vector-ref b 1)))
		 (if (and (number? time-a)(number? time-b))
		     (if (< time-a time-b)
			 #t
			 (if (eq? time-a time-b)
			     (string<? (conc (vector-ref a 2))
				       (conc (vector-ref b 2)))
			     #f))
		     (string<? (conc time-a)(conc time-b))))))))

;; 
(define (tdb:remote-update-testdat-meta-info run-id test-id work-area cpuload diskfree minutes)
  (let ((tdb         (rmt:open-test-db-by-test-id run-id test-id work-area: work-area)))
    (if (sqlite3:database? tdb)
	(begin
	  (sqlite3:execute tdb "INSERT INTO test_rundat (update_time,cpuload,diskfree,run_duration) VALUES (strftime('%s','now'),?,?,?);"
			   cpuload diskfree minutes)
	  (sqlite3:finalize! tdb))
	(debug:print 2 "Can't update testdat.db for test " test-id " read-only or non-existant"))))
    

Added testnanomsg/basic-req-rep.scm version [1436c827c9].







>
>
>
1
2
3
(use nanomsg srfi-18 sqlite3 numbers)

(define resp (nn-socket 'rep))

Added testnanomsg/mockupclient.scm version [63a8c6685a].





















































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
(use zmq posix numbers)

(define cname "Bob")
(define runtime 10)
(let ((args (argv)))
  (if (< (length args) 3)
      (begin
	(print "Usage: mockupclient clientname runtime")
	(exit))
      (begin
	(set! cname (cadr args))
	(set! runtime (string->number (caddr args))))))
      
;; (define start-delay (/ (random 100) 9))
;; (define runtime     (+ 1 (/ (random 200) 2)))

(print "Starting client " cname " with runtime " runtime)

(include "mockupclientlib.scm")

(set! endtime (+ (current-seconds) runtime))

;; first ping the server to ensure we have a connection
(if (server-ping cname 5)
    (print "SUCCESS: Client " cname " connected to server")
    (begin
      (print "ERROR: Client " cname " failed ping of server, exiting")
      (exit)))

(let loop ()
  (let ((x (random 15))
	(varname (list-ref (list "hello" "goodbye" "saluton" "kiaorana")(random 4))))
    (case x
      ;; ((1)(dbaccess cname 'sync "nodat"    #f))
      ((2 3 4 5)(dbaccess cname 'set varname (random 999)))
      ((6 7 8 9 10)(print cname ": Get \"" varname "\" " (dbaccess cname 'get varname #f)))
      (else
       (thread-sleep! 0.011)))
    (if (< (current-seconds) endtime)
	(loop))))

(print "Client " cname " all done!!")

Added testnanomsg/mockupclientlib.scm version [3b245ba7a9].





















































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
(define reqs (nn-socket 'req))

(connect-socket reqs "tcp://localhost:6563")

(thread-sleep! 0.2)

(define (server-ping cname timeout)
  (let ((msg     (conc cname ":ping:" timeout))
	(maxtime (+ (current-seconds) timeout)))
    (print "pinging server from " cname " with timeout " timeout)
    (let loop ((res   #f))
      (if (< maxtime (current-seconds))
	  #f ;; failed to ping
	  (if (equal? res "Got ping")
	      #t
	      (begin
		(print "Ping received from server " res)
		(send-message push msg)
		(thread-sleep! 0.1)
		(loop (receive-message sub non-blocking: #t))))))))
  
(define (dbaccess cname cmd var val #!key (numtries 20))
  (let* ((msg (conc cname ":" cmd ":" (if val (conc var " " val) var)))
	 (res #f)
	 (mtx1 (make-mutex))
	 (do-access (lambda ()
		      (let ((tmpres #f))
			(print "Sending msg: " msg)
			(send-message push msg)
			(print "Message " msg " sent")
			(print "Client " cname " waiting for response to " msg)
			(print "Client " cname " received address " (receive-message* sub))
			(set! tmpres (receive-message* sub))
			(mutex-lock! mtx1)
			(set! res tmpres)
			(mutex-unlock! mtx1))))
	 (th1 (make-thread do-access "do access"))
	 (th2 (make-thread (lambda ()
			     (let ((result #f))
			       (mutex-lock! mtx1)
			       (set! result res)
			       (mutex-unlock! mtx1)
			       (thread-sleep! 5)
			       (if (not result)
				   (if (> numtries 0)
				       (begin
					 (print "WARNING: access timed out for " cname ", trying again. Trys remaining=" numtries)
					 (dbaccess cname cmd var val numtries: (- numtries 1)))
				       (begin
					 (print "ERROR: dbaccess timed out. Exiting")
					 (exit)))))
			     "timeout thread"))))
    (thread-start! th1)
    (thread-start! th2)
    (thread-join! th1)
    (if res (print "SUCCESS: received " res " with " numtries " remaining possible attempts"))
    res))

Added testnanomsg/mockupserver.scm version [a4d3e5594c].





































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
;; pub/sub with envelope address
;; Note that if you don't insert a sleep, the server will crash with SIGPIPE as soon
;; as a client disconnects.  Also a remaining client may receive tons of
;; messages afterward.

(use nanomsg srfi-18 sqlite3 numbers)

(define resp (nn-socket 'rep))
(define cname "server")
(define total-db-accesses 0)
(define start-time (current-seconds))

(nn-bind resp  "tcp://*:6563")

(thread-sleep! 0.2)

(define (open-db)
  (let* ((dbpath    "mockup.db")
	 (dbexists  (file-exists? dbpath))
	 (db        (open-database dbpath)) ;; (never-give-up-open-db dbpath))
	 (handler   (make-busy-timeout 10)))
    (set-busy-handler! db handler)
    (if (not dbexists)
	(for-each
	 (lambda (stmt)
	   (execute db stmt))
	 (list
	  "PRAGMA SYNCHRONOUS=0;"
	  "CREATE TABLE clients (id INTEGER PRIMARY KEY,name TEXT,num_accesses INTEGER DEFAULT 0);"
	  "CREATE TABLE vars    (var TEXT,val TEXT,CONSTRAINT vars_constraint UNIQUE (var));")))
    db))

(define cid-cache (make-hash-table))

(define (get-client-id db cname)
  (let ((cid (hash-table-ref/default cid-cache cname #f)))
    (if cid 
	cid
	(begin
	  (execute db "INSERT OR REPLACE INTO clients (name) VALUES(?);" cname)
	  (for-each-row 
	   (lambda (id)
	     (set! cid id))
	   db
	   "SELECT id FROM clients WHERE name=?;" cname)
	  (hash-table-set! cid-cache cname cid)
	  (set! total-db-accesses (+ total-db-accesses 2))
	  cid))))

(define (count-client db cname)
  (let ((cid (get-client-id db cname)))
    (execute db "UPDATE clients SET num_accesses=num_accesses+1 WHERE id=?;" cid)
    (set! total-db-accesses (+ total-db-accesses 1))
    ))

(define db (open-db))
;; (define queuelst '())
;; (define mx1 (make-mutex))

(define max-queue-len 0)

(define (process-queue queuelst)
  (let ((queuelen (length queuelst)))
    (if (> queuelen max-queue-len)
	(set! max-queue-len queuelen))
    (for-each
     (lambda (item)
       (let ((cname (vector-ref item 1))
	     (clcmd (vector-ref item 2))
	     (cdata (vector-ref item 3)))
	 (send-message pub cname send-more: #t)
	 (send-message pub (case clcmd
			     ((sync)
			      (conc queuelen))
			     ((set)
			      (set! total-db-accesses (+ total-db-accesses 1))
			      (apply execute db "INSERT OR REPLACE INTO vars (var,val) VALUES (?,?);" (string-split cdata))
			      "ok")
			     ((get)
			      (set! total-db-accesses (+ total-db-accesses 1))
			      (let ((res "noval"))
				(for-each-row
				 (lambda (val)
				   (set! res val))
				 db 
				 "SELECT val FROM vars WHERE var=?;" cdata)
				res))
			     (else (conc "unk cmd: " clcmd))))))
     queuelst)))

;; SERVER THREAD
(define th1 (make-thread 
	     (lambda ()
	       (let ((last-run 0)) ;; current-seconds when run last
		 (let loop ((queuelst '()))
		   (let* ((indat (receive-message* pull))
			  (parts (string-split indat ":"))
			  (cname (car parts))                   ;; client name
			  (clcmd (string->symbol (cadr parts))) ;; client cmd
			  (cdata (caddr parts))                 ;; client data
			  (svect (vector (current-seconds) cname clcmd cdata))) ;; record for the queue
		     ;; (print "Server received message: " indat)
		     (count-client db cname)
		     (case clcmd
		       ((ping)
			(print "Got ping from " cname)
			(send-message pub cname send-more: #t)
			(send-message pub "Got ping")
			(loop queuelst))
		       ((sync) ;; just process the queue
			(print "Got sync from " cname)
			(process-queue (cons svect queuelst))
			(loop '()))
		       ((get)
			(process-queue (cons svect queuelst))
			(loop '()))
		       (else
			(loop (cons svect queuelst))))))))
	     "server thread"))

(include "mockupclientlib.scm")

;; SYNC THREAD
;; send a sync to the pull port
(define th2 (make-thread
	     (lambda ()
	       (let ((last-action-time (current-seconds)))
		 (let loop ()
		   (thread-sleep! 5)
		   (let ((queuelen (string->number (dbaccess "server" 'sync "nada" #f)))
			 (last-action-delta #f))
		     (if (> queuelen 1)(set! last-action-time (current-seconds)))
		     (set! last-action-delta (- (current-seconds) last-action-time))
		     (print "Server: Got queuelen=" queuelen ", last-action-delta=" last-action-delta)
		     (if (< last-action-delta 60)
			 (loop)
			 (print "Server exiting, 25 seconds since last access"))))))
	     "sync thread"))

(thread-start! th1)
(thread-start! th2)
(thread-join! th2)

(let* ((run-time       (- (current-seconds) start-time))
       (queries/second (/  total-db-accesses run-time)))
  (print "Server exited! Total db accesses=" total-db-accesses " in " run-time " seconds for " queries/second " queries/second with max queue length of: " max-queue-len))

Added testnanomsg/pipeline.scm version [1d4d831eb6].



















































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
;; watch nanomsg's pipeline load-balancer in action.
(use nanomsg)

(define push (nn-socket 'push))
(define pull1 (nn-socket 'pull))
(define pull2 (nn-socket 'pull))

(nn-bind    push  "inproc://test")
(nn-connect pull1 "inproc://test")
(nn-connect pull2 "inproc://test")

(nn-send push "a")
(nn-send push "b")
(nn-send push "c")
(nn-send push "d")

(define ((th sock))
  (print (current-thread) ": " (nn-recv sock))
  (print (current-thread) ": " (nn-recv sock))
  (print (current-thread) " is done"))

(thread-start! (th pull1))
(thread-start! (th pull2))

(thread-sleep! 1)

Added testnanomsg/req-rep-client.scm version [7998d54555].





























































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
;; watch nanomsg's pipeline load-balancer in action.
(use nanomsg)

(define req   (nn-socket 'req))

(nn-connect req  "tcp://localhost:22022")

;; (with-output-to-string (lambda ()(serialize obj)))
(define (client-send-receive soc msg)
  (nn-send soc msg)
  (nn-recv soc))

(define ((talk-to-server soc))
  (let loop ((cnt 20))
    (let ((name (list-ref '("Matt" "Tom" "Bob" "Jill" "James" "Jane")(random 6))))
      (print "Sending " name)
      (print (client-send-receive req name))
      (if (> cnt 0)(loop (- cnt 1)))))
  (print (client-send-receive req "quit"))
  (nn-close req)
  (exit))

;; (thread-start! (lambda ()
;; 		 (thread-sleep! 20)
;; 		 (print "Give up on waiting for the server")
;; 		 (nn-close req)
;; 		 (exit)))

(thread-join! (thread-start! (talk-to-server req)))

Added testnanomsg/req-rep-server.scm version [d9de6da037].





















































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
;; watch nanomsg's pipeline load-balancer in action.
(use nanomsg)

;; (use trace)
;; (trace nn-bind nn-socket nn-assert nn-recv nn-send thread-terminate! nn-close )

(define port  22022)
(define host  "127.0.0.1")

(define rep   (nn-socket 'rep))

(print "connecting, got: " (nn-bind    rep  (conc "tcp://" "*" ":" port)))

(define (server soc)
  (print "server starting")
  (let loop ((msg-in (nn-recv soc)))
    (print "server received: " msg-in)
    (cond
     ((equal? msg-in "quit")
      (nn-send soc "Ok, quitting"))
     ((and (>= (string-length msg-in) 4)
	   (equal? (substring msg-in 0 4) "ping"))
      (nn-send soc (conc (current-process-id)))
      (loop (nn-recv soc)))
     ;;((and (>= (string-length msg-in)
     (else
      (let ((this-task (random 15)))
	(thread-sleep! this-task)
	(nn-send soc (conc "hello " msg-in " this task took " this-task " seconds to complete"))
	(loop (nn-recv soc)))))))

(define (ping-self host port #!key (return-socket #t))
  ;; send a random number along with pid and check that we get it back
  (let* ((req     (nn-socket 'req))
	 (key     "ping")
	 (success #f)
	 (keepwaiting #t)
	 (ping    (make-thread
		   (lambda ()
		     (print "ping: sending string \"" key "\", expecting " (current-process-id))
		     (nn-send req key)
		     (let ((result  (nn-recv req)))
		       (if (equal? (conc (current-process-id)) result)
			   (begin
			     (print "ping, success: received \"" result "\"")
			     (set! success #t))
			   (begin
			     (print "ping, failed: received key \"" result "\"")
			     (set! keepwaiting #f)
			     (set! success #f)))))
		   "ping"))
	 (timeout (make-thread (lambda ()
				 (let loop ((count 0))
				   (thread-sleep! 1)
				   (print "still waiting after count seconds...")
				   (if (and keepwaiting (< count 10))
				       (loop (+ count 1))))
				 (if keepwaiting
				     (begin
				       (print "timeout waiting for ping")
				       (thread-terminate! ping))))
			       "timeout")))
    (nn-connect req (conc "tcp://" host ":" port))
    (handle-exceptions
     exn
     (begin
       (print-call-chain)
       (print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
       (print "exn=" (condition->list exn))
       (print "ping failed to connect to " host ":" port))
     (thread-start! timeout)
     (thread-start! ping)
     (thread-join! ping)
     (if success (thread-terminate! timeout)))
    (if return-socket
	(if success req #f)
	(begin
	  (nn-close req)
	  success))))

(let ((server-thread (make-thread (lambda ()(server rep)) "server")))
  (thread-start! server-thread)
  ;; (thread-sleep! 1)
  (if (ping-self host port)
      (begin
	(thread-join! server-thread)
	(nn-close rep))
      (print "ping failed")))

(exit)

Added testnanomsg/req-rep.scm version [b77ebf1421].





























































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
;; watch nanomsg's pipeline load-balancer in action.
(use nanomsg)

(define req   (nn-socket 'req))
(define rep   (nn-socket 'rep))

(nn-bind    rep  "inproc://test")
(nn-connect req  "inproc://test")

(define (client-send-receive soc msg)
  (nn-send soc msg)
  (nn-recv soc))

(define ((server soc))
  (let loop ((msg-in (nn-recv soc)))
    (if (not (equal? msg-in "quit"))
	(begin
	  (nn-send soc (conc "hello " msg-in))
	  (loop (nn-recv soc))))))

(thread-start! (server rep))

(print (client-send-receive req "Matt"))
(print (client-send-receive req "Tom"))

;; (client-send-receive req "quit")

(nn-close req)
(nn-close rep)
(exit)

Added testrpc/client.scm version [eacc9c3c29].

















>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
;;;; client.scm
(use rpc posix)

(define call (rpc:procedure 'foo "localhost"))

(do ((i 10 (sub1 i)))
    ((zero? i))
  (print "-> " (call (random 100))))

Added testrpc/server.scm version [d4d2e05e92].































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
;;;; server.scm
(use rpc)

(rpc:publish-procedure!
 'foo
 (lambda (x)
   (print "foo: " x)
   #f))

(rpc:publish-procedure!
 'fini
 (lambda () (print "fini") (thread-start! (lambda () (thread-sleep! 3) (print "terminate") (exit))) #f))

((rpc:make-server (tcp-listen (rpc:default-server-port))) #t)

Modified tests.scm from [a0ed3411a7] to [1b02d35c8f].

11
12
13
14
15
16
17

18
19
20
21

22

23
24

25
26
27
28
29
30
31

;;======================================================================
;; Tests
;;======================================================================

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


(declare (unit tests))
(declare (uses lock-queue))
(declare (uses db))

(declare (uses common))

(declare (uses items))
(declare (uses runconfig))


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








>




>

>


>







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

;;======================================================================
;; Tests
;;======================================================================

(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils)
(import (prefix sqlite3 sqlite3:))
(require-library stml)

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

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

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
		     (qry        (conc "(" test-qry " AND " item-qry ")")))
		;; (print "tests:match => patt-parts: " patt-parts ", test-patt: " test-patt ", item-patt: " item-patt)
		(if (null? tal)
		    (string-intersperse (append (reverse res)(list qry)) " OR ")
		    (loop (car tal)(cdr tal)(cons qry res)))))))
      #f))

;; get the previous record for when this test was run where all keys match but runname
;; returns #f if no such test found, returns a single test record if found
;; 
;; Run this server-side
;;
(define (test:get-previous-test-run-record db run-id test-name item-path)
  (let* ((keys    (db:get-keys db))
	 (selstr  (string-intersperse  keys ","))
	 (qrystr  (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND "))
	 (keyvals #f))
    ;; first look up the key values from the run selected by run-id
    (sqlite3:for-each-row 
     (lambda (a . b)
       (set! keyvals (cons a b)))
     db
     (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id)
    (if (not keyvals)
	#f
	(let ((prev-run-ids '()))
	  (apply sqlite3:for-each-row
		 (lambda (id)
		   (set! prev-run-ids (cons id prev-run-ids)))
		 db
		 (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id)))
	  ;; for each run starting with the most recent look to see if there is a matching test
	  ;; if found then return that matching test record
	  (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids)
	  (if (null? prev-run-ids) #f
	      (let loop ((hed (car prev-run-ids))
			 (tal (cdr prev-run-ids)))
		(let ((results (db:get-tests-for-run db hed (conc test-name "/" item-path)'() '() #f #f #f #f #f)))
		  (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results)
		  (if (and (null? results)
			   (not (null? tal)))
		      (loop (car tal)(cdr tal))
		      (if (null? results) #f
			  (car results))))))))))
    
;; get the previous records for when these tests were run where all keys match but runname
;; NB// Merge this with test:get-previous-test-run-records? This one looks for all matching tests
;; can use wildcards. Also can likely be factored in with get test paths?
;;
;; Run this remotely!!
;;
(define (test:get-matching-previous-test-run-records db run-id test-name item-path)
  (let* ((keys    (db:get-keys db))
	 (selstr  (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ","))
	 (qrystr  (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND "))
	 (keyvals #f)
	 (tests-hash (make-hash-table)))
    ;; first look up the key values from the run selected by run-id
    (sqlite3:for-each-row 
     (lambda (a . b)
       (set! keyvals (cons a b)))
     db
     (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id)
    (if (not keyvals)
	'()
	(let ((prev-run-ids '()))
	  (apply sqlite3:for-each-row
		 (lambda (id)
		   (set! prev-run-ids (cons id prev-run-ids)))
		 db
		 (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id)))
	  ;; collect all matching tests for the runs then
	  ;; extract the most recent test and return that.
	  (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals 
		       ", previous run ids found: " prev-run-ids)
	  (if (null? prev-run-ids) '()  ;; no previous runs? return null
	      (let loop ((hed (car prev-run-ids))
			 (tal (cdr prev-run-ids)))
		(let ((results (db:get-tests-for-run db hed (conc test-name "/" item-path) '() '() #f #f #f #f #f)))
		  (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name 
			       ", item-path " item-path " results: " (intersperse results "\n"))
		  ;; Keep only the youngest of any test/item combination
		  (for-each 
		   (lambda (testdat)
		     (let* ((full-testname (conc (db:test-get-testname testdat) "/" (db:test-get-item-path testdat)))
			    (stored-test   (hash-table-ref/default tests-hash full-testname #f)))
		       (if (or (not stored-test)
			       (and stored-test
				    (> (db:test-get-event_time testdat)(db:test-get-event_time stored-test))))
			   ;; this test is younger, store it in the hash
			   (hash-table-set! tests-hash full-testname testdat))))
		   results)
		  (if (null? tal)
		      (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests
		      (loop (car tal)(cdr tal))))))))))

;; Check for waiver eligibility
;;
(define (tests:check-waiver-eligibility testdat prev-testdat)
  (let* ((test-registry (make-hash-table))
	 (testconfig  (tests:get-testconfig (db:test-get-testname testdat) test-registry #f))

	 (test-rundir (db:test-get-rundir testdat))

	 (prev-rundir (db:test-get-rundir prev-testdat))
	 (waivers     (configf:section-vars testconfig "waivers"))
	 (waiver-rx   (regexp "^(\\S+)\\s+(.*)$"))
	 (diff-rule   "diff %file1% %file2%")
	 (logpro-rule "diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html"))
    (if (not (file-exists? test-rundir))
	(begin
	  (debug:print 0 "ERROR: test run directory is gone, cannot propagate waiver")







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





>
|
>
|







128
129
130
131
132
133
134

























































































135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
		     (qry        (conc "(" test-qry " AND " item-qry ")")))
		;; (print "tests:match => patt-parts: " patt-parts ", test-patt: " test-patt ", item-patt: " item-patt)
		(if (null? tal)
		    (string-intersperse (append (reverse res)(list qry)) " OR ")
		    (loop (car tal)(cdr tal)(cons qry res)))))))
      #f))


























































































;; Check for waiver eligibility
;;
(define (tests:check-waiver-eligibility testdat prev-testdat)
  (let* ((test-registry (make-hash-table))
	 (testconfig  (tests:get-testconfig (db:test-get-testname testdat) test-registry #f))
	 (test-rundir ;; (sdb:qry 'passstr 
	  (db:test-get-rundir testdat)) ;; )
	 (prev-rundir ;; (sdb:qry 'passstr 
	  (db:test-get-rundir prev-testdat)) ;; )
	 (waivers     (configf:section-vars testconfig "waivers"))
	 (waiver-rx   (regexp "^(\\S+)\\s+(.*)$"))
	 (diff-rule   "diff %file1% %file2%")
	 (logpro-rule "diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html"))
    (if (not (file-exists? test-rundir))
	(begin
	  (debug:print 0 "ERROR: test run directory is gone, cannot propagate waiver")
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
				    (if (null? tal)
					#t
					(loop (car tal)(cdr tal)))
				    #f))))))
	    (pop-directory)
	    result)))))

(define (tests:test-force-state-status! test-id state status)
  (cdb:test-set-status-state *runremote* test-id status state #f)
  (mt:process-triggers test-id state status))

;; Do not rpc this one, do the underlying calls!!!
(define (tests:test-set-status! test-id state status comment dat #!key (work-area #f))
  (debug:print-info 4 "tests:test-set-status! test-id=" test-id ", state=" state ", status=" status ", dat=" dat)
  (let* ((db          #f)
	 (real-status status)
	 (otherdat    (if dat dat (make-hash-table)))
	 (testdat     (cdb:get-test-info-by-id *runremote* test-id))
	 (run-id      (db:test-get-run_id testdat))
	 (test-name   (db:test-get-testname   testdat))
	 (item-path   (db:test-get-item-path testdat))
	 ;; before proceeding we must find out if the previous test (where all keys matched except runname)
	 ;; was WAIVED if this test is FAIL

	 ;; NOTES:
	 ;;  1. Is the call to test:get-previous-run-record remotified?
	 ;;  2. Add test for testconfig waiver propagation control here
	 ;;
	 (prev-test   (if (equal? status "FAIL")
			  (cdb:remote-run test:get-previous-test-run-record #f run-id test-name item-path)
			  #f))
	 (waived   (if prev-test
		       (if prev-test ;; true if we found a previous test in this run series
			   (let ((prev-status  (db:test-get-status  prev-test))
				 (prev-state   (db:test-get-state   prev-test))
				 (prev-comment (db:test-get-comment prev-test)))
			     (debug:print 4 "prev-status " prev-status ", prev-state " prev-state ", prev-comment " prev-comment)







|
|
|


|
<
<
|

|
<
|









|







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
				    (if (null? tal)
					#t
					(loop (car tal)(cdr tal)))
				    #f))))))
	    (pop-directory)
	    result)))))

(define (tests:test-force-state-status! run-id test-id state status)
  (rmt:test-set-status-state run-id test-id status state #f)
  (mt:process-triggers run-id test-id state status))

;; Do not rpc this one, do the underlying calls!!!
(define (tests:test-set-status! run-id test-id state status comment dat #!key (work-area #f))


  (let* ((real-status status)
	 (otherdat    (if dat dat (make-hash-table)))
	 (testdat     (rmt:get-test-info-by-id run-id test-id))

	 (test-name   (db:test-get-testname  testdat))
	 (item-path   (db:test-get-item-path testdat))
	 ;; before proceeding we must find out if the previous test (where all keys matched except runname)
	 ;; was WAIVED if this test is FAIL

	 ;; NOTES:
	 ;;  1. Is the call to test:get-previous-run-record remotified?
	 ;;  2. Add test for testconfig waiver propagation control here
	 ;;
	 (prev-test   (if (equal? status "FAIL")
			  (rmt:get-previous-test-run-record run-id test-name item-path)
			  #f))
	 (waived   (if prev-test
		       (if prev-test ;; true if we found a previous test in this run series
			   (let ((prev-status  (db:test-get-status  prev-test))
				 (prev-state   (db:test-get-state   prev-test))
				 (prev-comment (db:test-get-comment prev-test)))
			     (debug:print 4 "prev-status " prev-status ", prev-state " prev-state ", prev-comment " prev-comment)
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
	(set! real-status "WAIVED"))

    (debug:print 4 "real-status " real-status ", waived " waived ", status " status)

    ;; update the primary record IF state AND status are defined
    (if (and state status)
	(begin
	  (cdb:test-set-status-state *runremote* test-id real-status state (if waived waived comment))
	  (mt:process-triggers test-id state real-status)))
    
    ;; if status is "AUTO" then call rollup (note, this one modifies data in test
    ;; run area, it does remote calls under the hood.
    (if (and test-id state status (equal? status "AUTO")) 
	(db:test-data-rollup #f test-id status work-area: work-area))

    ;; add metadata (need to do this way to avoid SQL injection issues)

    ;; :first_err
    ;; (let ((val (hash-table-ref/default otherdat ":first_err" #f)))
    ;;   (if val
    ;;       (sqlite3:execute db "UPDATE tests SET first_err=? WHERE run_id=? AND testname=? AND item_path=?;" val run-id test-name item-path)))







|
|




|







236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
	(set! real-status "WAIVED"))

    (debug:print 4 "real-status " real-status ", waived " waived ", status " status)

    ;; update the primary record IF state AND status are defined
    (if (and state status)
	(begin
	  (rmt:test-set-status-state run-id test-id real-status state (if waived waived comment))
	  (mt:process-triggers run-id test-id state real-status)))
    
    ;; if status is "AUTO" then call rollup (note, this one modifies data in test
    ;; run area, it does remote calls under the hood.
    (if (and test-id state status (equal? status "AUTO")) 
	(rmt:test-data-rollup run-id test-id status))

    ;; add metadata (need to do this way to avoid SQL injection issues)

    ;; :first_err
    ;; (let ((val (hash-table-ref/default otherdat ":first_err" #f)))
    ;;   (if val
    ;;       (sqlite3:execute db "UPDATE tests SET first_err=? WHERE run_id=? AND testname=? AND item_path=?;" val run-id test-name item-path)))
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
			   variable ","
			   value    ","
			   expected ","
			   tol      ","
			   units    ","
			   dcomment ",," ;; extra comma for status
			   type     )))
	    ;; This was run remote, don't think that makes sense.
	    (db:csv->test-data #f test-id
				dat))))
      
    ;; need to update the top test record if PASS or FAIL and this is a subtest
    (if (not (equal? item-path ""))
	(mt:roll-up-pass-fail-counts run-id test-name item-path status))

    (if (or (and (string? comment)
		 (string-match (regexp "\\S+") comment))
	    waived)
	(let ((cmt  (if waived waived comment)))
	  (cdb:remote-run db:test-set-comment #f test-id cmt)))
    ))


(define (tests:test-set-toplog! db run-id test-name logf) 
  (cdb:client-call *runremote* 'tests:test-set-toplog #t 2 logf run-id test-name))

(define (tests:summarize-items db run-id test-id test-name force)
  ;; if not force then only update the record if one of these is true:
  ;;   1. logf is "log/final.log
  ;;   2. logf is same as outputfilename
  (let* ((outputfilename (conc "megatest-rollup-" test-name ".html"))
	 (orig-dir       (current-directory))
	 (logf-info      (cdb:remote-run db:test-get-logfile-info #f run-id test-name))
	 (logf           (if logf-info (cadr logf-info) #f))
	 (path           (if logf-info (car  logf-info) #f)))
    ;; This query finds the path and changes the directory to it for the test
    (if (and (string? path)
	     (directory? path)) ;; can get #f here under some wierd conditions. why, unknown ...
	(begin
	  (debug:print 4 "Found path: " path)
	  (change-directory path))
	;; (set! outputfilename (conc path "/" outputfilename)))
	(print "No such path: " path))
    (debug:print 4 "summarize-items with logf " logf ", outputfilename " outputfilename " and force " force)
    (if (or (equal? logf "logs/final.log")
	    (equal? logf outputfilename)
	    force)
	(begin
	  (if ;; (not (obtain-dot-lock outputfilename 1 5 7)) ;; retry every second for 20 seconds, call it dead after 30 seconds and steal the lock
              (not (lock-queue:wait-turn outputfilename test-id))

	      (print "Not updating " outputfilename " as another test item has signed up for the job")
	      (begin
		(print "Obtained lock for " outputfilename)
		(let ((oup    (open-output-file outputfilename))
		      (counts (make-hash-table))
		      (statecounts (make-hash-table))
		      (outtxt "")
		      (tot    0)
		      (testdat (cdb:remote-run db:test-get-records-for-index-file #f run-id test-name)))
		  (with-output-to-port
		      oup
		    (lambda ()
		      (set! outtxt (conc outtxt "<html><title>Summary: " test-name 
					 "</title><body><h2>Summary for " test-name "</h2>"))
		      (for-each
		       (lambda (testrecord)
			 (let ((id             (vector-ref testrecord 0))
			       (itempath       (vector-ref testrecord 1))
			       (state          (vector-ref testrecord 2))
			       (status         (vector-ref testrecord 3))
			       (run_duration   (vector-ref testrecord 4))
			       (logf           (vector-ref testrecord 5))
			       (comment        (vector-ref testrecord 6)))
			   (hash-table-set! counts status (+ 1 (hash-table-ref/default counts status 0)))
			   (hash-table-set! statecounts state (+ 1 (hash-table-ref/default statecounts state 0)))
			   (set! outtxt (conc outtxt "<tr>"
					      "<td><a href=\"" itempath "/" logf "\"> " itempath "</a></td>" 
					      "<td>" state    "</td>" 
					      "<td><font color=" (common:get-color-from-status status)
					      ">"   status   "</font></td>"
					      "<td>" (if (equal? comment "")
							 "&nbsp;"
							 comment) "</td>"
							 "</tr>"))))
		       testdat)
		      (print "<table><tr><td valign=\"top\">")
		      ;; Print out stats for status
		      (set! tot 0)
		      (print "<table cellspacing=\"0\" border=\"1\"><tr><td colspan=\"2\"><h2>State stats</h2></td></tr>")
		      (for-each (lambda (state)
				  (set! tot (+ tot (hash-table-ref statecounts state)))
				  (print "<tr><td>" state "</td><td>" (hash-table-ref statecounts state) "</td></tr>"))
				(hash-table-keys statecounts))
		      (print "<tr><td>Total</td><td>" tot "</td></tr></table>")
		      (print "</td><td valign=\"top\">")
		      ;; Print out stats for state
		      (set! tot 0)
		      (print "<table cellspacing=\"0\" border=\"1\"><tr><td colspan=\"2\"><h2>Status stats</h2></td></tr>")
		      (for-each (lambda (status)
				  (set! tot (+ tot (hash-table-ref counts status)))
				  (print "<tr><td><font color=\"" (common:get-color-from-status status) "\">" status
					 "</font></td><td>" (hash-table-ref counts status) "</td></tr>"))
				(hash-table-keys counts))
		      (print "<tr><td>Total</td><td>" tot "</td></tr></table>")
		      (print "</td></td></tr></table>")
		      
		      (print "<table cellspacing=\"0\" border=\"1\">" 
			     "<tr><td>Item</td><td>State</td><td>Status</td><td>Comment</td>"
			     outtxt "</table></body></html>")
		      (release-dot-lock outputfilename)))
		  (close-output-port oup)
		  (lock-queue:release-lock outputfilename test-id)
		  (change-directory orig-dir)
		  ;; NB// tests:test-set-toplog! is remote internal...
		  (tests:test-set-toplog! db run-id test-name outputfilename)







































































		  )))))))











































































































































































;;======================================================================
;; Gather data from test/task specifications
;;======================================================================

;; (define (tests:get-valid-tests testsdir test-patts) ;;  #!key (test-names '()))
;;   (let ((tests (glob (conc testsdir "/tests/*")))) ;; " (string-translate patt "%" "*")))))
;;     (set! tests (filter (lambda (test)(file-exists? (conc test "/testconfig"))) tests))







|
|




|





<
<
|

|
|

|





|









|




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


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

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







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
			   variable ","
			   value    ","
			   expected ","
			   tol      ","
			   units    ","
			   dcomment ",," ;; extra comma for status
			   type     )))
	    ;; This was run remote, don't think that makes sense. Perhaps not, but that is the easiest path for the moment.
	    (rmt:csv->test-data run-id test-id
				dat))))
      
    ;; need to update the top test record if PASS or FAIL and this is a subtest
    (if (not (equal? item-path ""))
	(rmt:roll-up-pass-fail-counts run-id test-name item-path status))

    (if (or (and (string? comment)
		 (string-match (regexp "\\S+") comment))
	    waived)
	(let ((cmt  (if waived waived comment)))


	  (rmt:general-call 'set-test-comment run-id cmt test-id)))))

(define (tests:test-set-toplog! run-id test-name logf) 
  (rmt:general-call 'tests:test-set-toplog run-id logf run-id test-name))

(define (tests:summarize-items run-id test-id test-name force)
  ;; if not force then only update the record if one of these is true:
  ;;   1. logf is "log/final.log
  ;;   2. logf is same as outputfilename
  (let* ((outputfilename (conc "megatest-rollup-" test-name ".html"))
	 (orig-dir       (current-directory))
	 (logf-info      (rmt:test-get-logfile-info run-id test-name))
	 (logf           (if logf-info (cadr logf-info) #f))
	 (path           (if logf-info (car  logf-info) #f)))
    ;; This query finds the path and changes the directory to it for the test
    (if (and (string? path)
	     (directory? path)) ;; can get #f here under some wierd conditions. why, unknown ...
	(begin
	  (debug:print 4 "Found path: " path)
	  (change-directory path))
	;; (set! outputfilename (conc path "/" outputfilename)))
	(debug:print 0 "ERROR: summarize-items for run-id=" run-id ", test-name=" test-name ", no such path: " path))
    (debug:print 4 "summarize-items with logf " logf ", outputfilename " outputfilename " and force " force)
    (if (or (equal? logf "logs/final.log")
	    (equal? logf outputfilename)
	    force)
	(let ((my-start-time (current-seconds))

	      (lockf         (conc outputfilename ".lock")))
	  (let loop ((have-lock  (common:simple-file-lock lockf)))
	    (if have-lock
		(begin
		  (print "Obtained lock for " outputfilename)




















































		  (tests:generate-html-summary-for-iterated-test run-id test-id test-name outputfilename)





		  (common:simple-file-release-lock lockf)
		  (change-directory orig-dir)
		  ;; NB// tests:test-set-toplog! is remote internal...
		  (tests:test-set-toplog! run-id test-name outputfilename))
		;; didn't get the lock, check to see if current update started later than this 
		;; update, if so we can exit without doing any work
		(if (> my-start-time (file-modification-time lockf))
		    ;; we started since current re-gen in flight, delay a little and try again
		    (begin
		      (debug:print-info 1 "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)
	(testdat (rmt:test-get-records-for-index-file run-id test-name)))
    (with-output-to-file outputfilename
      (lambda ()
	(set! outtxt (conc outtxt "<html><title>Summary: " test-name 
			   "</title><body><h2>Summary for " test-name "</h2>"))
	(for-each
	 (lambda (testrecord)
	   (let ((id             (vector-ref testrecord 0))
		 (itempath       (vector-ref testrecord 1))
		 (state          (vector-ref testrecord 2))
		 (status         (vector-ref testrecord 3))
		 (run_duration   (vector-ref testrecord 4))
		 (logf           (vector-ref testrecord 5))
		 (comment        (vector-ref testrecord 6)))
	     (hash-table-set! counts status (+ 1 (hash-table-ref/default counts status 0)))
	     (hash-table-set! statecounts state (+ 1 (hash-table-ref/default statecounts state 0)))
	     (set! outtxt (conc outtxt "<tr>"
				;; "<td><a href=\"" itempath "/" logf "\"> " itempath "</a></td>" 
				"<td><a href=\"" itempath "/test-summary.html\"> " itempath "</a></td>" 
				"<td>" state    "</td>" 
				"<td><font color=" (common:get-color-from-status status)
				">"   status   "</font></td>"
				"<td>" (if (equal? comment "")
					   "&nbsp;"
					   comment) "</td>"
					   "</tr>"))))
	 (if (list? testdat)
	     testdat
	     (begin
	       (print "ERROR: failed to get records with rmt:test-get-records-for-index-file run-id=" run-id "test-name=" test-name)
	       '())))
	
	(print "<table><tr><td valign=\"top\">")
	;; Print out stats for status
	(set! tot 0)
	(print "<table cellspacing=\"0\" border=\"1\"><tr><td colspan=\"2\"><h2>State stats</h2></td></tr>")
	(for-each (lambda (state)
		    (set! tot (+ tot (hash-table-ref statecounts state)))
		    (print "<tr><td>" state "</td><td>" (hash-table-ref statecounts state) "</td></tr>"))
		  (hash-table-keys statecounts))
	(print "<tr><td>Total</td><td>" tot "</td></tr></table>")
	(print "</td><td valign=\"top\">")
	;; Print out stats for state
	(set! tot 0)
	(print "<table cellspacing=\"0\" border=\"1\"><tr><td colspan=\"2\"><h2>Status stats</h2></td></tr>")
	(for-each (lambda (status)
		    (set! tot (+ tot (hash-table-ref counts status)))
		    (print "<tr><td><font color=\"" (common:get-color-from-status status) "\">" status
			   "</font></td><td>" (hash-table-ref counts status) "</td></tr>"))
		  (hash-table-keys counts))
	(print "<tr><td>Total</td><td>" tot "</td></tr></table>")
	(print "</td></td></tr></table>")
	
	(print "<table cellspacing=\"0\" border=\"1\">" 
	       "<tr><td>Item</td><td>State</td><td>Status</td><td>Comment</td>"
	       outtxt "</table></body></html>")
	;; (release-dot-lock outputfilename)
	))))

;; CHECK - WAS THIS ADDED OR REMOVED? MANUAL MERGE WITH API STUFF!!!
;;
;; get a pretty table to summarize steps
;;
;; (define (dcommon:process-steps-table steps);; db test-id #!key (work-area #f))
(define (tests:process-steps-table steps);; db test-id #!key (work-area #f))
;;  (let ((steps   (db:get-steps-for-test db test-id work-area: work-area)))
    ;; organise the steps for better readability
    (let ((res (make-hash-table)))
      (for-each 
       (lambda (step)
	 (debug:print 6 "step=" step)
	 (let ((record (hash-table-ref/default 
			res 
			(tdb:step-get-stepname step) 
			;;        stepname                start end status Duration  Logfile 
			(vector (tdb:step-get-stepname step) ""   "" ""     ""        ""))))
	   (debug:print 6 "record(before) = " record 
			"\nid:       " (tdb:step-get-id step)
			"\nstepname: " (tdb:step-get-stepname step)
			"\nstate:    " (tdb:step-get-state step)
			"\nstatus:   " (tdb:step-get-status step)
			"\ntime:     " (tdb:step-get-event_time step))
	   (case (string->symbol (tdb:step-get-state step))
	     ((start)(vector-set! record 1 (tdb:step-get-event_time step))
	      (vector-set! record 3 (if (equal? (vector-ref record 3) "")
					(tdb:step-get-status step)))
	      (if (> (string-length (tdb:step-get-logfile step))
		     0)
		  (vector-set! record 5 (tdb:step-get-logfile step))))
	     ((end)  
	      (vector-set! record 2 (any->number (tdb:step-get-event_time step)))
	      (vector-set! record 3 (tdb:step-get-status step))
	      (vector-set! record 4 (let ((startt (any->number (vector-ref record 1)))
					  (endt   (any->number (vector-ref record 2))))
				      (debug:print 4 "record[1]=" (vector-ref record 1) 
						   ", startt=" startt ", endt=" endt
						   ", get-status: " (tdb:step-get-status step))
				      (if (and (number? startt)(number? endt))
					  (seconds->hr-min-sec (- endt startt)) "-1")))
	      (if (> (string-length (tdb:step-get-logfile step))
		     0)
		  (vector-set! record 5 (tdb:step-get-logfile step))))
	     (else
	      (vector-set! record 2 (tdb:step-get-state step))
	      (vector-set! record 3 (tdb:step-get-status step))
	      (vector-set! record 4 (tdb:step-get-event_time step))))
	   (hash-table-set! res (tdb:step-get-stepname step) record)
	   (debug:print 6 "record(after)  = " record 
			"\nid:       " (tdb:step-get-id step)
			"\nstepname: " (tdb:step-get-stepname step)
			"\nstate:    " (tdb:step-get-state step)
			"\nstatus:   " (tdb:step-get-status step)
			"\ntime:     " (tdb:step-get-event_time step))))
       ;; (else   (vector-set! record 1 (tdb:step-get-event_time step)))
       (sort steps (lambda (a b)
		     (cond
		      ((<   (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t)
		      ((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b)) 
		       (<   (tdb:step-get-id a)        (tdb:step-get-id b)))
		      (else #f)))))
      res))


;; temporarily passing in dbstruct to support direct access (i.e. bypassing servers)
;;
(define (tests:get-compressed-steps dbstruct run-id test-id)
  (let* ((steps-data  (if dbstruct 
			  (db:get-steps-for-test dbstruct run-id test-id)
			  (rmt:get-steps-for-test run-id test-id))) 
	 (comprsteps  (tests:process-steps-table steps-data))) ;; (open-run-close db:get-steps-table #f test-id work-area: work-area)))
    (map (lambda (x)
	   ;; take advantage of the \n on time->string
	   (vector
	    (vector-ref x 0)
	    (let ((s (vector-ref x 1)))
	      (if (number? s)(seconds->time-string s) s))
	    (let ((s (vector-ref x 2)))
	      (if (number? s)(seconds->time-string s) s))
	    (vector-ref x 3)    ;; status
	    (vector-ref x 4)
	    (vector-ref x 5)))  ;; time delta
	 (sort (hash-table-values comprsteps)
	       (lambda (a b)
		 (let ((time-a (vector-ref a 1))
		       (time-b (vector-ref b 1)))
		   (if (and (number? time-a)(number? time-b))
		       (if (< time-a time-b)
			   #t
			   (if (eq? time-a time-b)
			       (string<? (conc (vector-ref a 2))
					 (conc (vector-ref b 2)))
			       #f))
		       (string<? (conc time-a)(conc time-b)))))))))


;; summarize test
(define (tests:summarize-test run-id test-id)
  (let* ((test-dat  (rmt:get-test-info-by-id run-id test-id))
	 (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 (conc (db:test-get-rundir test-dat) "/test-summary.html")))
	 (status    (db:test-get-status   test-dat))
	 (color     (common:get-color-from-status status))
	 (logf      (db:test-get-final_logf test-dat))
	 (steps-dat (tests:get-compressed-steps #f run-id test-id)))
    ;; (dcommon:get-compressed-steps #f 1 30045)
    ;; (#("wasting_time" "23:36:13" "23:36:21" "0" "8.0s" "wasting_time.log"))

    (s:output-new
     oup
     (s:html
      (s:title "Summary for " full-name)
      (s:body 
       (s:h2 "Summary for " full-name)
       (s:table 'cellspacing "0" 'border "1"
	(s:tr (s:td "run id")   (s:td (db:test-get-run_id   test-dat))
	      (s:td "test id")  (s:td (db:test-get-id       test-dat)))
	(s:tr (s:td "testname") (s:td test-name)
	      (s:td "itempath") (s:td item-path))
	(s:tr (s:td "state")    (s:td (db:test-get-state    test-dat))
	      (s:td "status")   (s:td (s:a 'href logf (s:font 'color color status))))
	(s:tr (s:td "TestDate") (s:td (seconds->work-week/day-time 
				       (db:test-get-event_time test-dat)))
	      (s:td "Duration") (s:td (seconds->hr-min-sec (db:test-get-run_duration test-dat)))))
       (s:h3 "Log files")
       (s:table
	'cellspacing "0" 'border "1"
	(s:tr (s:td "Final log")(s:td (s:a 'href logf logf))))
       (s:table
	'cellspacing "0" 'border "1"
	(s:tr (s:td "Step Name")(s:td "Start")(s:td "End")(s:td "Status")(s:td "Duration")(s:td "Log File"))
	(map (lambda (step-dat)
	       (s:tr (s:td (tdb:steps-table-get-stepname step-dat))
		     (s:td (tdb:steps-table-get-start    step-dat))
		     (s:td (tdb:steps-table-get-end      step-dat))
		     (s:td (tdb:steps-table-get-status   step-dat))
		     (s:td (tdb:steps-table-get-runtime  step-dat))
		     (s:td (let ((step-log (tdb:steps-table-get-log-file step-dat)))
			     (s:a 'href step-log step-log)))))
	     steps-dat))
	)))
    (close-output-port oup)))
	  
	  
;; MUST BE CALLED local!
;;
(define (tests:test-get-paths-matching keynames target fnamepatt #!key (res '()))
  ;; BUG: Move the values derived from args to parameters and push to megatest.scm
  (let* ((testpatt   (if (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%"))
	 (statepatt  (if (args:get-arg ":state")   (args:get-arg ":state")    "%"))
	 (statuspatt (if (args:get-arg ":status")  (args:get-arg ":status")   "%"))
	 (runname    (if (args:get-arg ":runname") (args:get-arg ":runname")  "%"))
	 (paths-from-db (rmt:test-get-paths-matching-keynames-target-new keynames target res
					testpatt
					statepatt
					statuspatt
					runname)))
    (if fnamepatt
	(apply append 
	       (map (lambda (p)
		      (if (directory-exists? p)
			  (glob (conc p "/" fnamepatt))
			  '()))
		    paths-from-db))
	paths-from-db)))

			      
;;======================================================================
;; Gather data from test/task specifications
;;======================================================================

;; (define (tests:get-valid-tests testsdir test-patts) ;;  #!key (test-names '()))
;;   (let ((tests (glob (conc testsdir "/tests/*")))) ;; " (string-translate patt "%" "*")))))
;;     (set! tests (filter (lambda (test)(file-exists? (conc test "/testconfig"))) tests))
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
     (lambda (testkeyname)
       (let* ((test-record (hash-table-ref testrecordshash testkeyname))
	      (test-name   (tests:testqueue-get-testname  test-record))
	      (itemdat     (tests:testqueue-get-itemdat   test-record))
	      (item-path   (tests:testqueue-get-item_path test-record))
	      (waitons     (tests:testqueue-get-waitons   test-record))
	      (keep-test   #t)
	      (test-id     (cdb:remote-run db:get-test-id-cached #f run-id test-name item-path))
	      (tdat        (cdb:remote-run db:get-testinfo-state-status #f test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id)))
	 (if tdat
	     (begin
	       ;; Look at the test state and status
	       (if (or (and (member (db:test-get-status tdat) 
				    '("PASS" "WARN" "WAIVED" "CHECK" "SKIP"))
			    (equal? (db:test-get-state tdat) "COMPLETED"))
		       (member (db:test-get-state tdat)
				    '("INCOMPLETE" "KILLED")))
		   (set! keep-test #f))

	       ;; examine waitons for any fails. If it is FAIL or INCOMPLETE then eliminate this test
	       ;; from the runnable list
	       (if keep-test
		   (for-each (lambda (waiton)
			       ;; for now we are waiting only on the parent test
			       (let* ((parent-test-id (cdb:remote-run db:get-test-id-cached #f run-id waiton ""))
				      (wtdat          (cdb:remote-run db:get-testinfo-state-status #f test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id)))
				 (if (or (and (equal? (db:test-get-state wtdat) "COMPLETED")
					      (member (db:test-get-status wtdat) '("FAIL")))
					 (member (db:test-get-status wtdat)  '("KILLED"))
					 (member (db:test-get-state wtdat)   '("INCOMPETE")))
				 ;; (if (or (member (db:test-get-status wtdat)
				 ;;        	 '("FAIL" "KILLED"))
				 ;;         (member (db:test-get-state wtdat)







|
|















|
|







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
     (lambda (testkeyname)
       (let* ((test-record (hash-table-ref testrecordshash testkeyname))
	      (test-name   (tests:testqueue-get-testname  test-record))
	      (itemdat     (tests:testqueue-get-itemdat   test-record))
	      (item-path   (tests:testqueue-get-item_path test-record))
	      (waitons     (tests:testqueue-get-waitons   test-record))
	      (keep-test   #t)
	      (test-id     (rmt:get-test-id run-id test-name item-path))
	      (tdat        (rmt:get-testinfo-state-status run-id test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id)))
	 (if tdat
	     (begin
	       ;; Look at the test state and status
	       (if (or (and (member (db:test-get-status tdat) 
				    '("PASS" "WARN" "WAIVED" "CHECK" "SKIP"))
			    (equal? (db:test-get-state tdat) "COMPLETED"))
		       (member (db:test-get-state tdat)
				    '("INCOMPLETE" "KILLED")))
		   (set! keep-test #f))

	       ;; examine waitons for any fails. If it is FAIL or INCOMPLETE then eliminate this test
	       ;; from the runnable list
	       (if keep-test
		   (for-each (lambda (waiton)
			       ;; for now we are waiting only on the parent test
			       (let* ((parent-test-id (rmt:get-test-id run-id waiton ""))
				      (wtdat          (rmt:get-testinfo-state-status run-id test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id)))
				 (if (or (and (equal? (db:test-get-state wtdat) "COMPLETED")
					      (member (db:test-get-status wtdat) '("FAIL")))
					 (member (db:test-get-status wtdat)  '("KILLED"))
					 (member (db:test-get-state wtdat)   '("INCOMPETE")))
				 ;; (if (or (member (db:test-get-status wtdat)
				 ;;        	 '("FAIL" "KILLED"))
				 ;;         (member (db:test-get-state wtdat)
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

;;======================================================================
;; test steps
;;======================================================================

;; teststep-set-status! used to be here

(define (test-get-kill-request test-id) ;; run-id test-name itemdat)
  (let* ((testdat   (cdb:remote-run db:get-testinfo-state-status #f test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id))) ;; run-id test-name item-path)))
    (and testdat
	 (equal? (test:get-state testdat) "KILLREQ"))))

(define (test:tdb-get-rundat-count tdb)
  (if tdb
      (let ((res 0))
	(sqlite3:for-each-row
	 (lambda (count)
	   (set! res count))
	 tdb
	 "SELECT count(id) FROM test_rundat;")
	res))
  0)

(define (tests:update-central-meta-info test-id cpuload diskfree minutes uname hostname)
  ;; This is a good candidate for threading the requests to enable
  ;; transactionized write at the server
  (cdb:tests-update-cpuload-diskfree *runremote* test-id cpuload diskfree)
  (if minutes 
      (cdb:tests-update-run-duration *runremote* test-id minutes))
  (if (and uname hostname)
      (cdb:tests-update-uname-host *runremote* test-id uname hostname)))
  

(define (tests:set-full-meta-info db test-id run-id minutes work-area remtries)
  ;; DOES cdb:remote-run under the hood!

  (let ((remtries 10))
    (handle-exceptions
     exn
     (if (> remtries 0)
	 (begin
	   (set! remtries (- remtries 1))
	   (thread-sleep! 10)
	   (tests:set-full-meta-info db test-id run-id minutes work-area (- remtries 1)))
	 (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
	   (debug:print 0 "ERROR: tried for over a minute to update meta info and failed. Giving up")
	   (debug:print 0 "EXCEPTION: database probably overloaded or unreadable.")
	   (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
	   (print "exn=" (condition->list exn))
	   (debug:print 0 " status:  " ((condition-property-accessor 'sqlite3 'status) exn))
	   (print-call-chain)))
     (let* ((num-records 0) ;; (test:tdb-get-rundat-count tdb))
	    (cpuload  (get-cpu-load))
	    (diskfree (get-df (current-directory)))
	    (uname    (get-uname "-srvpio"))
	    (hostname (get-host-name)))
       (tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes)
       (tests:update-central-meta-info test-id cpuload diskfree minutes uname hostname)))))
    
(define (tests:set-partial-meta-info db test-id run-id minutes work-area remtries)
  ;; DOES cdb:remote-run under the hood!

  (let* ((cpuload  (get-cpu-load))
	 (diskfree (get-df (current-directory)))
	 (remtries 10))
    (handle-exceptions
     exn
     (if (> remtries 0)
	 (begin


	   (set! remtries (- remtries 1))
	   (thread-sleep! 10)
	   (tests:set-full-meta-info db test-id run-id minutes work-area (- remtries 1)))
	 (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
	   (debug:print 0 "ERROR: tried for over a minute to update meta info and failed. Giving up")
	   (debug:print 0 "EXCEPTION: database probably overloaded or unreadable.")
	   (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
	   (print "exn=" (condition->list exn))
	   (debug:print 0 " status:  " ((condition-property-accessor 'sqlite3 'status) exn))
	   (print-call-chain)))
     (tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes)
    ;; Update central with uname and hostname = #f
    ;; Is this one of the performance problems? This info should come from testdat-meta anyway
    ;; (tests:update-central-meta-info test-id cpuload diskfree minutes #f #f)
  )))
	 
(define (tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes)
  (let ((tdb         (db:open-test-db-by-test-id db test-id work-area: work-area)))
    (if (sqlite3:database? tdb)
	(begin
	  (sqlite3:execute tdb "INSERT INTO test_rundat (update_time,cpuload,diskfree,run_duration) VALUES (strftime('%s','now'),?,?,?);"
			   cpuload diskfree minutes)
	  (sqlite3:finalize! tdb))
	(debug:print 2 "Can't update testdat.db for test " test-id " read-only or non-existant"))))
    
(define (tests:testdat-get-testinfo db test-id work-area)
   (let ((tdb         (db:open-test-db-by-test-id db test-id work-area: work-area))
	 (res         '()))
     (if (sqlite3:database? tdb)
	 (begin
	   (sqlite3:for-each-row
	    (lambda (update-time cpuload diskfree run-duration)
	      (set! res (cons (vector update-time cpuload diskfree run-duration) res)))
	    tdb
	    "SELECT update_time,cpuload,diskfree,run_duration FROM test_rundat ORDER BY update_time ASC;")
	   (sqlite3:finalize! tdb)))
     res))

;;======================================================================
;; A R C H I V I N G
;;======================================================================

(define (test:archive db test-id)
  #f)

(define (test:archive-tests db keynames target)
  #f)








|
|














|
<
<
|

|

|

>

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

|
<
>







>
>









|

<
<
<


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










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

;;======================================================================
;; test steps
;;======================================================================

;; teststep-set-status! used to be here

(define (test-get-kill-request run-id test-id) ;; run-id test-name itemdat)
  (let* ((testdat   (rmt:get-test-info-by-id run-id test-id)))
    (and testdat
	 (equal? (test:get-state testdat) "KILLREQ"))))

(define (test:tdb-get-rundat-count tdb)
  (if tdb
      (let ((res 0))
	(sqlite3:for-each-row
	 (lambda (count)
	   (set! res count))
	 tdb
	 "SELECT count(id) FROM test_rundat;")
	res))
  0)

(define (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname)


  (rmt:general-call 'update-cpuload-diskfree run-id cpuload diskfree test-id)
  (if minutes 
      (rmt:general-call 'update-run-duration run-id minutes test-id))
  (if (and uname hostname)
      (rmt:general-call 'update-uname-host run-id uname hostname test-id)))
  
;; This one is for running with no db access (i.e. via rmt: internally)
(define (tests:set-full-meta-info db test-id run-id minutes work-area remtries)

;; (define (tests:set-full-meta-info test-id run-id minutes work-area)
;;  (let ((remtries 10))















  (let* ((cpuload  (get-cpu-load))
	 (diskfree (get-df (current-directory)))
	 (uname    (get-uname "-srvpio"))
	 (hostname (get-host-name)))

    (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname)))
    
;; (define (tests:set-partial-meta-info test-id run-id minutes work-area)

(define (tests:set-partial-meta-info test-id run-id minutes work-area remtries)
  (let* ((cpuload  (get-cpu-load))
	 (diskfree (get-df (current-directory)))
	 (remtries 10))
    (handle-exceptions
     exn
     (if (> remtries 0)
	 (begin
	   (print-call-chain (current-error-port))
	   (debug:print-info 0 "WARNING: failed to set meta info. Will try " remtries " more times")
	   (set! remtries (- remtries 1))
	   (thread-sleep! 10)
	   (tests:set-full-meta-info db test-id run-id minutes work-area (- remtries 1)))
	 (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
	   (debug:print 0 "ERROR: tried for over a minute to update meta info and failed. Giving up")
	   (debug:print 0 "EXCEPTION: database probably overloaded or unreadable.")
	   (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
	   (print "exn=" (condition->list exn))
	   (debug:print 0 " status:  " ((condition-property-accessor 'sqlite3 'status) exn))
	   (print-call-chain (current-error-port))))
     (tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes)



  )))
	 






















;;======================================================================
;; A R C H I V I N G
;;======================================================================

(define (test:archive db test-id)
  #f)

(define (test:archive-tests db keynames target)
  #f)

Modified tests/Makefile from [392c30bd69] to [58d615ee76].

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
#
# run some tests

BINPATH=$(shell readlink -m $(PWD)/../bin)
MEGATEST=$(BINPATH)/megatest
DASHBOARD=$(BINPATH)/dashboard
PATH := $(BINPATH):$(PATH)
RUNNAME := $(shell date +w%V.%u.%H.%M)
IPADDR := "-"
# Set SERVER to "-server -"
SERVER  = 
DEBUG   = 1
LOGGING = 


OS  = $(shell grep ID /etc/*-release|cut -d= -f2)
FS  = $(shell df -T .|tail -1|awk '{print $$2}')
VER = $(shell fsl info|grep checkout|awk '{print $$2}'|cut -c 1-5)

# The NEWTARGET causes some tests to fail. Do not use until this is fixed.
NEWTARGET  = "$(OS)/$(FS)/$(VER)"
TARGET     = "ubuntu/nfs/none"

all : test1 test2 test3 test4 test5 test6 test7 test8 test9




server :
	cd ..;make -j;make install
	cd fullrun;$(MEGATEST) -server - -debug 22

stopserver :
	cd ..;make -j && make install
	cd fullrun;$(MEGATEST) -stop-server 0

repl :
	cd ..;make -j && make install
	cd fullrun;$(MEGATEST) -repl

test0 : cleanprep
	cd simplerun ; $(MEGATEST) -server - -debug $(DEBUG)

test1 : cleanprep
	rm -f simplerun/megatest.db
	rm -rf simplelinks/ simpleruns/
	mkdir -p simplelinks simpleruns
	cd simplerun;cp ../../*_records.scm .;perl -pi.bak -e 's/define-inline/define/' *_records.scm
	cd simplerun;echo '(load "../tests.scm")' | $(MEGATEST) -repl -debug $(DEBUG)

test2 : fullprep
	cd fullrun;$(MEGATEST) -preclean -runtests ez_pass,runfirst/a/% -reqtarg ubuntu/nfs/none :runname $(RUNNAME) -debug $(DEBUG) $(LOGGING)
	cd fullrun;megatest -preclean -runtests % -target ubuntu/nfs/none :runname $(RUNNAME)_01 -testpatt %/,%/ai -debug $(DEBUG)
	cd fullrun;megatest -preclean -runtests %/,%/ai -target ubuntu/nfs/none :runname $(RUNAME)_02 -debug $(DEBUG)
	cd fullrun;megatest -preclean -runtests runfirst/%,%/ai -target ubuntu/nfs/none :runname $(RUNNAME)_02 -debug $(DEBUG)
	cd fullrun;megatest -runtests %/,%/winter -target ubuntu/nfs/none :runname $(RUNNAME)_03  -debug $(DEBUG)



|
|
|
|
|
|
|
|
|
|
>









|
>
>
>



|







|





<
<
<
<
<







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
#
# run some tests

BINPATH   = $(shell readlink -m $(PWD)/../bin)
MEGATEST  = $(BINPATH)/megatest
DASHBOARD = $(BINPATH)/dashboard
PATH     := $(BINPATH):$(PATH)
RUNNAME  := $(shell date +w%V.%u.%H.%M)
IPADDR   := "-"
RUNID    := 1
SERVER    = 
DEBUG     = 1
LOGGING   = 
ROWS      = 20

OS  = $(shell grep ID /etc/*-release|cut -d= -f2)
FS  = $(shell df -T .|tail -1|awk '{print $$2}')
VER = $(shell fsl info|grep checkout|awk '{print $$2}'|cut -c 1-5)

# The NEWTARGET causes some tests to fail. Do not use until this is fixed.
NEWTARGET  = "$(OS)/$(FS)/$(VER)"
TARGET     = "ubuntu/nfs/none"

all : unit test1 test2 test3 test4 test5 test6 test7 test8 test9

unit :
	./rununittest.sh basicserver $(DEBUG)

server :
	cd ..;make -j;make install
	cd fullrun;$(MEGATEST) -server - -debug $(DEBUG) -run-id $(RUNID)

stopserver :
	cd ..;make -j && make install
	cd fullrun;$(MEGATEST) -stop-server 0

repl :
	cd ..;make -j && make install
	cd fullrun;$(MEGATEST) -:b -repl

test0 : cleanprep
	cd simplerun ; $(MEGATEST) -server - -debug $(DEBUG)

test1 : cleanprep






test2 : fullprep
	cd fullrun;$(MEGATEST) -preclean -runtests ez_pass,runfirst/a/% -reqtarg ubuntu/nfs/none :runname $(RUNNAME) -debug $(DEBUG) $(LOGGING)
	cd fullrun;megatest -preclean -runtests % -target ubuntu/nfs/none :runname $(RUNNAME)_01 -testpatt %/,%/ai -debug $(DEBUG)
	cd fullrun;megatest -preclean -runtests %/,%/ai -target ubuntu/nfs/none :runname $(RUNAME)_02 -debug $(DEBUG)
	cd fullrun;megatest -preclean -runtests runfirst/%,%/ai -target ubuntu/nfs/none :runname $(RUNNAME)_02 -debug $(DEBUG)
	cd fullrun;megatest -runtests %/,%/winter -target ubuntu/nfs/none :runname $(RUNNAME)_03  -debug $(DEBUG)
68
69
70
71
72
73
74

75
76

77
78
79
80
81
82
83
84
85
86
87
88
	cd fullrun;time $(MEGATEST) -debug $(DEBUG) -run-wait -runtests % -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -m "This is a comment specific to a run" -v $(LOGGING)

test4a : cleanprep
	cd fullrun;time $(MEGATEST) -debug $(DEBUG) -preclean -runtests all_toplevel -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -m "This is a comment specific to a run" -v $(LOGGING)

# NOTE: Only one instance can be a server
test5 : cleanprep

	@echo "WARNING: No longer running fullprep, test converage may be lessened"
	cd fullrun;sleep 0;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_aa -debug $(DEBUG) $(LOGGING) > aa.log 2> aa.log &

	cd fullrun;sleep 0;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_ab -debug $(DEBUG) $(LOGGING) > ab.log 2> ab.log &
	cd fullrun;sleep 5;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_ac -debug $(DEBUG) $(LOGGING) > ac.log 2> ac.log &
	cd fullrun;sleep 8;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_ad -debug $(DEBUG) $(LOGGING) > ad.log 2> ad.log &	
#	cd fullrun;sleep 0;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_ae -debug $(DEBUG) $(LOGGING) > ae.log 2> ae.log &	
#	cd fullrun;sleep 0;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_af -debug $(DEBUG) $(LOGGING) > af.log 2> af.log &	a

# MUST ADD THIS BACK IN ASAP!!!!
	# cd fullrun;sleep 10;$(MEGATEST) -run-wait  -target $(TARGET) :runname % -testpatt % :state RUNNING,LAUNCHED,NOT_STARTED,REMOTEHOSTSTART;echo ALL DONE

test6: fullprep
	cd fullrun;$(MEGATEST) -preclean -runtests runfirst -testpatt %/1 -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_itempatt -v
	cd fullrun;$(MEGATEST) -preclean -runtests runfirst -testpatt %blahha% -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_itempatt -debug 10







>


>
|
|
|
|
<







67
68
69
70
71
72
73
74
75
76
77
78
79
80
81

82
83
84
85
86
87
88
	cd fullrun;time $(MEGATEST) -debug $(DEBUG) -run-wait -runtests % -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -m "This is a comment specific to a run" -v $(LOGGING)

test4a : cleanprep
	cd fullrun;time $(MEGATEST) -debug $(DEBUG) -preclean -runtests all_toplevel -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -m "This is a comment specific to a run" -v $(LOGGING)

# NOTE: Only one instance can be a server
test5 : cleanprep
	rm -f fullrun/a*.log fullrun/logs/*
	@echo "WARNING: No longer running fullprep, test converage may be lessened"
	cd fullrun;sleep 0;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_aa -debug $(DEBUG) $(LOGGING) > aa.log 2> aa.log &
	cd fullrun;sleep 0;$(MEGATEST) -preclean -runtests % -target ubuntu/nfs/sleep1 :runname $(RUNNAME)_ae -debug $(DEBUG) $(LOGGING) > ae.log 2> ae.log &	
	cd fullrun;sleep 0;$(MEGATEST) -preclean -runtests % -target ubuntu/nfs/sleep10 :runname $(RUNNAME)_ab -debug $(DEBUG) $(LOGGING) > ab.log 2> ab.log &
	cd fullrun;sleep 5;$(MEGATEST) -preclean -runtests % -target ubuntu/nfs/sleep60 :runname $(RUNNAME)_ac -debug $(DEBUG) $(LOGGING) > ac.log 2> ac.log &
	cd fullrun;sleep 8;$(MEGATEST) -preclean -runtests % -target ubuntu/nfs/sleep240 :runname $(RUNNAME)_ad -debug $(DEBUG) $(LOGGING) > ad.log 2> ad.log &	
#	cd fullrun;sleep 0;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_af -debug $(DEBUG) $(LOGGING) > af.log 2> af.log &


# MUST ADD THIS BACK IN ASAP!!!!
	# cd fullrun;sleep 10;$(MEGATEST) -run-wait  -target $(TARGET) :runname % -testpatt % :state RUNNING,LAUNCHED,NOT_STARTED,REMOTEHOSTSTART;echo ALL DONE

test6: fullprep
	cd fullrun;$(MEGATEST) -preclean -runtests runfirst -testpatt %/1 -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_itempatt -v
	cd fullrun;$(MEGATEST) -preclean -runtests runfirst -testpatt %blahha% -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_itempatt -debug 10
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
# Some simple checks for bootstrapping and run loop logic 

test9 : minsetup test9a test9b test9c test9d test9e

test9a :
	@echo Run super-simple mintest e, no waitons.
	cd mintest;$(DASHBOARD)&
	cd mintest;megatest -preclean -runtests e -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG)

test9b :
	@echo Run simple mintest d with one waiton c
	cd mintest;megatest -preclean -runtests d -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG)

test9c :
	@echo Run mintest a with full waiton chain a -> b -> c -> d -> e
	cd mintest;megatest -preclean -runtests a -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG)

test9d :
	@echo Run an itemized test with no items
	cd mintest;megatest -preclean -runtests g -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG)

test9e :
	@echo Run mintest a1 with full waiton chain with d1fail: a1 -> b1 -> c1 -> d1fail -> e1
	cd mintest;megatest -preclean -runtests a1 -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG)

test10 :
	@echo Run a bunch of different targets simultaneously
	(cd fullrun;$(MEGATEST) -server - ;sleep 2)&
	for targ in mint/btrfs/mintdir sunos/sshfs/loc; do \
	   (cd fullrun;$(MEGATEST) -preclean -runtests priority_10_waiton_1 -target $$targ :runname $(RUNNAME) &); done
	for sys in ubuntu suse redhat debian;do \
	  for fs in afs nfs zfs; do \
	     for dpath in none tmp; do \
	        (cd fullrun;$(MEGATEST) -preclean -runtests priority_10_waiton_1 -target $$sys/$$fs/$$dpath :runname $(RUNNAME) &);\
	     done;done;done

test11 :
	 cd fullrun;time (for a in 1 2 3 4 5 6 7 8 9 10  1 2 3 4 5 6 7 8 9 10  1 2 3 4 5 6 7 8 9 10  1 2 3 4 5 6 7 8 9 10 ;do   (megatest -test-paths -target %/%/% > /dev/null ) & done; wait; )

minsetup : 
	cd ..;make -j && make install
	mkdir -p mintest/runs mintest/links
	cd mintest;megatest -stop-server 0
	cd mintest;megatest -server - -debug $(DEBUG) > server.log 2> server.log & 
	sleep 3
	cd mintest;dashboard -rows 18 &

cleanprep : ../*.scm Makefile */*.config
	mkdir -p fullrun/tmp/mt_runs fullrun/tmp/mt_links
	cd ..;make -j;make install
	rm -f */logging.db
	touch cleanprep

fullprep : cleanprep
	cd fullrun;$(MEGATEST) -remove-runs :runname $(RUNNAME)% -target %/%/% -testpatt %/%
	cd fullrun;$(BINPATH)/dashboard -rows 15 &

dashboard : cleanprep
	cd fullrun && $(BINPATH)/dashboard -transport fs -rows 20 &

dashboard-http : cleanprep
	cd fullrun && $(BINPATH)/dashboard -transport http -rows 20 &

remove :
	cd fullrun;$(MEGATEST) -remove-runs :runname $(RUN)  -testpatt % -itempatt % :sysname % :fsname % :datapath %

clean  : 
	rm cleanprep

kill :
	killall -v mtest main.sh dboard || true
	rm -f */megatest.db */logging.db */monitor.db || true
	killall -v mtest dboard || true

hardkill : kill
	sleep 5;killall -v mtest main.sh dboard -9

listservers :
	cd fullrun;$(MEGATEST) -list-servers

runforever :
	while(ls); do runname=`date +%F-%R:%S`;(cd fullrun;$(MEGATEST) -runall -target ubuntu/nfs/none :runname $$runname;/home/matt/data/megatest/megatest -runall -target ubuntu/nfs/none :runname $$runname;/home/matt/data/megatest/megatest -runall -target ubuntu/nfs/none :runname $$runname);done







|



|



|



|



|


















|
|

|


|









|

|
|









|



|






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
# Some simple checks for bootstrapping and run loop logic 

test9 : minsetup test9a test9b test9c test9d test9e

test9a :
	@echo Run super-simple mintest e, no waitons.
	cd mintest;$(DASHBOARD)&
	cd mintest;$(MEGATEST) -preclean -runtests e -target $(VER) -runname $(shell date +%H.%M.%S) -debug $(DEBUG)

test9b :
	@echo Run simple mintest d with one waiton c
	cd mintest;$(MEGATEST) -preclean -runtests d -target $(VER) -runname `date +%H.%M.%S` -debug $(DEBUG)

test9c :
	@echo Run mintest a with full waiton chain a -> b -> c -> d -> e
	cd mintest;$(MEGATEST) -preclean -runtests a -target $(VER) -runname `date +%H.%M.%S` -debug $(DEBUG)

test9d :
	@echo Run an itemized test with no items
	cd mintest;$(MEGATEST) -preclean -runtests g -target $(VER) -runname `date +%H.%M.%S` -debug $(DEBUG)

test9e :
	@echo Run mintest a1 with full waiton chain with d1fail: a1 -> b1 -> c1 -> d1fail -> e1
	cd mintest;$(MEGATEST) -preclean -runtests a1 -target $(VER) -runname `date +%H.%M.%S` -debug $(DEBUG)

test10 :
	@echo Run a bunch of different targets simultaneously
	(cd fullrun;$(MEGATEST) -server - ;sleep 2)&
	for targ in mint/btrfs/mintdir sunos/sshfs/loc; do \
	   (cd fullrun;$(MEGATEST) -preclean -runtests priority_10_waiton_1 -target $$targ :runname $(RUNNAME) &); done
	for sys in ubuntu suse redhat debian;do \
	  for fs in afs nfs zfs; do \
	     for dpath in none tmp; do \
	        (cd fullrun;$(MEGATEST) -preclean -runtests priority_10_waiton_1 -target $$sys/$$fs/$$dpath :runname $(RUNNAME) &);\
	     done;done;done

test11 :
	 cd fullrun;time (for a in 1 2 3 4 5 6 7 8 9 10  1 2 3 4 5 6 7 8 9 10  1 2 3 4 5 6 7 8 9 10  1 2 3 4 5 6 7 8 9 10 ;do   (megatest -test-paths -target %/%/% > /dev/null ) & done; wait; )

minsetup : 
	cd ..;make -j && make install
	mkdir -p mintest/runs mintest/links
	cd mintest;$(MEGATEST) -stop-server 0
	cd mintest;$(MEGATEST) -server - -debug $(DEBUG) > server.log 2> server.log & 
	sleep 3
	cd mintest;$(DASHBOARD) -rows 18 &

cleanprep : ../*.scm Makefile */*.config
	mkdir -p fullrun/tmp/mt_runs fullrun/tmp/mt_links /tmp/$(USER)/adisk1
	cd ..;make -j;make install
	rm -f */logging.db
	touch cleanprep

fullprep : cleanprep
	cd fullrun;$(MEGATEST) -remove-runs :runname $(RUNNAME)% -target %/%/% -testpatt %/%
	cd fullrun;$(BINPATH)/dashboard -rows 15 &

dashboard : cleanprep
	cd fullrun && $(BINPATH)/dashboard -rows $(ROWS) &

newdashboard : cleanprep
	cd fullrun && $(BINPATH)/newdashboard &

remove :
	cd fullrun;$(MEGATEST) -remove-runs :runname $(RUN)  -testpatt % -itempatt % :sysname % :fsname % :datapath %

clean  : 
	rm cleanprep

kill :
	killall -v mtest main.sh dboard || true
	rm -rf /tmp/.$(USER)-portlogger.db *run/db/* */megatest.db */logging.db */monitor.db fullrun/tmp/mt_*/* fullrun/tmp/mt_*/.db* fullrun/logs/*.log fullrun/*.log || true
	killall -v mtest dboard || true

hardkill : kill
	sleep 2;killall -v mtest main.sh dboard -9

listservers :
	cd fullrun;$(MEGATEST) -list-servers

runforever :
	while(ls); do runname=`date +%F-%R:%S`;(cd fullrun;$(MEGATEST) -runall -target ubuntu/nfs/none :runname $$runname;/home/matt/data/megatest/megatest -runall -target ubuntu/nfs/none :runname $$runname;/home/matt/data/megatest/megatest -runall -target ubuntu/nfs/none :runname $$runname);done

Modified tests/fdktestqa/fdk.config from [0cdf621a94] to [bb2780b886].

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16


















[fields]
SYSTEM TEXT
RELEASE TEXT

[env-override]
[setup]
# Adjust max_concurrent_jobs to limit how much you load your machines
# max_concurrent_jobs 150
max_concurrent_jobs 150

# This is your link path, you can move it but it is generally better to keep it stable
linktree #{shell readlink -f #{getenv PWD}/../simplelinks}

[include testqa/configs/megatest.abc.config]

timeout 0.025






















<



|


|



|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
[fields]
SYSTEM TEXT
RELEASE TEXT


[setup]
# Adjust max_concurrent_jobs to limit how much you load your machines
# max_concurrent_jobs 150
max_concurrent_jobs 1000

# This is your link path, you can move it but it is generally better to keep it stable
linktree #{shell readlink -f #{getenv MT_RUN_AREA_HOME}/../simplelinks}

[include testqa/configs/megatest.abc.config]

# timeout 0.025

[jobtools]
maxload 4
launcher nbfake

[server]
# timeout 0.01
# homehost xena
# homehost 143.182.225.38

# force server
server-query-threshold 0


[jobtools]
# launcher nbq -P ch_vp -C SLES11_EM64T_4G -Q /ciaf/fdk
# launcher nbfake
# maxload 4

Modified tests/fdktestqa/testqa/Makefile from [6c9750395d] to [d3de829000].

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
BINDIR    = $(PWD)/../../../bin
PATH     := $(BINDIR):$(PATH)
MEGATEST  = $(BINDIR)/megatest
DASHBOARD = $(BINDIR)/dashboard

RUNNAME   = a


all :
	$(MEGATEST) -remove-runs -target a/b :runname c -testpatt %/%
	$(MEGATEST) -runtests % -target a/b :runname c

bigbig :
	$(MEGATEST) -server - -daemonize ; sleep 3
	for tn in a b c d;do \
	   ($(MEGATEST) -runtests % -target a/b :runname $tn & ) ; \
	done

bigrun :
	$(MEGATEST) -runtests bigrun -target a/bigrun :runname $(RUNNAME)

bigrun2 :
	$(MEGATEST) -runtests bigrun2 -target a/bigrun2 :runname $(RUNNAME)

bigrun3 :
	$(MEGATEST) -runtests bigrun3 -target a/bigrun3 :runname $(RUNNAME)

dashboard : 
	$(DASHBOARD) -rows 20 &




compile :
	(cd ../../..;make -j && make install)

clean :
	rm -rf ../simple*/*/* megatest.db monitor.db





>








<





|


|







>
>
>




|

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
BINDIR    = $(PWD)/../../../bin
PATH     := $(BINDIR):$(PATH)
MEGATEST  = $(BINDIR)/megatest
DASHBOARD = $(BINDIR)/dashboard
NEWDASHBOARD = $(BINDIR)/newdashboard
RUNNAME   = a


all :
	$(MEGATEST) -remove-runs -target a/b :runname c -testpatt %/%
	$(MEGATEST) -runtests % -target a/b :runname c

bigbig :

	for tn in a b c d;do \
	   ($(MEGATEST) -runtests % -target a/b :runname $tn & ) ; \
	done

bigrun :
	$(MEGATEST) -runtests bigrun -target a/bigrun :runname a$(shell date +%V)

bigrun2 :
	$(MEGATEST) -runtests bigrun2 -target a/bigrun2 :runname a$(shell date +%V)

bigrun3 :
	$(MEGATEST) -runtests bigrun3 -target a/bigrun3 :runname $(RUNNAME)

dashboard : 
	$(DASHBOARD) -rows 20 &

newdashboard :
	$(NEWDASHBOARD) &

compile :
	(cd ../../..;make -j && make install)

clean :
	rm -rf ../simple*/*/* megatest.db db/* ../simple*/.db/* logs/* monitor.db

Modified tests/fdktestqa/testqa/configs/megatest.abc.config from [568ec796ea] to [a1a8a77b6d].

1
2
3
4
5
6
7
8
9
# Valid values for state and status for steps, NB// It is not recommended you use this
[validvalues]
state start end completed

# Job tools are more advanced ways to control how your jobs are launched
[jobtools]
useshell yes

[include megatest.def.config]






|


1
2
3
4
5
6
7
8
9
# Valid values for state and status for steps, NB// It is not recommended you use this
[validvalues]
state start end completed

# Job tools are more advanced ways to control how your jobs are launched
[jobtools]
# useshell yes

[include megatest.def.config]

Modified tests/fdktestqa/testqa/configs/megatest.def.config from [614ea68417] to [1df0e5e24a].

1
2
3
4
5
6
7
8
# You can override environment variables for all your tests here
[env-override]
EXAMPLE_VAR example value

# As you run more tests you may need to add additional disks, the names are arbitrary but must be unique
[disks]
disk0 #{scheme (nice-path "#{getenv PWD}/../simpleruns")}







|

1
2
3
4
5
6
7
8
# You can override environment variables for all your tests here
[env-override]
EXAMPLE_VAR example value

# As you run more tests you may need to add additional disks, the names are arbitrary but must be unique
[disks]
disk0 #{scheme (nice-path "#{getenv MT_RUN_AREA_HOME}/../simpleruns")}

Modified tests/fdktestqa/testqa/megatest.config from [50948d2125] to [0bd41b6735].

1
2
3
4
5
6



7
8
9
10
[setup]
testcopycmd cp --remove-destination -rlv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log
runqueue 20
# transport http
# launchwait no




[include ../fdk.config]

[server]
port 9080


<
<


>
>
>


<
<
1
2


3
4
5
6
7
8
9


[setup]
testcopycmd cp --remove-destination -rlv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log


# launchwait no

[jobtools]
launcher nbfake

[include ../fdk.config]



Modified tests/fdktestqa/testqa/tests/bigrun/step1.sh from [45d51b92e4] to [e700391a61].

1
2
3
4
5
6
7
8
9
10
#!/bin/bash
if [ $NUMBER -lt 10 ];then 
   sleep 2
   sleep `echo 4 * $NUMBER | bc`
else
   sleep 130
fi

if [[ $RANDOM -lt 10000 ]];then
  exit 1


|







1
2
3
4
5
6
7
8
9
10
#!/bin/bash
if [ $NUMBER -lt 10 ];then 
   sleep 20
   sleep `echo 4 * $NUMBER | bc`
else
   sleep 130
fi

if [[ $RANDOM -lt 10000 ]];then
  exit 1

Deleted tests/fullrun/config/mt_include_1.config version [8efd108e44].

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
[setup]
# exectutable /path/to/megatest
max_concurrent_jobs 500

linktree #{getenv MT_RUN_AREA_HOME}/tmp/mt_links

[jobtools]
useshell yes
# ## launcher launches jobs, the job is managed on the target host
## by megatest, comment out launcher to run local
# workhosts localhost hermes
# launcher exec nbfake
# launcher nbfake
# launcher echo
# launcher nbfind
# launcher nodanggood
# launcher loadrunner
launcher nbfake
# maxload *per cpu*
maxload 4
# default waitdelay is 60 seconds
waitdelay 15


## use "xterm -e csi -- " as a launcher to examine the launch environment.
## exit with (exit)
## get a shell with (system "bash")
# launcher xterm -e csi --
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































Deleted tests/fullrun/config/mt_include_2.config version [e4edd5bbcd].

1
2
[disks]
disk0 #{getenv MT_RUN_AREA_HOME}/tmp/mt_runs
<
<




Added tests/fullrun/configs/mt_include_1.config version [4c90d470ad].















































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
[setup]
# exectutable /path/to/megatest
max_concurrent_jobs 250

linktree #{getenv MT_RUN_AREA_HOME}/tmp/mt_links

[jobtools]
useshell yes
# ## launcher launches jobs, the job is managed on the target host
## by megatest, comment out launcher to run local
# workhosts localhost hermes
# launcher exec nbfake

launcher nbfake
# launcher echo

# launcher nbfind
# launcher nodanggood

## use "xterm -e csi -- " as a launcher to examine the launch environment.
## exit with (exit)
## get a shell with (system "bash")
# launcher xterm -e csi --

Added tests/fullrun/configs/mt_include_2.config version [e4edd5bbcd].





>
>
1
2
[disks]
disk0 #{getenv MT_RUN_AREA_HOME}/tmp/mt_runs

Modified tests/fullrun/megatest.config from [9cd6dad452] to [08287ce2b3].

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
[fields]
sysname TEXT
fsname TEXT
datapath TEXT

# refareas can be searched to find previous runs
# the path points to where megatest.db exists
[refareas]
area1 /tmp/oldarea/megatest

[include config/mt_include_1.config]

[dashboard]
pre-command  xterm -geometry 180x20 -e "
post-command |& tee results.log ;echo Press any key to continue;bash -c 'read -n 1 -s'" &
testsort -event_time

[misc]
home #{shell readlink -f $MT_RUN_AREA_HOME}
parent #{shell readlink -f $MT_RUN_AREA_HOME/..}

[tests-paths]
1 #{get misc parent}/simplerun/tests

[setup]
# Set launchwait to no to use the more agressive code that does not wait for the launch to complete before proceeding
# this may save a few milliseconds on launching tests
# launchwait no
waivercommentpatt ^WW\d+ [a-z].*
incomplete-timeout 1

# yes, anything else is no
run-wait yes


# Use http instead of direct filesystem access
# transport http
transport fs

# If set to "default" the old code is used. Otherwise defaults to 200 or uses
# numeric value given.
#
runqueue 20

# Default runtimelim 1d 1h 1m 10s










|




















|
|

|
<
<
|







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
[fields]
sysname TEXT
fsname TEXT
datapath TEXT

# refareas can be searched to find previous runs
# the path points to where megatest.db exists
[refareas]
area1 /tmp/oldarea/megatest

[include ./configs/mt_include_1.config]

[dashboard]
pre-command  xterm -geometry 180x20 -e "
post-command |& tee results.log ;echo Press any key to continue;bash -c 'read -n 1 -s'" &
testsort -event_time

[misc]
home #{shell readlink -f $MT_RUN_AREA_HOME}
parent #{shell readlink -f $MT_RUN_AREA_HOME/..}

[tests-paths]
1 #{get misc parent}/simplerun/tests

[setup]
# Set launchwait to no to use the more agressive code that does not wait for the launch to complete before proceeding
# this may save a few milliseconds on launching tests
# launchwait no
waivercommentpatt ^WW\d+ [a-z].*
incomplete-timeout 1

# set the dbdir, default is linktree
dbdir #{getenv MT_RUN_AREA_HOME}/db/

# wait for runs to completely complete. yes, anything else is no


run-wait yes

# If set to "default" the old code is used. Otherwise defaults to 200 or uses
# numeric value given.
#
runqueue 20

# Default runtimelim 1d 1h 1m 10s
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
testcopycmd cp --remove-destination -rsv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log

# or for hard links

# testcopycmd cp --remove-destination -rlv TEST_SRC_PATH/. TEST_TARG_PATH/.

# FULL or 2, NORMAL or 1, OFF or 0
synchronous OFF
# Throttle roughly scales the db access milliseconds to seconds delay
throttle 0.2
# Max retries allows megatest to re-check that a tests status has changed
# as tests can have transient FAIL status occasionally
maxretries 20

# Setup continued.
[setup]

# override the logview command
#
logviewer (%MTCMD%) 2> /dev/null > /dev/null

# override the html viewer launch command
#
# htmlviewercmd firefox -new-window 
htmlviewercmd konqueror







[validvalues]
state start end 0 1 - 2
status pass fail n/a 0 1 running - 2

# These are set before all tests, override them 
# in the testconfig [pre-launch-env-overrides] section
[env-override]




# MT_XTERM_CMD overrides the terminal command
# MT_XTERM_CMD xterm -bg lightgreen -fg black

SPECIAL_ENV_VARS overide them here - should be seen at launch and in the runs
TESTVAR [system echo $PWD]
DEADVAR [system ls]
VARWITHDOLLAR $HOME/.zshrc
WACKYVAR  #{system ls > /dev/null}
WACKYVAR2 #{get validvalues state}
WACKYVAR3 #{getenv USER}
WACKYVAR4 #{scheme (+ 5 6 7)}
WACKYVAR5 #{getenv sysname}/#{getenv fsname}/#{getenv datapath}
WACKYVAR6 #{scheme (args:get-arg "-target")}
PREDICTABLE the_ans
MRAH MT_RUN_AREA_HOME=#{getenv MT_RUN_AREA_HOME}
# The empty var should have a definition with null string
EMPTY_VAR

WRAPPEDVAR This var should have the work blah thrice: \
blah \
blah

# Set MAX_ALLOWED_LOAD for nbload. 150 percent is a good value.

MAX_ALLOWED_LOAD 200

# XTERM   [system xterm]
# RUNDEAD [system exit 56]

[server]








# If the server can't be started on this port it will try the next port until
# it succeeds
port 8080

# This server will keep running this number of hours after last access. 
# Three minutes is 0.05 hours
timeout 0.025













## disks are:
## name host:/path/to/area
## -or-
## name /path/to/area
[disks]
disk0 /foobarbazz


[include config/mt_include_2.config]

[include #{getenv USER}_testing.config]

[jobgroups]

# NOTE: job groups will falsely count the toplevel test as a job. If possible add N
#       to your jobgroups where N is the number of parallel runs you are likely to see
#       

sqlite3 5
blockz  5


































# Uncomment these to emulate a job queue with a long time (look in bin/sleeprunner for the time)
[jobtools]

launcher sleeprunner







|
















|
>
>
>
>
>
>








>
>
>
>




|

















<
<

<




>
>
>
>
>
>
>



|



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







>
>
|







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


>
|
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
testcopycmd cp --remove-destination -rsv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log

# or for hard links

# testcopycmd cp --remove-destination -rlv TEST_SRC_PATH/. TEST_TARG_PATH/.

# FULL or 2, NORMAL or 1, OFF or 0
synchronous 0
# Throttle roughly scales the db access milliseconds to seconds delay
throttle 0.2
# Max retries allows megatest to re-check that a tests status has changed
# as tests can have transient FAIL status occasionally
maxretries 20

# Setup continued.
[setup]

# override the logview command
#
logviewer (%MTCMD%) 2> /dev/null > /dev/null

# override the html viewer launch command
#
# htmlviewercmd firefox -new-window 
htmlviewercmd arora

# -runtests automatically deletes the records for tests with the listed states on starting up a run allowing them to re-run
#     (nb// this is in addition to NOT_STARTED which is automatically re-run)
#
allow-auto-rerun INCOMPLETE ZERO_ITEMS
# could add: STUCK STUCK/DEAD UNKNOWN KILLED KILLREQ PREQ_DISCARD

[validvalues]
state start end 0 1 - 2
status pass fail n/a 0 1 running - 2

# These are set before all tests, override them 
# in the testconfig [pre-launch-env-overrides] section
[env-override]

# This variable is honored by the loadrunner script. The value is in percent
MAX_ALLOWED_LOAD 200

# MT_XTERM_CMD overrides the terminal command
# MT_XTERM_CMD xterm -bg lightgreen -fg black

SPECIAL_ENV_VARS overide them here - should be seen at launch and in the runs
TESTVAR [system readlink -f .]
DEADVAR [system ls]
VARWITHDOLLAR $HOME/.zshrc
WACKYVAR  #{system ls > /dev/null}
WACKYVAR2 #{get validvalues state}
WACKYVAR3 #{getenv USER}
WACKYVAR4 #{scheme (+ 5 6 7)}
WACKYVAR5 #{getenv sysname}/#{getenv fsname}/#{getenv datapath}
WACKYVAR6 #{scheme (args:get-arg "-target")}
PREDICTABLE the_ans
MRAH MT_RUN_AREA_HOME=#{getenv MT_RUN_AREA_HOME}
# The empty var should have a definition with null string
EMPTY_VAR

WRAPPEDVAR This var should have the work blah thrice: \
blah \
blah



MAX_ALLOWED_LOAD 200

# XTERM   [system xterm]
# RUNDEAD [system exit 56]

[server]

# Use http instead of direct filesystem access
transport http
# transport fs
# transport nmsg

synchronous 0

# If the server can't be started on this port it will try the next port until
# it succeeds
port 9080

# This server will keep running this number of hours after last access. 
# Three minutes is 0.05 hours
# timeout 0.025
timeout 0.061

# Server is required - slower but more resistant to Sqlite issues.
required yes

# Start server when average query takes longer than this
# server-query-threshold 55500
server-query-threshold 100
timeout 0.01

# daemonize yes
# hostname #{scheme (get-host-name)}

## disks are:
## name host:/path/to/area
## -or-
## name /path/to/area
[disks]
disk0 /foobarbazz
disk1 not-a-disk

[include ./configs/mt_include_2.config]

[include #{getenv USER}_testing.config]

[jobgroups]

# NOTE: job groups will falsely count the toplevel test as a job. If possible add N
#       to your jobgroups where N is the number of parallel runs you are likely to see
#      

sqlite3 6
blockz  10
#       to your jobgroups where N is the number of parallel runs you are likely to see
#       

#======================================================================
# Machine flavors
#
#   These specify lists of hosts or scripts to use or call for various
#   flavors of task.
#
#======================================================================

[flavors]

plain hosts: xena, phoebe
strong command: NBFAKE_HOST=zeus nbfake
arm hosts: cubian

[archive]

# use machines of these flavor
useflavors plain
targsize 2G

# minimum space required on an archive disk before allowing archiving to start (MB)
minspace 10

[archive-disks]

# Archives will be organised under these paths like this:
#  <testsuite>/<creationdate>
# Within the archive the data is structured like this:
#  <target>/<runname>/<test>/
disk0 /tmp/#{getenv USER}/adisk1

# Uncomment these to emulate a job queue with a long time (look in bin/sleeprunner for the time)
[jobtools]
launcher #{scheme (if (equal? (getenv "datapath") "none") "nbfake" "sleeprunner")}

Modified tests/fullrun/runconfigs.config from [cdf025da8a] to [48da28b4cb].

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













[default]
SOMEVAR This should show up in SOMEVAR3

# target based getting of config file, look at afs.config and nfs.config
[include #{getenv fsname}.config]

[include #{getenv MT_RUN_AREA_HOME}/common_runconfigs.config]

# #{system echo 'VACKYVAR #{shell pwd}' > $MT_RUN_AREA_HOME/config/$USER.config}
[include ./config/#{getenv USER}.config]


WACKYVAR0 #{get ubuntu/nfs/none CURRENT}
WACKYVAR1 #{scheme (args:get-arg "-target")}

[default/ubuntu/nfs]
WACKYVAR2 #{runconfigs-get CURRENT}

[ubuntu/nfs/none]
WACKYVAR2 #{runconfigs-get CURRENT}
SOMEVAR2  This should show up in SOMEVAR4 if the target is ubuntu/nfs/none


[default]
SOMEVAR3 #{rget SOMEVAR}
SOMEVAR4 #{rget SOMEVAR2}
SOMEVAR5 #{runconfigs-get SOMEVAR2}

[this/a/test]
BLAHFOO 123





















|
|











>








>
>
>
>
>
>
>
>
>
>
>
>
>
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
[default]
SOMEVAR This should show up in SOMEVAR3

# target based getting of config file, look at afs.config and nfs.config
[include #{getenv fsname}.config]

[include #{getenv MT_RUN_AREA_HOME}/common_runconfigs.config]

# #{system echo 'VACKYVAR #{shell pwd}' > $MT_RUN_AREA_HOME/configs/$USER.config}
[include ./configs/#{getenv USER}.config]


WACKYVAR0 #{get ubuntu/nfs/none CURRENT}
WACKYVAR1 #{scheme (args:get-arg "-target")}

[default/ubuntu/nfs]
WACKYVAR2 #{runconfigs-get CURRENT}

[ubuntu/nfs/none]
WACKYVAR2 #{runconfigs-get CURRENT}
SOMEVAR2  This should show up in SOMEVAR4 if the target is ubuntu/nfs/none
VARWITHDOLLARSIGNS The$USER/signs/should/be/replaced/with/variable

[default]
SOMEVAR3 #{rget SOMEVAR}
SOMEVAR4 #{rget SOMEVAR2}
SOMEVAR5 #{runconfigs-get SOMEVAR2}

[this/a/test]
BLAHFOO 123

[ubuntu/nfs/sleep1]
SLEEPRUNNER 1

[ubuntu/nfs/sleep10]
SLEEPRUNNER 10

[ubuntu/nfs/sleep60]
SLEEPRUNNER 60

[ubuntu/nfs/sleep240]
SLEEPRUNNER 240

Added tests/fullrun/tests/dynamic_waiton/testconfig version [7a5b999ddf].











































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
[ezsteps]
listfiles ls

[requirements]
waiton #{scheme (string-intersperse \
                  (tests:filter-test-names \
                      (hash-table-keys (tests:get-all)) \
                      (or (args:get-arg "-runtests") \
                          (args:get-arg "-testpatt") "")) " ")}

[items]

[test_meta]
author matt
owner  bob
description This test runs a single ezstep which is expected to pass \
but there is an items definition with no items. This should evoke an \
error.

tags first,single
reviewed 09/10/2011, by Matt

Modified tests/fullrun/tests/exit_0/testconfig from [475b97c77b] to [5010ef5eb6].

1
2
3
4
5
6
7
8
9
10





[setup]
runscript main.sh

[test_meta]
author matt
owner  bob
description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS

tags first,single
reviewed 09/10/2011, by Matt















>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
[setup]
runscript main.sh

[test_meta]
author matt
owner  bob
description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS

tags first,single
reviewed 09/10/2011, by Matt

[triggers]
NOT_STARTED/ xterm -e bash -s -- 
RUNNING/ xterm -e bash -s -- 

Modified tests/fullrun/tests/priority_8/main.sh from [0536bc3eb1] to [12267f0508].

1
2
3
4

5

6

7

8
9
10
#!/bin/bash

# a bunch of steps in 2 second increments
for i in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17;do

  $MT_MEGATEST -step step$i :state start :status running -setlog results$i.html

  sleep 2

  $MT_MEGATEST -step step$i :state end :status 0

done

exit 0




>

>

>

>



1
2
3
4
5
6
7
8
9
10
11
12
13
14
#!/bin/bash

# a bunch of steps in 2 second increments
for i in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17;do
  echo "start step before $i: `date`"
  $MT_MEGATEST -step step$i :state start :status running -setlog results$i.html
  echo "start step after $i: `date`"
  sleep 2
  echo "end step before $i: `date`"
  $MT_MEGATEST -step step$i :state end :status 0
  echo "end step after $i: `date`"
done

exit 0

Modified tests/fullrun/tests/runfirst/main.sh from [2d77d9ebfd] to [f50c79a657].

28
29
30
31
32
33
34


35
36
loadstatus=$?

if [[ `basename $PWD` == "mustfail" ]];then
  $MT_MEGATEST -test-status :state COMPLETED :status FAIL
else
  $MT_MEGATEST -test-status :state COMPLETED :status $loadstatus -m "This is a test level comment" :value 10e6 :expected_value 1.1e6 :tol 100e3 :category nada :variable sillyvar :units mFarks :comment "This is the value/expected comment"
fi



# $MT_MEGATEST -test-status :state COMPLETED :status FAIL







>
>


28
29
30
31
32
33
34
35
36
37
38
loadstatus=$?

if [[ `basename $PWD` == "mustfail" ]];then
  $MT_MEGATEST -test-status :state COMPLETED :status FAIL
else
  $MT_MEGATEST -test-status :state COMPLETED :status $loadstatus -m "This is a test level comment" :value 10e6 :expected_value 1.1e6 :tol 100e3 :category nada :variable sillyvar :units mFarks :comment "This is the value/expected comment"
fi

env > envfile.txt

# $MT_MEGATEST -test-status :state COMPLETED :status FAIL

Added tests/fullrun/tests/test_mt_vars/altvarnotset.logpro version [3d9297acb6].



>
1
(expect:error in "LogFileBody" = 0 "a file that should never exist" #/what a dumb filename this is/)

Added tests/fullrun/tests/test_mt_vars/bogousnotset.logpro version [3d9297acb6].



>
1
(expect:error in "LogFileBody" = 0 "a file that should never exist" #/what a dumb filename this is/)

Added tests/fullrun/tests/test_mt_vars/currentisblah.logpro version [3d9297acb6].



>
1
(expect:error in "LogFileBody" = 0 "a file that should never exist" #/what a dumb filename this is/)

Modified tests/fullrun/tests/test_mt_vars/currentisblah.sh from [38498b5b33] to [e891695e2f].

1
2
3
#!/usr/bin/env bash

grep CURRENT megatest.sh | grep /tmp/nada


|
1
2
3
#!/usr/bin/env bash

grep -e '^export CURRENT' megatest.sh | grep /tmp/nada

Added tests/fullrun/tests/test_mt_vars/empty_var.logpro version [3d9297acb6].



>
1
(expect:error in "LogFileBody" = 0 "a file that should never exist" #/what a dumb filename this is/)

Added tests/fullrun/tests/test_mt_vars/eval_vars.sh version [786761600e].















>
>
>
>
>
>
>
1
2
3
4
5
6
7
#!/bin/bash

if env | grep VARWITHDOLLARSIGNS | grep USER;then
    exit 1 # fails!
else
    exit 0 # good!
fi

Added tests/fullrun/tests/test_mt_vars/lookithome.logpro version [3d9297acb6].



>
1
(expect:error in "LogFileBody" = 0 "a file that should never exist" #/what a dumb filename this is/)

Added tests/fullrun/tests/test_mt_vars/lookittmp.logpro version [3d9297acb6].



>
1
(expect:error in "LogFileBody" = 0 "a file that should never exist" #/what a dumb filename this is/)

Added tests/fullrun/tests/test_mt_vars/test-path.logpro version [3d9297acb6].



>
1
(expect:error in "LogFileBody" = 0 "a file that should never exist" #/what a dumb filename this is/)

Modified tests/fullrun/tests/test_mt_vars/testconfig from [a0c61adcaf] to [0d7c3216f9].

16
17
18
19
20
21
22



23
24
25
26
27
28
29
empty_var empty_var.sh

# VACKYVAR should be set to a path
vackyvar vackyvar.sh

# test-path and test-file
test-path test-path-file.sh




[requirements]
waiton runfirst
priority 0

[items]
NUMNUM [system cat $MT_RUN_AREA_HOME/tmp/$USER/$sysname/$fsname/$datapath/$MT_RUNNAME/$PREDICTABLE]







>
>
>







16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
empty_var empty_var.sh

# VACKYVAR should be set to a path
vackyvar vackyvar.sh

# test-path and test-file
test-path test-path-file.sh

# verify that vars with $ signs get expanded
varwithdollar eval_vars.sh

[requirements]
waiton runfirst
priority 0

[items]
NUMNUM [system cat $MT_RUN_AREA_HOME/tmp/$USER/$sysname/$fsname/$datapath/$MT_RUNNAME/$PREDICTABLE]

Added tests/fullrun/tests/test_mt_vars/vackyvar.logpro version [3d9297acb6].



>
1
(expect:error in "LogFileBody" = 0 "a file that should never exist" #/what a dumb filename this is/)

Added tests/fullrun/tests/test_mt_vars/varwithdollar.logpro version [3d9297acb6].



>
1
(expect:error in "LogFileBody" = 0 "a file that should never exist" #/what a dumb filename this is/)

Modified tests/mintest/megatest.config from [24752ab48d] to [74b434d2c6].

1
2
3
4
5
6

7
8
9
10
11
12
13
[fields]
X TEXT

[setup]
max_concurrent_jobs 50
linktree #{getenv PWD}/linktree


[server]
port 8090

[jobtools]
useshell yes
launcher nbfind





|
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
[fields]
X TEXT

[setup]
max_concurrent_jobs 50
linktree #{getenv MT_RUN_AREA_HOME}/linktree
transport http

[server]
port 8090

[jobtools]
useshell yes
launcher nbfind

Added tests/rununittest.sh version [d9bb67915f].















































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
#!/bin/bash

# Usage: rununittest.sh testname debuglevel
#

# Ensure all is made
(cd ..;make && make install)

# put megatest on path from correct location
mtbindir=$(readlink -f ../bin)

export PATH="${mtbindir}:$PATH"

# Clean setup
#
dbdir=$(cd simplerun;megatest -show-config -section setup -var linktree)/.db
rm -f simplerun/megatest.db simplerun/monitor.db simplerun/db/monitor.db $dbdir/*.db
rm -rf simplelinks/ simpleruns/ simplerun/db/ $dbdir
mkdir -p simplelinks simpleruns
(cd simplerun;cp ../../*_records.scm .;perl -pi.bak -e 's/define-inline/define/' *_records.scm)

# Run the test $1 is the unit test to run
cd simplerun;echo '(load "../tests.scm")' | ../../bin/megatest -repl -debug $2 $1

Modified tests/simplerun/megatest.config from [4fdc96f0ee] to [4850198caf].

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
[fields]
SYSTEM TEXT
RELEASE TEXT

[setup]
# Adjust max_concurrent_jobs to limit how much you load your machines
max_concurrent_jobs 50






# This is your link path, you can move it but it is generally better to keep it stable
linktree #{shell readlink -f #{getenv PWD}/../simplelinks}

# Valid values for state and status for steps, NB// It is not recommended you use this
[validvalues]
state start end completed

# Job tools are more advanced ways to control how your jobs are launched
[jobtools]
useshell yes
launcher nbfind

# You can override environment variables for all your tests here
[env-override]
EXAMPLE_VAR example value

# As you run more tests you may need to add additional disks, the names are arbitrary but must be unique
[disks]
disk0 #{shell readlink -f #{getenv PWD}/../simpleruns}








>
>
>
>
>

|
















|
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
[fields]
SYSTEM TEXT
RELEASE TEXT

[setup]
# Adjust max_concurrent_jobs to limit how much you load your machines
max_concurrent_jobs 50

# Uncomment this to make the in-mem db into a disk based db (slower but good for debug)
# be aware that some unit tests will fail with this due to persistent data
#
# tmpdb /tmp

# This is your link path, you can move it but it is generally better to keep it stable
linktree #{getenv MT_RUN_AREA_HOME}/../simplelinks

# Valid values for state and status for steps, NB// It is not recommended you use this
[validvalues]
state start end completed

# Job tools are more advanced ways to control how your jobs are launched
[jobtools]
useshell yes
launcher nbfind

# You can override environment variables for all your tests here
[env-override]
EXAMPLE_VAR example value

# As you run more tests you may need to add additional disks, the names are arbitrary but must be unique
[disks]
disk0 #{getenv MT_RUN_AREA_HOME}/../simpleruns

Added tests/simplerun/tests/test2/step1.sh version [67f9a133dc].







>
>
>
1
2
3
#!/usr/bin/env bash

# Run your step here

Deleted tests/simplerun/tests/test2/step1.sh.sh version [67f9a133dc].

1
2
3
#!/usr/bin/env bash

# Run your step here
<
<
<






Added tests/simplerun/tests/test2/step2.sh version [67f9a133dc].







>
>
>
1
2
3
#!/usr/bin/env bash

# Run your step here

Deleted tests/simplerun/tests/test2/step2.sh.sh version [67f9a133dc].

1
2
3
#!/usr/bin/env bash

# Run your step here
<
<
<






Added tests/stats.txt version [2a209bca81].



























































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
DB Stats:  a1236d6bf92ec5cb8955f490761b21b0d3eea9d3
========
Cmd                                     Count   TotTime   Avg       
get-count-tests-running-for-run-id         1035    237.0                0.23
get-count-tests-running-in-jobgroup         884    119.0                0.13
get-count-tests-running                     884    169.0                0.19
get-prereqs-not-met                         884    732.0                0.83
get-test-info-by-id                         673    122.0                0.18
get-keys                                    476      1.0                0.00
get-test-id                                 356     42.0                0.12
testmeta-get-record                         203     24.0                0.12
roll-up-pass-fail-counts                    159     39.0                0.25
register-test                               140     30.0                0.21
test-set-rundir-shortdir                    128     98.0                0.77
test-set-status-state                        94     45.0                0.48
find-and-mark-incomplete                     32      0.0                0.00
state-status-msg                             25      4.0                0.16
delete-tests-in-state                        12      4.0                0.33
get-tests-for-run-mindata                     8      0.0                0.00
get-all-run-ids                               5      2.0                0.40
get-run-info                                  4      0.0                0.00
register-run                                  4      5.0                1.25
set-tests-state-status                        4     15.0                3.75
get-tests-for-run                             4     15.0                3.75

# After converting first three functions above to sqlite3:first-result
DB Stats
========
Cmd                                     Count   TotTime   Avg       
get-count-tests-running-for-run-id         1138    179.0                0.16
get-count-tests-running-in-jobgroup         987     91.0                0.09
get-count-tests-running                     987    171.0                0.17
get-prereqs-not-met                         987    892.0                0.90
get-test-info-by-id                         672     95.0                0.14
get-keys                                    476      0.0                0.00
get-test-id                                 355     41.0                0.12
testmeta-get-record                         203     15.0                0.07
roll-up-pass-fail-counts                    159     30.0                0.19
register-test                               140     22.0                0.16
test-set-rundir-shortdir                    128    855.0                6.68
test-set-status-state                        94     20.0                0.21
find-and-mark-incomplete                     36      1.0                0.03
state-status-msg                             24      5.0                0.21
delete-tests-in-state                        12      2.0                0.17
get-tests-for-run-mindata                     9      0.0                0.00
get-all-run-ids                               5      1.0                0.20
register-run                                  4      1.0                0.25
get-tests-for-run                             4     11.0                2.75
get-run-info                                  4      0.0                0.00
set-tests-state-status                        4     17.0                4.25

DB Stats another run, converted one or two non-relevant functions to sqlite3:first-result
========
Cmd                                     Count   TotTime   Avg       
get-count-tests-running-for-run-id          987    157.0                0.16
get-count-tests-running-in-jobgroup         836     79.0                0.09
get-count-tests-running                     836    121.0                0.14
get-prereqs-not-met                         836    513.0                0.61
get-test-info-by-id                         673     85.0                0.13
get-keys                                    476      0.0                0.00
get-test-id                                 356     32.0                0.09
testmeta-get-record                         203     19.0                0.09
roll-up-pass-fail-counts                    159     27.0                0.17
register-test                               140     23.0                0.16
test-set-rundir-shortdir                    128     35.0                0.27
test-set-status-state                        94     20.0                0.21
find-and-mark-incomplete                     40      0.0                0.00
state-status-msg                             25      5.0                0.20
delete-tests-in-state                        12      1.0                0.08
get-tests-for-run-mindata                    10      0.0                0.00
get-all-run-ids                               5      0.0                0.00
set-tests-state-status                        4     15.0                3.75
register-run                                  4      2.0                0.50
get-run-info                                  4      1.0                0.25
get-tests-for-run                             4     12.0                3.00


Modified tests/tests.scm from [18c56c70d8] to [9d9074d93d].

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
(let ((files (glob "*_records.scm")))
  (for-each
   (lambda (file)
     (print "Loading " file)
     (load file))
   files))

(define *runremote* #f)

;;======================================================================
;; P R O C E S S E S
;;======================================================================

(test "cmd-run-with-stderr->list" '("No such file or directory")
      (let ((reslst (cmd-run-with-stderr->list "ls" "/tmp/ihadbetternotexist")))
	(string-search (regexp "No such file or directory")(car reslst))))

;;======================================================================
;; T E S T   M A T C H I N G
;;======================================================================

;; tests:glob-like-match
(test #f '("abc") (tests:glob-like-match "abc" "abc"))
(for-each 
 (lambda (patt str expected)
   (test (conc patt " " str "=>" expected) expected (tests:glob-like-match patt str)))
 (list "abc"    "~abc" "~abc" "a*c"  "a%c")
 (list "abc"    "abcd" "abc"  "ABC"  "ABC")
 (list '("abc")  #t      #f     #f '("ABC"))
 )

;; tests:match
(test #f #t (tests:match "abc/def" "abc" "def"))
(for-each 
 (lambda (patterns testname itempath expected)
   (test (conc patterns " " testname "/" itempath "=>" expected)
	 expected 
	 (tests:match patterns testname itempath)))
 (list "abc" "abc/%" "ab%/c%" "~abc/c%" "abc/~c%" "a,b/c,%/d" "%/,%/a" "%/,%/a" "%/,%/a" "%" "%" "%/" "%/" "%abc%")
 (list "abc" "abc"   "abcd"   "abc"     "abc"     "a"         "abc"     "def"    "ghi"   "a" "a"  "a"  "a" "abc")
 (list   ""  ""      "cde"    "cde"     "cde"     ""            ""      "a"       "b"    ""  "b"  ""   "b" "abc")
 (list   #t    #t       #t    #f           #f      #t           #t       #t       #f     #t  #t   #t    #f #t))

;; db:patt->like
(test #f "testname LIKE 't%'" (db:patt->like "testname" "t%" comparator: " AND "))
(test #f "testname LIKE 't%' AND testname LIKE '%t'" (db:patt->like "testname" "t%,%t" comparator: " AND "))
(test #f "item_path GLOB ''" (db:patt->like "item_path" ""))

;; test:match->sqlqry
(test #f "(testname GLOB 'a' AND item_path GLOB 'b') OR (testname LIKE 'a%' AND item_path LIKE '%') OR (testname GLOB '' AND item_path LIKE 'b%')"
      (tests:match->sqlqry "a/b,a%,/b%"))
(test #f "(testname GLOB 'a' AND item_path GLOB 'b') OR (testname LIKE 'a%' AND item_path LIKE '%') OR (testname LIKE '%' AND item_path LIKE 'b%')"
      (tests:match->sqlqry "a/b,a%,%/b%"))

;;======================================================================
;; S E R V E R
;;======================================================================

(test "setup for run" #t (begin (setup-for-run)
				(string? (getenv "MT_RUN_AREA_HOME"))))

(test "server-register, get-best-server" #t (let ((res #f))
					      (open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live 'http)
					      (set! res (open-run-close tasks:get-best-server tasks:open-db))
					      (number? (vector-ref res 3))))

(test "de-register server" #t (let ((res #f))
				(open-run-close tasks:server-deregister tasks:open-db "bob" port: 1234)
				(vector? (open-run-close tasks:get-best-server tasks:open-db))))

(define server-pid #f)
(test "launch server" #t (let ((pid (process-fork (lambda ()
						    ;; (daemon:ize)
						    (server:launch 'http)))))
			   (set! server-pid pid)
			   (number? pid)))

(thread-sleep! 3) ;; need to wait for server to start. Yes, a better way is needed.
(test "get-best-server" #t (let ((dat (open-run-close tasks:get-best-server tasks:open-db)))
			     (set! *runremote* (list (vector-ref dat 1)(vector-ref dat 2))) ;; host ip pullport pubport
			     (and (string? (car  *runremote*))
			     	  (number? (cadr *runremote*)))))

(test #f #t (car (cdb:login *runremote* *toppath* *my-client-signature*)))
(test #f #t (let ((res (client:login *runremote*)))
	      (car res)))


;;======================================================================
;; C O N F I G   F I L E S 
;;======================================================================

(define conffile #f)
(test "Read a config" #t (hash-table? (read-config "test.config" #f #f)))
(test "Read a config that doesn't exist" #t (hash-table? (read-config "nada.config" #f #f)))

(set! conffile (read-config "test.config" #f #f))
(test "Get available diskspace" #t (number? (get-df "./")))
(test "Get best dir" #t (let ((bestdir (get-best-disk conffile)))
			      (or (equal? "./"   bestdir)
				  (equal? "/tmp" bestdir))))
(test "Multiline variable" 4 (length (string-split (config-lookup conffile "metadata" "description") "\n")))

;; db
(define row    (vector "a" "b" "c" "blah"))
(define header (list "col1" "col2" "col3" "col4"))
(test "Get row by header" "blah" (db:get-value-by-header row header "col4"))

;; (define *toppath* "tests")
(define *db* #f)
(test "open-db" #t (begin
		     (set! *db* (open-db))
		     (if *db* #t #f)))

;; quit wasting time, I'm changing *db* to db
(define db *db*)

(test "get cpu load" #t (number? (get-cpu-load)))
(test "get uname"    #t (string? (get-uname)))

(test "get validvalues as list" (list "start" "end" "completed")
      (string-split (config-lookup *configdat* "validvalues" "state")))

(for-each (lambda (item)
	    (test (conc "get valid items (" item ")")
		  item (items:check-valid-items "state" item)))
	  (list "start" "end" "completed"))

(for-each (lambda (item)
	    (test (conc "get valid items (" item ")")
		  item (items:check-valid-items "status" item)))
	  (list "pass" "fail" "n/a"))

(test #f #f (items:check-valid-items "state" "blahfool"))

(test "write env files" "nada.csh" (begin
                                      (save-environment-as-files "nada")
                                      (and (file-exists? "nada.sh")
    			                 (file-exists? "nada.csh"))))

(test #f #t (cdb:client-call *runremote* 'immediate #t 1 (lambda ()(display "Got here eh!?") #t)))

;; (set! *verbosity* 20)
(test #f *verbosity* (cadr (cdb:set-verbosity *runremote* *verbosity*)))
(test #f #f (cdb:roll-up-pass-fail-counts *runremote* 1 "test1" "" "PASS"))
;; (set! *verbosity* 1)
;; (cdb:set-verbosity *runremote* *verbosity*)

(test "get all legal tests" (list "test1" "test2") (sort (get-all-legal-tests) string<=?))


(test "get-keys" "SYSTEM" (car (db:get-keys *db*)))

(define remargs (args:get-args
		 '("bar" "foo" ":runname" "bob" ":SYSTEM" "ubuntu" ":RELEASE" "v1.2" ":datapath" "blah/foo" "nada")
		 (list ":runname" ":state" ":status")
		 (list "-h")
		 args:arg-hash
		 0))

(test "register-run" #t (number?
			 (db:register-run *db*
					  '(("SYSTEM" "key1")("RELEASE" "key2"))
					  "myrun" 
					  "new"
					  "n/a" 
					  "bob")))

(test #f #t             (cdb:tests-register-test *runremote* 1 "nada" ""))
(test #f 1              (cdb:remote-run db:get-test-id #f 1 "nada" ""))
(test #f "NOT_STARTED"  (vector-ref (open-run-close db:get-test-info #f 1 "nada" "") 3))
(test #f "NOT_STARTED"  (vector-ref (cdb:get-test-info *runremote* 1 "nada" "") 3))

(define keys (db:get-keys *db*))

;;======================================================================
;; D B
;;======================================================================

(test #f "FOO LIKE 'abc%def'" (db:patt->like "FOO" "abc%def"))
(test #f "key2" (vector-ref (car (vector-ref (runs:get-runs-by-patt *db* '("SYSTEM" "RELEASE") "%" "key1/key2") 1)) 1))

(test #f "SYSTEM,RELEASE,id,runname,state,status,owner,event_time" (car (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time"))))
(test #f #t (runs:operate-on 'print "%" "%" "%"))

;;(test "update-test-info" #t (test-update-meta-info *db* 1 "nada" 
(setenv "BLAHFOO" "1234")
(unsetenv "NADAFOO")
(test "env temp overrides" "xyz" (let ((prevvals (alist->env-vars '(("BLAHFOO" 4321)("NADAFOO" xyz))))
				       (result   (get-environment-variable "NADAFOO")))
				    (alist->env-vars prevvals)
				    result))

(test "env restored" "1234" (get-environment-variable "BLAHFOO"))


(test "Items assoc" "Elephant" (cadar (cadr (item-assoc->item-list '(("ANIMAL" "Elephant Lion")("SEASON" "Spring Fall"))))))
(set! *verbosity* 6)
(test "Items assoc" '()(item-assoc->item-list '(("a" "a b c d")("b" "c d e")("c" "")("d"))))
(set! *verbosity* -1)
(test "Items assoc empty items" '()   (item-assoc->item-list '(("A"))))
(set! *verbosity* 1)
(test "Items table" "SEASON" (caadar (item-table->item-list '(("ANIMAL" "Elephant Lion")("SEASON" "Spring Winter")))))
(test "Items table empty items I" '() (item-table->item-list '(("A"))))
(test "Items table empty items II" '() (item-table->item-list '(("A" ""))))

;; Test out the steps code

(define test-id #f)

;; force keepgoing
; (hash-table-set! args:arg-hash "-keepgoing" #t)
(hash-table-set! args:arg-hash "-itempatt" "%")
(hash-table-set! args:arg-hash "-testpatt" "%")
(hash-table-set! args:arg-hash "-target" "ubuntu/r1.2")
(test "Setup for a run"       #t (begin (setup-for-run) #t))

(define *tdb* #f)
(define keyvals #f)
(test "target->keyval" #t (let ((kv (keys:target->keyval keys (args:get-arg "-target"))))
			    (set! keyvals kv)(list? keyvals)))

(define testdbpath (conc "/tmp/" (getenv "USER") "/megatest_testing"))
(system (conc "rm -f " testdbpath "/testdat.db;mkdir -p " testdbpath))

(print "Using " testdbpath " for test db")
(test #f #t (let ((db (open-test-db testdbpath)))
	      (set! *tdb* db)
	      (sqlite3#database? db)))
(sqlite3#finalize! *tdb*)

;; (test "Remove the rollup run" #t (begin (remove-runs) #t))
(define tconfig #f)
(test "get a testconfig" #t (let ((tconf (tests:get-testconfig "test1" 'return-procs)))
			      (set! tconfig tconf)
			      (hash-table? tconf)))
(db:clean-all-caches)

(test "set-megatest-env-vars"
      "ubuntu"
      (begin
	(set-megatest-env-vars 1 inkeys: keys)
	(get-environment-variable "SYSTEM")))
(test "setup-env-defaults"
      "see this variable"
      (begin
	(setup-env-defaults "runconfigs.config" 1 *already-seen-runconfig-info* keys keyvals "pre-launch-env-vars")
	(get-environment-variable "ALLTESTS")))

(test #f "ubuntu" (car (keys:target-set-args keys (args:get-arg "-target") args:arg-hash)))

(define rinfo #f)
(test "get-run-info"  #f (vector? (vector-ref (let ((rinf (cdb:remote-run db:get-run-info #f 1)))
						(set! rinfo rinf)
						rinf) 0)))
(test "get-key-vals"  "key1" (car (cdb:remote-run db:get-key-vals #f 1)))
(test "tests:sort-by" '() (tests:sort-by-priority-and-waiton (make-hash-table)))

(test "update-test_meta" "test1" (begin
				   (runs:update-test_meta "test1" tconfig)
				   (let ((dat (cdb:remote-run db:testmeta-get-record #f "test1")))
				     (vector-ref dat 1))))

(define test-path "tests/test1")
(define disk-path #f)
(test "get-best-disk"    #t (string? (file-exists? (let ((d (get-best-disk *configdat*)))
						     (set! disk-path d)
						     d))))
(test "create-work-area" #t (symbolic-link? (car (create-work-area 1 rinfo keyvals 1 test-path disk-path "test1" '()))))
(test #f "" (item-list->path '()))

(test "launch-test" #t (string? (file-exists? (launch-test 1 1 rinfo keyvals "run1" tconfig "test1" test-path '() (make-hash-table)))))


(test "Run a test" #t (general-run-call 
		       "-runtests" 
		       "run a test"
		       (lambda (target runname keys keyvallst)
			 (let ((test-patts "test%"))
			   ;; (runs:run-tests target runname test-patts user (make-hash-table))
			   ;; (run:test run-id run-info key-vals runname test-record flags parent-test)
			   ;; (set! *verbosity* 22) ;; (list 0 1 2))
			   (run:test 1 ;; run-id
				     #f        ;; run-info is yet only a dream
				     keyvallst ;; (keys:target->keyval keys target)
				     "run1"    ;; runname 
				     (vector            ;; test_records.scm tests:testqueue
				      "test1"           ;; testname
				      tconfig           ;; testconfig
				      '()               ;; waitons
				      0                 ;; priority
				      #f                ;; items
				      #f                ;; itemsdat
				      ""                ;; itempath
				      )
				     args:arg-hash      ;; flags (e.g. -itemspatt)
				     #f)
			   ;; (set! *verbosity* 0)
			   ))))





(test "server stop" #f (let ((hostname (car  *runremote*))
			     (port     (cadr *runremote*)))
			 (tasks:kill-server #t hostname port server-pid 'http)
			 (open-run-close tasks:get-best-server tasks:open-db)))

(exit 1)
;; (test "cache is coherent" #t (let ((cached-info (db:get-test-info-cached-by-id db 2))
;; 				   (non-cached  (db:get-test-info-not-cached-by-id db 2)))
;; 			       (print "\nCached:    " cached-info)
;; 			       (print "Noncached: " non-cached)
;; 			       (equal? cached-info non-cached)))

(change-directory test-work-dir)
(test "Add a step"  #t
      (begin
	(db:teststep-set-status! db 2 "step1" "start" 0 "This is a comment" "mylogfile.html")
	(sleep 2)
	(db:teststep-set-status! db 2 "step1" "end" "pass" "This is a different comment" "finallogfile.html")
	(set! test-id (db:test-get-id (car (cdb:remote-run db:get-tests-for-run #f 1 "test1" '() '()))))
	(number? test-id)))

(test "Get rundir"       #t (let ((rundir (cdb:remote-run db:test-get-rundir-from-test-id #f test-id)))
			      (print "Rundir " rundir)
			      (system (conc "mkdir -p " rundir))
			      (string? rundir)))
(test #f #t (sqlite3#database? (open-test-db "./")))
(test "Create a test db" "../simpleruns/key1/key2/myrun/test1/testdat.db"
      (let ((tdb (open-run-close db:open-test-db-by-test-id db test-id)))
	(if tdb (sqlite3#finalize! tdb))
	(file-exists? "../simpleruns/key1/key2/myrun/test1/testdat.db")))

(test "Get steps for test" #t (let ((steps (cdb:remote-run db:get-steps-for-test #f test-id)))
				(print steps)
				(> (length steps) 0)))
(test "Get nice table for steps" "2.0s"
      (begin
	(vector-ref (hash-table-ref (open-run-close db:get-steps-table #f test-id) "step1") 4)))

;; (exit)

(test #f "myrun" (cdb:remote-run db:get-run-name-from-id #f 1))

(test #f #f (cdb:remote-run db:roll-up-pass-fail-counts #f 1 "nada" "" "PASS"))

;;======================================================================
;; R E M O T E   C A L L S 
;;======================================================================

(define start-wait (current-seconds))
(print "Starting intensive cache and rpc test")
(for-each (lambda (params)
	    (print "Intensive: params=" params)
	    (cdb:tests-register-test *runremote* 1 (conc "test" (random 20)) "")
	    (apply cdb:test-set-status-state *runremote* test-id params)
	    (cdb:pass-fail-counts *runremote* test-id (random 100) (random 100))
	    (cdb:test-rollup-test_data-pass-fail *runremote* test-id)
	    (cdb:roll-up-pass-fail-counts *runremote* 1 "test1" "" (cadr params))
	    (thread-sleep! 0.01)) ;; cache ordering granularity is at the second level. Should really be at the ms level
	  '(("COMPLETED"    "PASS" #f)
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("COMPLETED"    "PASS" #f)
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("KILLED"       "UNKNOWN" "More testing")
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("COMPLETED"    "PASS" #f)
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("KILLED"       "UNKNOWN" "More testing")
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("COMPLETED"    "PASS" #f)
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("KILLED"       "UNKNOWN" "More testing")
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("COMPLETED"    "PASS" #f)
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("KILLED"       "UNKNOWN" "More testing")
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("COMPLETED"    "PASS" #f)
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("KILLED"       "UNKNOWN" "More testing")
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("COMPLETED"    "PASS" #f)
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("KILLED"       "UNKNOWN" "More testing")
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("COMPLETED"    "PASS" #f)
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("KILLED"       "UNKNOWN" "More testing")
	    ("KILLED"       "UNKNOWN" "More testing")
	    ))

;; now set all tests to completed
(cdb:flush-queue *runremote*)
(let ((tests (cdb:remote-run db:get-tests-for-run #f 1 "%" '() '())))
  (print "Setting " (length tests) " to COMPLETED/PASS")
  (for-each
   (lambda (test)
     (cdb:test-set-status-state *runremote* (db:test-get-id test) "COMPLETED" "PASS" "Forced pass"))
   tests))

;; (process-wait server-pid)
;; (test "Server wait time" #t (let ((run-delta (- (current-seconds) start-wait)))
;; 			      (print "Server ran for " run-delta " seconds")
;; 			      (> run-delta 20)))

(test "Rollup the run(s)" #t (begin
			       (runs:rollup-run keys (keys->alist keys "na") "rollup" "matt")
			       #t))

(hash-table-set! args:arg-hash ":runname" "%")

(test "Remove the rollup run" #t (begin (operate-on 'remove-runs)))

(print "Waiting for server to be done, should be about 20 seconds")
(test "server stop" #f (let ((hostname (car  *runremote*))
			     (port     (cadr *runremote*)))
			 (tasks:kill-server #t hostname port server-pid 'http)
			 (open-run-close tasks:get-best-server tasks:open-db)))

;; (cdb:kill-server *runremote*)

;; (thread-join! th1 th2 th3)

;; ADD ME!!!! (db:get-prereqs-not-met *db* 1 '("runfirst") "" mode: 'normal)
;; ADD ME!!!! (rdb:get-tests-for-run *db* 1 "runfirst" #f '() '())







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

<
<
<
<
<
<
<





<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
22
23
24
25
26
27
28

29



30



31



32
33







34
35







36
37
38
39
40










































































































































































































































































































































































































(let ((files (glob "*_records.scm")))
  (for-each
   (lambda (file)
     (print "Loading " file)
     (load file))
   files))


(let* ((unit-test-name (list-ref (argv) 4))



       (fname          (conc "../unittests/" unit-test-name ".scm")))



  (if (file-exists? fname)



      (load fname)
      (print "ERROR: Unit test " unit-test-name " not found in unittests directory")))
















 (list "abc" "abc/%" "ab%/c%" "~abc/c%" "abc/~c%" "a,b/c,%/d" "%/,%/a" "%/,%/a" "%/,%/a" "%" "%" "%/" "%/" "%abc%")
 (list "abc" "abc"   "abcd"   "abc"     "abc"     "a"         "abc"     "def"    "ghi"   "a" "a"  "a"  "a" "abc")
 (list   ""  ""      "cde"    "cde"     "cde"     ""            ""      "a"       "b"    ""  "b"  ""   "b" "abc")
 (list   #t    #t       #t    #f           #f      #t           #t       #t       #f     #t  #t   #t    #f #t))











































































































































































































































































































































































































Added tests/unittests/basicserver.scm version [28418079ab].



























































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
;;======================================================================
;; S E R V E R
;;======================================================================

;; Run like this:
;;
;;  ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0)

(delete-file* "logs/1.log")
(define run-id 1)

(test "setup for run" #t (begin (launch:setup-for-run)
 				(string? (getenv "MT_RUN_AREA_HOME"))))

;; NON Server tests go here

(test #f #f (db:dbdat-get-path *db*))
(test #f #f (db:get-run-name-from-id *db* run-id))
;; (test #f '("SYSTEM" "RELEASE") (rmt:get-keys))

;; (exit)

;; Server tests go here 
(for-each
 (lambda (run-id)
   (test #f #f (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id))
   (server:kind-run run-id)
   (test "did server start within 20 seconds?"
	 #t
	 (let loop ((remtries 20)
		    (running (tasks:server-running-or-starting? (db:delay-if-busy
								 (tasks:open-db))
								run-id)))
	   (if running 
	       (> running 0)
	       (if (> remtries 0)
		   (begin
		     (thread-sleep! 1)
		     (loop (- remtries 1)
			   (tasks:server-running-or-starting? (db:delay-if-busy
							       (tasks:open-db))
							      run-id)))))))
   
   (test "did server become available" #t
	 (let loop ((remtries 10)
		    (res      (tasks:get-server (db:delay-if-busy (tasks:open-db)) run-id)))
	   (if res
	       (vector? res)
	       (begin
		 (if (> remtries 0)
		     (begin
		       (thread-sleep! 1.1)
		       (loop (- remtries 1)(tasks:get-server (db:delay-if-busy (tasks:open-db)) run-id)))
		     res)))))
   )
 (list 0 1))

(define user    (current-user-name))
(define runname "mytestrun")
(define keys    (rmt:get-keys))
(define runinfo #f)
(define keyvals '(("SYSTEM" "abc")("RELEASE" "def")))
(define header  (list "SYSTEM" "RELEASE" "id" "runname" "state" "status" "owner" "event_time"))

;; Setup
;;
(test #f #f  (not (client:setup run-id)))
(test #f #f  (not (hash-table-ref/default *runremote* run-id #f)))

;; Login
;;
(test #f'(#t "successful login")
      (rmt:login-no-auto-client-setup (hash-table-ref/default *runremote* run-id #f) run-id))
(test #f '(#t "successful login")
      (rmt:login run-id))

;; Keys
;;
(test #f '("SYSTEM" "RELEASE")  (rmt:get-keys))

;; No data in db
;;
(test #f '() (rmt:get-all-run-ids))
(test #f #f  (rmt:get-run-name-from-id run-id))
(test #f 
      (vector
       header
       (vector #f #f #f #f))
      (rmt:get-run-info run-id))

;; Insert data into db
;;
(test #f 1 (rmt:register-run keyvals runname "new" "n/a" user))
;; (test #f #f (rmt:get-runs-by-patt keys runname))
(test #f #t (rmt:general-call 'register-test run-id run-id "test-one" ""))
(define test-one-id #f)
(test #f 30001  (let ((test-id (rmt:get-test-id run-id "test-one" "")))
	      (set! test-one-id test-id)
	      test-id))
(define test-one-rec #f)
(test #f "test-one" (let ((test-rec (rmt:get-test-info-by-id run-id test-one-id)))
		      (set! test-one-rec test-rec)
		      (vector-ref test-rec 2)))

;; With data in db
;;
(print "Using runame=" runname)
(test #f '(1)    (rmt:get-all-run-ids))
(test #f runname (rmt:get-run-name-from-id run-id))
(test #f 
      runname
      (let ((run-info (rmt:get-run-info run-id)))
	(db:get-value-by-header (db:get-rows run-info)
				(db:get-header run-info)
				"runname")))

(for-each (lambda (run-id)
;; test killing server
;;
(tasks:kill-server-run-id run-id)

(test #f #f (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id))
)
(list 0 1))

;; Tests to assess reading/writing while servers are starting/stopping
(define start-time (current-seconds))
(let loop ((test-state 'start))
  (let* ((server-dats (tasks:get-server-records (db:delay-if-busy (tasks:open-db)) run-id))
	 (first-dat   (if (not (null? server-dats))
			  (car server-dats)
			  #f)))
    (map (lambda (dat)
	   (apply print (intersperse (vector->list dat) ", ")))
	 server-dats)
    (test #f test-one-rec (rmt:get-test-info-by-id run-id test-one-id))
    (thread-sleep! 1)
    (case test-state
      ((start)
       (print "Trying to start server")
       (server:kind-run run-id)
       (loop 'server-started))
      ((server-started)
       (case (vector-ref first-dat)
	 ((running)
	  (print "Server appears to be running. Now ask it to shutdown")
	  (rmt:kill-server run-id)
	  (loop 'server-shutdown))
	 ((shutting-down)
	  (loop test-state))
	 (else (print "Don't know what to do if get here"))))
      ((server-shutdown)
       (loop test-state)))))

;;======================================================================
;; END OF TESTS
;;======================================================================


;; (test #f #f (client:setup run-id))

;; (set! *transport-type* 'http)
;; 
;; (test "setup for run" #t (begin (launch:setup-for-run)
;; 				(string? (getenv "MT_RUN_AREA_HOME"))))
;; 
;; (test "server-register, get-best-server" #t (let ((res #f))
;; 					      (open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live 'http)
;; 					      (set! res (open-run-close tasks:get-best-server tasks:open-db))
;; 					      (number? (vector-ref res 3))))
;; 
;; (test "de-register server" #f (let ((res #f))
;; 				(open-run-close tasks:server-deregister tasks:open-db "bob" port: 1234)
;; 				(vector? (open-run-close tasks:get-best-server tasks:open-db))))
;; 
;; (define server-pid #f)
;; 
;; ;; Not sure how the following should work, replacing it with system of megatest -server
;; ;; (test "launch server" #t (let ((pid (process-fork (lambda ()
;; ;; 						    ;; (daemon:ize)
;; ;; 						    (server:launch 'http)))))
;; ;; 			   (set! server-pid pid)
;; ;; 			   (number? pid)))
;; (system "../../bin/megatest -server - -debug 22 > server.log 2> server.log &")
;; 
;; (let loop ((n 10))
;;   (thread-sleep! 1) ;; need to wait for server to start.
;;   (let ((res (open-run-close tasks:get-best-server tasks:open-db)))
;;     (print "tasks:get-best-server returned " res)
;;     (if (and (not res)
;; 	     (> n 0))
;; 	(loop (- n 1)))))
;; 
;; (test "get-best-server" #t (begin 
;; 			     (client:launch)
;; 			     (let ((dat (open-run-close tasks:get-best-server tasks:open-db)))
;; 			       (vector? dat))))
;; 
;; (define *keys*               (keys:config-get-fields *configdat*))
;; (define *keyvals*            (keys:target->keyval *keys* "a/b/c"))
;; 
;; (test #f #t                       (string? (car *runremote*)))
;; (test #f '(#t "successful login") (rmt:login)) ;;  *runremote* *toppath* *my-client-signature*)))
;; 
;; (test #f #f                       (rmt:get-test-info-by-id 99)) ;; get non-existant test
;; 
;; ;; RUNS
;; (test #f 1                        (rmt:register-run  *keyvals* "firstrun" "new" "n/a" (current-user-name)))
;; (test "get run info"  "firstrun"  (let ((rinfo (rmt:get-run-info 1)))
;; 				    (vector-ref (vector-ref rinfo 1) 3)))
;; (test "get runname from id" "firstrun" (rmt:get-run-name-from-id 1))
;; 
;; ;; TESTS
;; (test "get tests (no data)" '()   (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f))
;; (test "register test"       #t    (rmt:general-call 'register-test 1 "test1" ""))
;; (test "get tests (some data)"  1  (length (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f)))
;; (test "get test id"            1  (rmt:get-test-id 1 "test1" ""))
;; (test "sync back"              #t (> (rmt:sync-inmem->db) 0))
;; (test "get test id from main"  1  (db:get-test-id *db* 1 "test1" ""))
;; (test "get keys"               #t (list? (rmt:get-keys)))
;; (test "set comment"            #t (begin (rmt:general-call 'set-test-comment "this is a comment" 1) #t))
;; (test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1)))
;; 					  (db:test-get-comment trec)))
;; 
;; ;; MORE RUNS
;; (test "get runs"  #t (let* ((runs   (rmt:get-runs "%" #f #f '()))
;; 			    (header (vector-ref runs 0))
;; 			    (data   (vector-ref runs 1)))
;; 		       (and (list?   header)
;; 			    (list?   data)
;; 			    (vector? (car data)))))
;; 
;; (test "get local testinfo" "test1" (vector-ref (db:get-testinfo-state-status *db* 1) 2))
;; (test "get testinfo"       "test1" (vector-ref (rmt:get-testinfo-state-status 1) 2))
;; 
;; ;;======================================================================
;; ;; D B
;; ;;======================================================================
;; 
;; (test "pass fail counts" #t (rmt:general-call 'pass-fail-counts 10 9 1))
;; (test "get pass fail counts" 19 (let ((dat (rmt:get-test-info-by-id 1)))
;; 				  (+ (db:test-get-pass_count dat)
;; 				     (db:test-get-fail_count dat))))
;; 
;; (define testregistry (make-hash-table))
;; (for-each
;;  (lambda (tname)
;;    (for-each
;;     (lambda (itempath)
;;       (let ((tkey  (conc tname "/" itempath))
;; 	    (rpass (random 10))
;; 	    (rfail (random 10)))
;; 	(hash-table-set! testregistry tkey (list tname itempath))
;; 	(rmt:general-call 'register-test 1 tname itempath)
;; 	(let* ((tid  (rmt:get-test-id 1 tname itempath))
;; 	       (tdat (rmt:get-test-info-by-id tid)))
;; 	  (rmt:general-call 'pass-fail-counts rpass rfail (db:test-get-id tdat))
;; 	  (let* ((resdat (rmt:get-test-info-by-id tid)))
;; 	    (test "set/get pass fail counts" (list rpass rfail)
;; 		  (list (db:test-get-pass_count resdat)
;; 			(db:test-get-fail_count resdat)))))))
;;     (list "" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j")))
;;  (list "test1" "test2" "test3" "test4" "test5"))
;; 
;; 
;; (test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f)))
;; 

(exit)

Added tests/unittests/configfiles.scm version [b89134d61a].









































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
;;======================================================================
;; C O N F I G   F I L E S 
;;======================================================================

(define conffile #f)
(test "Read a config" #t (hash-table? (read-config "test.config" #f #f)))
(test "Read a config that doesn't exist" #t (hash-table? (read-config "nada.config" #f #f)))

(set! conffile (read-config "test.config" #f #f))
(test "Get available diskspace" #t (number? (get-df "./")))
(test "Get best dir" #t (let ((bestdir (get-best-disk conffile)))
			      (or (equal? "./"   bestdir)
				  (equal? "/tmp" bestdir))))
(test "Multiline variable" 4 (length (string-split (config-lookup conffile "metadata" "description") "\n")))

;; db
(define row    (vector "a" "b" "c" "blah"))
(define header (list "col1" "col2" "col3" "col4"))
(test "Get row by header" "blah" (db:get-value-by-header row header "col4"))

;; (define *toppath* "tests")
(define *db* #f)
(test "open-db" #t (begin
		     (set! *db* (open-db))
		     (if *db* #t #f)))

;; quit wasting time, I'm changing *db* to db
(define db *db*)

(test "get cpu load" #t (number? (get-cpu-load)))
(test "get uname"    #t (string? (get-uname)))

(test "get validvalues as list" (list "start" "end" "completed")
      (string-split (config-lookup *configdat* "validvalues" "state")))

(for-each (lambda (item)
	    (test (conc "get valid items (" item ")")
		  item (items:check-valid-items "state" item)))
	  (list "start" "end" "completed"))

(for-each (lambda (item)
	    (test (conc "get valid items (" item ")")
		  item (items:check-valid-items "status" item)))
	  (list "pass" "fail" "n/a"))

(test #f #f (items:check-valid-items "state" "blahfool"))

(test "write env files" "nada.csh" (begin
                                      (save-environment-as-files "nada")
                                      (and (file-exists? "nada.sh")
    			                 (file-exists? "nada.csh"))))

Added tests/unittests/dbrdbstruct.scm version [174e159a1e].



































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
;;======================================================================
;; S E R V E R
;;======================================================================

;; Run like this:
;;
;;  (cd ..;make && make install) && ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0)

(test #f #t                 (vector? (make-dbr:dbstruct "/tmp")))

(define dbstruct (make-dbr:dbstruct "/tmp"))

(test #f #t                 (begin (dbr:dbstruct-set-main! dbstruct "blah") #t))
(test #f "blah"             (dbr:dbstruct-get-main  dbstruct))
(for-each 
 (lambda (run-id)
   (test #f #t                 (vector? (dbr:dbstruct-get-rundb-rec dbstruct run-id))))
 (list 1 2 3 4 5 6 7 8 9 #f))

(test #f 0 (dbr:dbstruct-field-name->num 'rundb))
(test #f 1 (dbr:dbstruct-field-name->num 'inmem))
(test #f 2 (dbr:dbstruct-field-name->num 'mtime))

(test #f #f (dbr:dbstruct-get-runvec-val dbstruct 1 'rundb))
(test #f #t (begin (dbr:dbstruct-set-runvec-val! dbstruct 1 'rundb "rundb") #t))
(test #f "rundb" (dbr:dbstruct-get-runvec-val dbstruct 1 'rundb))

(for-each
 (lambda (k)
   (test #f #t                 (begin (dbr:dbstruct-set-runvec-val! dbstruct 1 k (conc k)) #t))
   (test #f (conc k)           (dbr:dbstruct-get-runvec-val dbstruct 1 k)))
 '(rundb inmem mtime rtime stime inuse))

Added tests/unittests/inmemdb.scm version [be345ba03b].

























































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
;;======================================================================
;; S E R V E R
;;======================================================================

;; Run like this:
;;
;;  (cd ..;make && make install) && ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0)

(set! *transport-type* 'http)

(system "cp ../fullrun/megatest.db megatest.db")

(test "open inmem db"          1  (begin (open-in-mem-db) 1))

(test "setup for run" #t (begin (setup-for-run)
				(string? (getenv "MT_RUN_AREA_HOME"))))

(system "megatest -server - -debug 0 &")

(thread-sleep! 3) ;; need to wait for server to start. Yes, a better way is needed.

(define *keys*               (keys:config-get-fields *configdat*))
(define *keyvals*            (keys:target->keyval *keys* "a/b/c"))

(test #f #t                       (string? (car *runremote*)))
(test #f '(#t "successful login") (rmt:login)) ;;  *runremote* *toppath* *my-client-signature*)))

(define inmem (db:open-inmem-db))

(define (inmem-test t b)
  (test "inmem sync to"   t (db:sync-to *db* inmem))
  (test "inmem sync back" b (db:sync-to inmem *db*)))

(inmem-test 0 0)

(inmem-test 1 1)

;;======================================================================
;; D B
;;======================================================================

(test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f)))

 

Added tests/unittests/misc.scm version [68603bcdd2].



























































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
;;======================================================================
;; P R O C E S S E S
;;======================================================================

(test "cmd-run-with-stderr->list" '("No such file or directory")
      (let ((reslst (cmd-run-with-stderr->list "ls" "/tmp/ihadbetternotexist")))
	(string-search (regexp "No such file or directory")(car reslst))))

;;======================================================================
;; T E S T   M A T C H I N G
;;======================================================================

;; tests:glob-like-match
(test #f '("abc") (tests:glob-like-match "abc" "abc"))
(for-each 
 (lambda (patt str expected)
   (test (conc patt " " str "=>" expected) expected (tests:glob-like-match patt str)))
 (list "abc"    "~abc" "~abc" "a*c"  "a%c")
 (list "abc"    "abcd" "abc"  "ABC"  "ABC")
 (list '("abc")  #t      #f     #f '("ABC"))
 )

;; tests:match
(test #f #t (tests:match "abc/def" "abc" "def"))
(for-each 
 (lambda (patterns testname itempath expected)
   (test (conc patterns " " testname "/" itempath "=>" expected)
	 expected 
	 (tests:match patterns testname itempath)))
 (list "abc" "abc/%" "ab%/c%" "~abc/c%" "abc/~c%" "a,b/c,%/d" "%/,%/a" "%/,%/a" "%/,%/a" "%" "%" "%/" "%/")
 (list "abc" "abc"   "abcd"   "abc"     "abc"     "a"         "abc"     "def"    "ghi"   "a" "a"  "a"  "a")
 (list   ""  ""      "cde"    "cde"     "cde"     ""            ""      "a"       "b"    ""  "b"  ""   "b")
 (list   #t    #t       #t    #f           #f      #t           #t       #t       #f     #t  #t   #t    #f))

;; db:patt->like
(test #f "testname LIKE 't%'" (db:patt->like "testname" "t%" comparator: " AND "))
(test #f "testname LIKE 't%' AND testname LIKE '%t'" (db:patt->like "testname" "t%,%t" comparator: " AND "))
(test #f "item_path GLOB ''" (db:patt->like "item_path" ""))

;; test:match->sqlqry
(test #f "(testname GLOB 'a' AND item_path GLOB 'b') OR (testname LIKE 'a%' AND item_path LIKE '%') OR (testname GLOB '' AND item_path LIKE 'b%')"
      (tests:match->sqlqry "a/b,a%,/b%"))
(test #f "(testname GLOB 'a' AND item_path GLOB 'b') OR (testname LIKE 'a%' AND item_path LIKE '%') OR (testname LIKE '%' AND item_path LIKE 'b%')"
      (tests:match->sqlqry "a/b,a%,%/b%"))

Added tests/unittests/runs.scm version [61908ea980].







































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
(define keys (db:get-keys *db*))

(test "get all legal tests" (list "test1" "test2") (sort (get-all-legal-tests) string<=?))

(test "register-run" #t (number?
			 (db:register-run *db*
					  '(("SYSTEM" "key1")("RELEASE" "key2"))
					  "myrun" 
					  "new"
					  "n/a" 
					  "bob")))

(test #f #t             (cdb:tests-register-test *runremote* 1 "nada" ""))
(test #f 1              (cdb:remote-run db:get-test-id #f 1 "nada" ""))
(test #f "NOT_STARTED"  (vector-ref (open-run-close db:get-test-info #f 1 "nada" "") 3))
(test #f "NOT_STARTED"  (vector-ref (cdb:get-test-info *runremote* 1 "nada" "") 3))

(test #f "FOO LIKE 'abc%def'" (db:patt->like "FOO" "abc%def"))
(test #f "key2" (vector-ref (car (vector-ref (runs:get-runs-by-patt *db* '("SYSTEM" "RELEASE") "%" "key1/key2") 1)) 1))

(test #f "SYSTEM,RELEASE,id,runname,state,status,owner,event_time" (car (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time"))))
(test #f #t (runs:operate-on 'print "%" "%" "%"))

;;(test "update-test-info" #t (test-update-meta-info *db* 1 "nada" 
(setenv "BLAHFOO" "1234")
(unsetenv "NADAFOO")
(test "env temp overrides" "xyz" (let ((prevvals (alist->env-vars '(("BLAHFOO" 4321)("NADAFOO" xyz))))
				       (result   (get-environment-variable "NADAFOO")))
				    (alist->env-vars prevvals)
				    result))

(test "env restored" "1234" (get-environment-variable "BLAHFOO"))


(test "Items assoc" "Elephant" (cadar (cadr (item-assoc->item-list '(("ANIMAL" "Elephant Lion")("SEASON" "Spring Fall"))))))
(set! *verbosity* 6)
(test "Items assoc" '()(item-assoc->item-list '(("a" "a b c d")("b" "c d e")("c" "")("d"))))
(set! *verbosity* -1)
(test "Items assoc empty items" '()   (item-assoc->item-list '(("A"))))
(set! *verbosity* 1)
(test "Items table" "SEASON" (caadar (item-table->item-list '(("ANIMAL" "Elephant Lion")("SEASON" "Spring Winter")))))
(test "Items table empty items I" '() (item-table->item-list '(("A"))))
(test "Items table empty items II" '() (item-table->item-list '(("A" ""))))

;; Test out the steps code

(define test-id #f)

;; force keepgoing
; (hash-table-set! args:arg-hash "-keepgoing" #t)
(hash-table-set! args:arg-hash "-itempatt" "%")
(hash-table-set! args:arg-hash "-testpatt" "%")
(hash-table-set! args:arg-hash "-target" "ubuntu/r1.2")
(test "Setup for a run"       #t (begin (setup-for-run) #t))

(define *tdb* #f)
(define keyvals #f)
(test "target->keyval" #t (let ((kv (keys:target->keyval keys (args:get-arg "-target"))))
			    (set! keyvals kv)(list? keyvals)))

(define testdbpath (conc "/tmp/" (getenv "USER") "/megatest_testing"))
(system (conc "rm -f " testdbpath "/testdat.db;mkdir -p " testdbpath))

(print "Using " testdbpath " for test db")
(test #f #t (let ((db (open-test-db testdbpath)))
	      (set! *tdb* db)
	      (sqlite3#database? db)))
(sqlite3#finalize! *tdb*)

;; (test "Remove the rollup run" #t (begin (remove-runs) #t))
(define tconfig #f)
(test "get a testconfig" #t (let ((tconf (tests:get-testconfig "test1" 'return-procs)))
			      (set! tconfig tconf)
			      (hash-table? tconf)))
(db:clean-all-caches)

(test "set-megatest-env-vars"
      "ubuntu"
      (begin
	(set-megatest-env-vars 1 inkeys: keys)
	(get-environment-variable "SYSTEM")))
(test "setup-env-defaults"
      "see this variable"
      (begin
	(setup-env-defaults "runconfigs.config" 1 *already-seen-runconfig-info* keys keyvals "pre-launch-env-vars")
	(get-environment-variable "ALLTESTS")))

(test #f "ubuntu" (car (keys:target-set-args keys (args:get-arg "-target") args:arg-hash)))

(define rinfo #f)
(test "get-run-info"  #f (vector? (vector-ref (let ((rinf (cdb:remote-run db:get-run-info #f 1)))
						(set! rinfo rinf)
						rinf) 0)))
(test "get-key-vals"  "key1" (car (cdb:remote-run db:get-key-vals #f 1)))
(test "tests:sort-by" '() (tests:sort-by-priority-and-waiton (make-hash-table)))

(test "update-test_meta" "test1" (begin
				   (runs:update-test_meta "test1" tconfig)
				   (let ((dat (cdb:remote-run db:testmeta-get-record #f "test1")))
				     (vector-ref dat 1))))

(define test-path "tests/test1")
(define disk-path #f)
(test "get-best-disk"    #t (string? (file-exists? (let ((d (get-best-disk *configdat*)))
						     (set! disk-path d)
						     d))))
(test "create-work-area" #t (symbolic-link? (car (create-work-area 1 rinfo keyvals 1 test-path disk-path "test1" '()))))
(test #f "" (item-list->path '()))

(test "launch-test" #t (string? (file-exists? (launch-test 1 1 rinfo keyvals "run1" tconfig "test1" test-path '() (make-hash-table)))))


(test "Run a test" #t (general-run-call 
		       "-runtests" 
		       "run a test"
		       (lambda (target runname keys keyvallst)
			 (let ((test-patts "test%"))
			   ;; (runs:run-tests target runname test-patts user (make-hash-table))
			   ;; (run:test run-id run-info key-vals runname test-record flags parent-test)
			   ;; (set! *verbosity* 22) ;; (list 0 1 2))
			   (run:test 1 ;; run-id
				     #f        ;; run-info is yet only a dream
				     keyvallst ;; (keys:target->keyval keys target)
				     "run1"    ;; runname 
				     (vector            ;; test_records.scm tests:testqueue
				      "test1"           ;; testname
				      tconfig           ;; testconfig
				      '()               ;; waitons
				      0                 ;; priority
				      #f                ;; items
				      #f                ;; itemsdat
				      ""                ;; itempath
				      )
				     args:arg-hash      ;; flags (e.g. -itemspatt)
				     #f)
			   ;; (set! *verbosity* 0)
			   ))))





(test "server stop" #f (let ((hostname (car  *runremote*))
			     (port     (cadr *runremote*)))
			 (tasks:kill-server #t hostname port server-pid 'http)
			 (open-run-close tasks:get-best-server tasks:open-db)))

(exit 1)
;; (test "cache is coherent" #t (let ((cached-info (db:get-test-info-cached-by-id db 2))
;; 				   (non-cached  (db:get-test-info-not-cached-by-id db 2)))
;; 			       (print "\nCached:    " cached-info)
;; 			       (print "Noncached: " non-cached)
;; 			       (equal? cached-info non-cached)))

(change-directory test-work-dir)
(test "Add a step"  #t
      (begin
	(db:teststep-set-status! db 2 "step1" "start" 0 "This is a comment" "mylogfile.html")
	(sleep 2)
	(db:teststep-set-status! db 2 "step1" "end" "pass" "This is a different comment" "finallogfile.html")
	(set! test-id (db:test-get-id (car (cdb:remote-run db:get-tests-for-run #f 1 "test1" '() '()))))
	(number? test-id)))

(test "Get rundir"       #t (let ((rundir (cdb:remote-run db:test-get-rundir-from-test-id #f test-id)))
			      (print "Rundir " rundir)
			      (system (conc "mkdir -p " rundir))
			      (string? rundir)))
(test #f #t (sqlite3#database? (open-test-db "./")))
(test "Create a test db" "../simpleruns/key1/key2/myrun/test1/testdat.db"
      (let ((tdb (open-run-close db:open-test-db-by-test-id db test-id)))
	(if tdb (sqlite3#finalize! tdb))
	(file-exists? "../simpleruns/key1/key2/myrun/test1/testdat.db")))

(test "Get steps for test" #t (let ((steps (cdb:remote-run db:get-steps-for-test #f test-id)))
				(print steps)
				(> (length steps) 0)))
(test "Get nice table for steps" "2.0s"
      (begin
	(vector-ref (hash-table-ref (open-run-close db:get-steps-table #f test-id) "step1") 4)))

;; (exit)

(test #f "myrun" (cdb:remote-run db:get-run-name-from-id #f 1))

(test #f #f (cdb:remote-run db:roll-up-pass-fail-counts #f 1 "nada" "" "PASS"))

;;======================================================================
;; R E M O T E   C A L L S 
;;======================================================================

(define start-wait (current-seconds))
(print "Starting intensive cache and rpc test")
(for-each (lambda (params)
	    (print "Intensive: params=" params)
	    (cdb:tests-register-test *runremote* 1 (conc "test" (random 20)) "")
	    (apply cdb:test-set-status-state *runremote* test-id params)
	    (cdb:pass-fail-counts *runremote* test-id (random 100) (random 100))
	    (cdb:test-rollup-test_data-pass-fail *runremote* test-id)
	    (cdb:roll-up-pass-fail-counts *runremote* 1 "test1" "" (cadr params))
	    (thread-sleep! 0.01)) ;; cache ordering granularity is at the second level. Should really be at the ms level
	  '(("COMPLETED"    "PASS" #f)
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("COMPLETED"    "PASS" #f)
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("KILLED"       "UNKNOWN" "More testing")
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("COMPLETED"    "PASS" #f)
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("KILLED"       "UNKNOWN" "More testing")
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("COMPLETED"    "PASS" #f)
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("KILLED"       "UNKNOWN" "More testing")
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("COMPLETED"    "PASS" #f)
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("KILLED"       "UNKNOWN" "More testing")
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("COMPLETED"    "PASS" #f)
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("KILLED"       "UNKNOWN" "More testing")
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("COMPLETED"    "PASS" #f)
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("KILLED"       "UNKNOWN" "More testing")
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("COMPLETED"    "PASS" #f)
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("KILLED"       "UNKNOWN" "More testing")
	    ("KILLED"       "UNKNOWN" "More testing")
	    ))

;; now set all tests to completed
(cdb:flush-queue *runremote*)
(let ((tests (cdb:remote-run db:get-tests-for-run #f 1 "%" '() '())))
  (print "Setting " (length tests) " to COMPLETED/PASS")
  (for-each
   (lambda (test)
     (cdb:test-set-status-state *runremote* (db:test-get-id test) "COMPLETED" "PASS" "Forced pass"))
   tests))

;; (process-wait server-pid)
;; (test "Server wait time" #t (let ((run-delta (- (current-seconds) start-wait)))
;; 			      (print "Server ran for " run-delta " seconds")
;; 			      (> run-delta 20)))

(test "Rollup the run(s)" #t (begin
			       (runs:rollup-run keys (keys->alist keys "na") "rollup" "matt")
			       #t))

(hash-table-set! args:arg-hash ":runname" "%")

(test "Remove the rollup run" #t (begin (operate-on 'remove-runs)))

(print "Waiting for server to be done, should be about 20 seconds")
(test "server stop" #f (let ((hostname (car  *runremote*))
			     (port     (cadr *runremote*)))
			 (tasks:kill-server #t hostname port server-pid 'http)
			 (open-run-close tasks:get-best-server tasks:open-db)))

;; (cdb:kill-server *runremote*)

;; (thread-join! th1 th2 th3)

;; ADD ME!!!! (db:get-prereqs-not-met *db* 1 '("runfirst") "" mode: 'normal)
;; ADD ME!!!! (rdb:get-tests-for-run *db* 1 "runfirst" #f '() '())

Added tests/unittests/server.scm version [d45af24828].



































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
;;======================================================================
;; S E R V E R
;;======================================================================

;; Run like this:
;;
;;  (cd ..;make && make install) && ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0)

(delete-file* "logs/1.log")
(define run-id 1)

(test "setup for run" #t (begin (launch:setup-for-run)
 				(string? (getenv "MT_RUN_AREA_HOME"))))

;; Insert data into db
;;
(define user    (current-user-name))
(define runname "mytestrun")
(define keys    (rmt:get-keys))
(define runinfo #f)
(define keyvals '(("SYSTEM" "abc")("RELEASE" "def")))
(define header  (list "SYSTEM" "RELEASE" "id" "runname" "state" "status" "owner" "event_time"))

(test #f 1 (rmt:register-run keyvals runname "new" "n/a" user))
;; (test #f #f (rmt:get-runs-by-patt keys runname))
(test #f #t (rmt:general-call 'register-test run-id run-id "test-one" ""))
(define test-one-id #f)
(test #f 30001  (let ((test-id (rmt:get-test-id run-id "test-one" "")))
	      (set! test-one-id test-id)
	      test-id))
(define test-one-rec #f)
(test #f "test-one" (let ((test-rec (rmt:get-test-info-by-id run-id test-one-id)))
		      (set! test-one-rec test-rec)
		      (vector-ref test-rec 2)))

(use trace)
(import trace)
;; (trace
;;  rmt:send-receive
;;  rmt:open-qry-close-locally
;; )

;; Tests to assess reading/writing while servers are starting/stopping
(define start-time (current-seconds))
(let loop ((test-state 'start))
  (let* ((server-dats (tasks:get-server-records (db:delay-if-busy (tasks:open-db)) run-id))
	 (first-dat   (if (not (null? server-dats))
			  (car server-dats)
			  #f))
	 (server-state (or (and first-dat (string->symbol (vector-ref first-dat 8))) 'no-dat)))
    (if first-dat
	(map (lambda (dat)
	       (apply print (intersperse (vector->list dat) ", ")))
	     server-dats)
	(print "No server"))
    (test #f test-one-rec (rmt:get-test-info-by-id run-id test-one-id))
    (thread-sleep! 1)
    (case test-state
      ((start)
       (print "Trying to start server")
       (server:kind-run run-id)
       (loop 'server-started))
      ((server-started)
       (case server-state 
	 ((running)
	  (print "Server appears to be running. Now ask it to shutdown")
	  (rmt:kill-server run-id)
	  ;; (trace rmt:open-qry-close-locally rmt:send-receive)
	  (loop 'shutdown-started))
	 ((available)
	  (loop test-state))
	 ((shutting-down)
	  (loop test-state))
	 ((no-dat)
	  (loop test-state))
	 (else (print "Don't know what to do if get here"))))
      ((shutdown-started)
       (case server-state 
	 ((no-dat)
	  (print "Server appears to have shutdown, ending this test"))
	 (else
	  (loop test-state)))))))

(exit)	 
       
;; (set! *transport-type* 'http)
;; 
;; (test "setup for run" #t (begin (setup-for-run)
;; 				(string? (getenv "MT_RUN_AREA_HOME"))))
;; 
;; (test "server-register, get-best-server" #t (let ((res #f))
;; 					      (open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live 'http)
;; 					      (set! res (open-run-close tasks:get-best-server tasks:open-db))
;; 					      (number? (vector-ref res 3))))
;; 
;; (test "de-register server" #f (let ((res #f))
;; 				(open-run-close tasks:server-deregister tasks:open-db "bob" port: 1234)
;; 				(vector? (open-run-close tasks:get-best-server tasks:open-db))))
;; 
;; (define server-pid #f)
;; 
;; ;; Not sure how the following should work, replacing it with system of megatest -server
;; ;; (test "launch server" #t (let ((pid (process-fork (lambda ()
;; ;; 						    ;; (daemon:ize)
;; ;; 						    (server:launch 'http)))))
;; ;; 			   (set! server-pid pid)
;; ;; 			   (number? pid)))
;; (system "../../bin/megatest -server - -debug 22 > server.log 2> server.log &")
;; 
;; (let loop ((n 10))
;;   (thread-sleep! 1) ;; need to wait for server to start.
;;   (let ((res (open-run-close tasks:get-best-server tasks:open-db)))
;;     (print "tasks:get-best-server returned " res)
;;     (if (and (not res)
;; 	     (> n 0))
;; 	(loop (- n 1)))))
;; 
;; (test "get-best-server" #t (begin 
;; 			     (client:launch)
;; 			     (let ((dat (open-run-close tasks:get-best-server tasks:open-db)))
;; 			       (vector? dat))))
;; 
;; (define *keys*               (keys:config-get-fields *configdat*))
;; (define *keyvals*            (keys:target->keyval *keys* "a/b/c"))
;; 
;; (test #f #t                       (string? (car *runremote*)))
;; (test #f '(#t "successful login") (rmt:login)) ;;  *runremote* *toppath* *my-client-signature*)))
;; 
;; (test #f #f                       (rmt:get-test-info-by-id 1 99)) ;; get non-existant test
;; 
;; ;; RUNS
;; (test #f 1                        (rmt:register-run  *keyvals* "firstrun" "new" "n/a" (current-user-name)))
;; (test "get run info"  "firstrun"  (let ((rinfo (rmt:get-run-info 1)))
;; 				    (vector-ref (vector-ref rinfo 1) 3)))
;; (test "get runname from id" "firstrun" (rmt:get-run-name-from-id 1))
;; 
;; ;; TESTS
;; (test "get tests (no data)" '()   (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f))
;; (test "register test"       #t    (rmt:general-call 'register-test 1 1 "test1" ""))
;; (test "get tests (some data)"  1  (length (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f)))
;; (test "get test id"            1  (rmt:get-test-id 1 "test1" ""))
;; 
;; (test "sync back"              #t (> (rmt:sync-inmem->db) 0))
;; (test "get test id from main"  1  (db:get-test-id *db* 1 "test1" ""))
;; 
;; (test "get keys"               #t (list? (rmt:get-keys)))
;; (test "set comment"            #t (begin (rmt:general-call 'set-test-comment 1 "this is a comment" 1) #t))
;; (test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1 1)))
;; 					  (db:test-get-comment trec)))
;; 
;; ;; MORE RUNS
;; (test "get runs"  #t (let* ((runs   (rmt:get-runs "%" #f #f '()))
;; 			    (header (vector-ref runs 0))
;; 			    (data   (vector-ref runs 1)))
;; 		       (and (list?   header)
;; 			    (list?   data)
;; 			    (vector? (car data)))))
;; 
;; (test "get local testinfo" "test1" (vector-ref (db:get-testinfo-state-status *db* 1 1) 2))
;; (test "get testinfo"       "test1" (vector-ref (rmt:get-testinfo-state-status 1 1) 2))
;; 
;; ;;======================================================================
;; ;; D B
;; ;;======================================================================
;; 
;; (test "pass fail counts" #t (rmt:general-call 'pass-fail-counts 10 9 1))
;; (test "get pass fail counts" 19 (let ((dat (rmt:get-test-info-by-id 1)))
;; 				  (+ (db:test-get-pass_count dat)
;; 				     (db:test-get-fail_count dat))))
;; 
;; (define testregistry (make-hash-table))
;; (for-each
;;  (lambda (tname)
;;    (for-each
;;     (lambda (itempath)
;;       (let ((tkey  (conc tname "/" itempath))
;; 	    (rpass (random 10))
;; 	    (rfail (random 10)))
;; 	(hash-table-set! testregistry tkey (list tname itempath))
;; 	(rmt:general-call 'register-test 1 tname itempath)
;; 	(let* ((tid  (rmt:get-test-id 1 tname itempath))
;; 	       (tdat (rmt:get-test-info-by-id tid)))
;; 	  (rmt:general-call 'pass-fail-counts rpass rfail (db:test-get-id tdat))
;; 	  (let* ((resdat (rmt:get-test-info-by-id tid)))
;; 	    (test "set/get pass fail counts" (list rpass rfail)
;; 		  (list (db:test-get-pass_count resdat)
;; 			(db:test-get-fail_count resdat)))))))
;;     (list "" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j")))
;;  (list "test1" "test2" "test3" "test4" "test5"))
;; 
;; 
;; (test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f)))
;; 

Added tests/unittests/tests.scm version [da39a3ee5e].

Added tests/watch-monitor.sh version [b68f1ca512].





















>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
#!/bin/bash

if [ -e fullrun/db/monitor.db ];then
sqlite3 fullrun/db/monitor.db << EOF
.header on
.mode column
select * from servers order by start_time desc;
.q
EOF
fi

Modified tree.scm from [e7e38b65a4] to [02f8628298].

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
		  (if (> depth node-depth) ;; (+ 1 node-depth))
		      #f
		      (loop hed tal depth (+ nodenum 1)))))
	    #f))))

;; top is the top node name zeroeth node VALUE=0
(define (tree:add-node obj top nodelst #!key (userdata #f))

  (if (not (iup:attribute obj "TITLE0"))
      (iup:attribute-set! obj "ADDBRANCH0" top))
  (cond
   ((not (string=? top (iup:attribute obj "TITLE0")))
    (print "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0")))
   ((null? nodelst))
   (else
    (let loop ((hed      (car nodelst))
	       (tal      (cdr nodelst))
	       (depth    1)
	       (pathl    (list top)))
      ;; Because the tree dialog changes node numbers when
      ;; nodes are added or removed we must look up nodes
      ;; each and every time. 0 is the top node so default
      ;; to that.
      (let* ((newpath    (append pathl (list hed)))
	     (parentnode (tree:find-node obj pathl))
	     (nodenum    (tree:find-node obj newpath)))
	;; Add the branch under lastnode if not found
	(if (not nodenum)
	    (begin
	      (iup:attribute-set! obj (conc "ADDBRANCH" parentnode) hed)

	      (if userdata
		  (iup:attribute-set! obj (conc "USERDATA"   parentnode) userdata))
	      (if (null? tal)
		  #t
		  ;; reset to top
		  (loop (car nodelst)(cdr nodelst) 1 (list top)))) 
	    (if (null? tal) ;; if null here then this path has already been added







>
|


|


















>







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
		  (if (> depth node-depth) ;; (+ 1 node-depth))
		      #f
		      (loop hed tal depth (+ nodenum 1)))))
	    #f))))

;; top is the top node name zeroeth node VALUE=0
(define (tree:add-node obj top nodelst #!key (userdata #f))
  (if (or (not (string? (iup:attribute obj "TITLE0")))
	  (string-null? (iup:attribute obj "TITLE0")))
      (iup:attribute-set! obj "ADDBRANCH0" top))
  (cond
   ((not (equal? top (iup:attribute obj "TITLE0")))
    (print "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0")))
   ((null? nodelst))
   (else
    (let loop ((hed      (car nodelst))
	       (tal      (cdr nodelst))
	       (depth    1)
	       (pathl    (list top)))
      ;; Because the tree dialog changes node numbers when
      ;; nodes are added or removed we must look up nodes
      ;; each and every time. 0 is the top node so default
      ;; to that.
      (let* ((newpath    (append pathl (list hed)))
	     (parentnode (tree:find-node obj pathl))
	     (nodenum    (tree:find-node obj newpath)))
	;; Add the branch under lastnode if not found
	(if (not nodenum)
	    (begin
	      (iup:attribute-set! obj (conc "ADDBRANCH" parentnode) hed)
		;; ERROR? ADDING DATA TO PARENT, DONT WE WANT IT ON CREATED NODE?
	      (if userdata
		  (iup:attribute-set! obj (conc "USERDATA"   parentnode) userdata))
	      (if (null? tal)
		  #t
		  ;; reset to top
		  (loop (car nodelst)(cdr nodelst) 1 (list top)))) 
	    (if (null? tal) ;; if null here then this path has already been added
109
110
111
112
113
114
115
116
























			   (take path node-depth)
			   path))
	   (newpath    (append trimpath (list node-title))))
      (if (>= currnode nodenum)
	  newpath
	  (loop (+ currnode 1)
		newpath)))))
	































|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
			   (take path node-depth)
			   path))
	   (newpath    (append trimpath (list node-title))))
      (if (>= currnode nodenum)
	  newpath
	  (loop (+ currnode 1)
		newpath)))))

(define (tree:delete-node obj top node-path) ;; node-path is a list of strings
  (let ((id  (tree:find-node obj (cons top node-path))))
    (print "Found node to remove " id " for path " top " " node-path)
    (iup:attribute-set! obj (conc "DELNODE" id) "SELECTED")))
	
#|

  (let* ((tb      (iup:treebox
                   #:value 0
                   #:name "Runs"
                   #:expand "YES"
                   #:addexpanded "NO"
                   #:selection-cb
                   (lambda (obj id state)
                     ;; (print "obj: " obj ", id: " id ", state: " state)
                     (let* ((run-path (tree:node->path obj id))
                            (run-id   (tree-path->run-id (cdr run-path))))
                       (if run-id
                           (begin
                             (dboard:data-set-curr-run-id! *data* run-id)
                             (dashboard:update-run-summary-tab)))
                       ;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
                       ))))
|#

Modified txtdb/nada3/RunsToLock.dat from [9e39b39de9] to [5d15c8e35d].

1

2
3
4
5
6
7
8
[def]

ghi jkl
qrst 
uvwx 
yz12 

[mno]
abc 

>







1
2
3
4
5
6
7
8
9
[def]
def def
ghi jkl
qrst 
uvwx 
yz12 

[mno]
abc 

Deleted txtdb/txtdb.scm version [e82989d975].

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

;; Copyright 2006-2013, 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.

(use ssax)
(use sxml-serializer)
(use sxml-modifications)
(use regex)
(use srfi-69)
(use regex-case)
(use posix)
(use json)
(use csv)
(use srfi-18)

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

;; Read a non-compressed gnumeric file
(define (refdb:read-gnumeric-xml fname)
  (with-input-from-file fname
    (lambda ()
      (ssax:xml->sxml (current-input-port) '()))))

(define (find-section dat section #!key (depth 0))
  (let loop ((hed   (car dat))
	     (tal   (cdr dat)))   
    (if (list? hed)
	(let ((res (find-section hed section depth: (+ depth 1))))
	  (if res 
	      res
	      (if (null? tal)
		  #f
		  (loop (car tal)(cdr tal)))))
	(if (eq? hed section)
	    tal
	    (if (null? tal)
		#f
		(loop (car tal)(cdr tal)))))))

(define (remove-section dat section)
  (if (null? dat)
      '()
      (let loop ((hed (car dat))
		 (tal (cdr dat))
		 (res '()))
	(let ((newres (if (and (list? hed)
			       (not (null? hed))
			       (equal? (car hed) section))
			  res
			  (cons hed res))))
	  (if (null? tal)
	      (reverse newres)
	      (loop (car tal)(cdr tal) newres))))))

(define (list-sections dat)
  (filter (lambda (x)(and x))
	  (map (lambda (section)
		 (if (and (list? section)
			  (not (null? section)))
		     (car section)
		     #f))
	       dat)))

(define (string->safe-filename str)
  (string-substitute (regexp " ") "_" str #t))

(define (sheet->refdb dat targdir)
  (let* ((comment-rx  (regexp "^#CMNT\\d+\\s*"))
	 (blank-rx    (regexp "^#BLNK\\d+\\s*"))
	 (sheet-name  (car (find-section dat 'http://www.gnumeric.org/v10.dtd:Name)))
	 ;; (safe-name   (string->safe-filename sheet-name))
	 (cells       (find-section dat 'http://www.gnumeric.org/v10.dtd:Cells))
	 (remaining   (remove-section (remove-section dat 'http://www.gnumeric.org/v10.dtd:Name)
				      'http://www.gnumeric.org/v10.dtd:Cells))
	 (rownums     (make-hash-table))  ;; num -> name
	 (colnums     (make-hash-table))  ;; num -> name
	 (cols        (make-hash-table))  ;; name -> ( (name val) ... )
	 (col0title   ""))
    (for-each (lambda (cell)
		(let ((rownum  (string->number (car (find-section cell 'Row))))
		      (colnum  (string->number (car (find-section cell 'Col))))
		      (valtype (let ((res (find-section cell 'ValueType)))
				 (if res (car res) #f)))
		      (value   (let ((res (cdr (filter (lambda (x)(not (list? x))) cell))))
				 (if (null? res) "" (car res)))))
		  ;; If colnum is 0 Then this is a row name, if rownum is 0 then this is a col name
		  (cond
		   ((and (not (eq? 0 rownum))
			 (eq? 0 colnum)) ;; a blank in column zero is handled with the special name "row-N"
		    (hash-table-set! rownums rownum (if (equal? value "")
							(conc "row-" rownum)
							value)))
		   ((and (not (eq? 0 colnum))
			 (eq? 0 rownum))
		    (hash-table-set! colnums colnum (if (equal? value "")
							(conc "col-" colnum)
							value)))
		   ((and (eq? 0 rownum)
			 (eq? 0 colnum))
		    (set! col0title value))
		   (else
		    (let ((colname (hash-table-ref/default colnums colnum (conc "col-" colnum)))
			  (rowname (hash-table-ref/default rownums rownum (conc "row-" rownum))))
		      (hash-table-set! cols colname (cons (list rowname value) 
							  (hash-table-ref/default cols colname '()))))))))
	      cells)
    (let ((ref-colnums (map (lambda (c)
			      (list (cdr c)(car c)))
			    (hash-table->alist colnums))))
      (with-output-to-file (conc targdir "/" sheet-name ".dat")
	(lambda ()
	  (if (not (string-null? col0title))(print "[" col0title "]"))
	  (for-each (lambda (colname)
		      (print "[" colname "]")
		      (for-each (lambda (row)
				  (let ((key (car row))
					(val (cadr row)))
				    (if (string-search comment-rx key)
					(print val)
					(if (string-search blank-rx key)
					    (print)
					    (if (string-search " " key)
						(print "\"" key "\" " val)
						(print key " " val))))))
				(reverse (hash-table-ref cols colname)))
		      ;; (print)
		      )
		    (sort (hash-table-keys cols)(lambda (a b)
						  (let ((colnum-a (assoc a ref-colnums))
							(colnum-b (assoc b ref-colnums)))
						    (if (and colnum-a colnum-b)
							(< (cadr colnum-a)(cadr colnum-b))
							(if (and (string? a)
								 (string? b))
							    (string< a b))))))))))
    (with-output-to-file (conc targdir "/sxml/" sheet-name ".sxml")
      (lambda ()
	(pp remaining)))
    sheet-name))

(define (sxml->file dat fname)
  (with-output-to-file fname
    (lambda ()
      ;; (print (sxml-serializer#serialize-sxml dat))
      (pp dat))))

(define (file->sxml fname)
  (let ((res (read-file fname read)))
    (if (null? res)
	(begin
	  (print "ERROR: file " fname " is malformed for read")
	  #f)
	(car res))))

(define (replace-sheet-name-index indat sheets)
  (let* ((rem-dat  (remove-section indat 'http://www.gnumeric.org/v10.dtd:SheetNameIndex))
	 (one-sht  (find-section rem-dat 'http://www.gnumeric.org/v10.dtd:SheetName)) ;; for the future if I ever decide to do this "right"
	 (mk-entry (lambda (sheet-name)
		     (append '(http://www.gnumeric.org/v10.dtd:SheetName
			       (@ (http://www.gnumeric.org/v10.dtd:Rows "65536")
				  (http://www.gnumeric.org/v10.dtd:Cols "256")))
			     (list sheet-name))))
	 (new-indx-values (map mk-entry sheets)))
    (append rem-dat (list (cons 'http://www.gnumeric.org/v10.dtd:SheetNameIndex
				new-indx-values)))))
    
    
;; Write an sxml gnumeric workbook to a refdb directory structure.
;;
(define (extract-refdb dat targdir)
  (create-directory (conc targdir "/sxml") #t)
  (let* ((wrkbk       (find-section   dat   'http://www.gnumeric.org/v10.dtd:Workbook))
	 (wrk-rem     (remove-section dat   'http://www.gnumeric.org/v10.dtd:Workbook))
	 (sheets      (find-section   wrkbk 'http://www.gnumeric.org/v10.dtd:Sheets))
	 (sht-rem     (remove-section wrkbk 'http://www.gnumeric.org/v10.dtd:Sheets))
	 (sheet-names (map (lambda (sheet)
			     (sheet->refdb sheet targdir))
			   sheets)))
    (sxml->file wrk-rem (conc targdir "/sxml/_workbook.sxml"))
    (sxml->file sht-rem (conc targdir "/sxml/_sheets.sxml"))
    (with-output-to-file (conc targdir "/sheet-names.cfg")
      (lambda ()
	(map print sheet-names)))))

(define (read-gnumeric-file fname)
  (if (not (string-match (regexp ".*.gnumeric$") fname))
      (begin
	(print "ERROR: Attempt to import gnumeric file with extention other than .gnumeric")
	(exit))
      (let ((tmpf (create-temporary-file (pathname-strip-directory fname))))
	(system (conc " gunzip > " tmpf " < " fname))
	(let ((res (refdb:read-gnumeric-xml tmpf)))
	  (delete-file tmpf)
	  res))))

(define (import-gnumeric-file fname targdir)
  (extract-refdb (read-gnumeric-file fname) targdir))

;; Write a gnumeric compressed xml spreadsheet from a refdb directory structure.
;;
(define (refdb-export dbdir fname)
  (let* ((sxml-dat (refdb->sxml dbdir))
	 (tmpf     (create-temporary-file (pathname-strip-directory fname)))
	 (tmpgzf   (conc tmpf ".gz")))
    (with-output-to-file tmpf
      (lambda ()
	(print (sxml-serializer#serialize-sxml sxml-dat ns-prefixes: (list (cons 'gnm "http://www.gnumeric.org/v10.dtd"))))))
    (system (conc "gzip " tmpf))
    (file-copy tmpgzf fname #t)
    (delete-file tmpgzf)))

(define (hash-table-reverse-lookup ht val)
  (hash-table-fold ht (lambda (k v res)(if (equal? v val) k res)) #f))

(define (read-dat fname)
  (let ((section-rx  (regexp "^\\[(.*)\\]\\s*$"))
	(comment-rx  (regexp "^#.*"))          ;; This means a cell name cannot start with #
	(quoted-cell-rx (regexp "^\"([^\"]*)\" (.*)$"))
	(cell-rx     (regexp "^(\\S+) (.*)$")) ;; One space only for the cellname content separator 
	(blank-rx    (regexp "^\\s*$"))
	(continue-rx (regexp ".*\\\\$"))
	(var-no-val-rx (regexp "^(\\S+)\\s*$"))
	(inp         (open-input-file fname))
	(cmnt-indx   (make-hash-table))
	(blnk-indx   (make-hash-table))
	(first-section #f)) ;; used for zeroth title
    (let loop ((inl     (read-line inp))
	       (section ".............")
	       (res     '()))
      (if (eof-object? inl)
	  (begin
	    (close-input-port inp)
	    (cons (list first-section first-section first-section)
		  (reverse res)))
	  (regex-case
	   inl 
	   (continue-rx _         (loop (conc inl (read-line inp)) section res))
	   (comment-rx _          (let ((curr-indx (+ 1 (hash-table-ref/default cmnt-indx section 0))))
				    (hash-table-set! cmnt-indx section curr-indx)
				    (loop (read-line inp)
					  section 
					  (cons (list (conc "#CMNT" curr-indx) section inl) res))))
	   (blank-rx   _          (let ((curr-indx (+ 1 (hash-table-ref/default blnk-indx section 0))))
				    (hash-table-set! blnk-indx section curr-indx)
				    (loop (read-line inp)
					  section
					  (cons (list (conc "#BLNK" curr-indx) section " ") res))))
	   (section-rx (x sname)  (begin
				    (if (not first-section)
					(set! first-section sname))
				    (loop (read-line inp) 
					  sname 
					  res)))
	   (quoted-cell-rx (x k v)(loop (read-line inp)
					section
					(cons (list k section v) res)))
	   (cell-rx   (x k v)     (loop (read-line inp)
					section
					(cons (list k section v) res)))
	   (var-no-val-rx (x k)   (loop (read-line inp)
					section
					(cons (list k section "") res)))
	   (else                  (begin
				    (print "ERROR: Unrecognised line in input file " fname ", ignoring it")
				    (loop (read-line inp) section res))))))))

(define (get-value-type val expressions)
  (cond 
   ((not val)            '(ValueType "60"))
   ((string->number val) '(ValueType "40"))
   ((equal? val "")      '(ValueType "60"))
   ((equal? (substring val 0 1) "=")
    (let ((exid (hash-table-ref/default expressions val #f)))
      (if exid 
	  (list 'ExprID exid)
	  (let* ((values  (hash-table-keys expressions)) ;; note, values are the id numbers
		 (new-max (+ 1 (if (null? values) 0 (apply max values)))))
	    (hash-table-set! expressions val new-max)
	    (list 'ExprID new-max)))))
   (else '(ValueType "60"))))

(define (dat->cells dat)
  (let* ((indx     (common:sparse-list-generate-index (cdr dat)))
	 (row-indx (car indx))
	 (col-indx (cadr indx))
	 (rowdat   (map (lambda (row)(list (car row) "    " (car row))) row-indx))
	 (coldat   (map (lambda (col)(list "    " (car col) (car col))) col-indx))
	 (exprs    (make-hash-table)))
    (list (cons 'http://www.gnumeric.org/v10.dtd:Cells 
		(map (lambda (item)
		       (let* ((row-name (car item))
			      (col-name (cadr item))
			      (row-num  (let ((i (assoc row-name row-indx)))
					  (if i (cadr i) 0))) ;; 0 for the title row/col
			      (col-num  (let ((i (assoc col-name col-indx)))
					  (if i (cadr i) 0)))
			      (value    (caddr item))
			      (val-type (get-value-type value exprs)))
			 (list 'http://www.gnumeric.org/v10.dtd:Cell
			       (list '@ val-type (list 'Row (conc row-num)) (list 'Col (conc col-num)))
			       value)))
		     (append rowdat coldat dat))))))
    
(define (refdb->sxml dbdir)
  (let* ((sht-names (read-file (conc dbdir "/sheet-names.cfg")  read-line))
	 (wrk-rem   (file->sxml (conc dbdir "/sxml/_workbook.sxml")))
	 (sht-rem   (file->sxml (conc dbdir "/sxml/_sheets.sxml")))
	 (sheets    (fold (lambda (sheetname res)
			    (let* ((sheetdat (read-dat (conc dbdir "/" sheetname ".dat")))
				   (cells    (dat->cells sheetdat))
				   (sht-meta (file->sxml (conc dbdir "/sxml/" sheetname ".sxml"))))
			      (cons (cons (car sht-meta) 
					  (append (cons (list 'http://www.gnumeric.org/v10.dtd:Name sheetname)
							(cdr sht-meta))
						  cells))
				    res)))
			  '()
			 (reverse  sht-names))))
    (append wrk-rem (list (append
			   (cons 'http://www.gnumeric.org/v10.dtd:Workbook
				 sht-rem)
			   (list (cons 'http://www.gnumeric.org/v10.dtd:Sheets sheets)))))))

;; (define (

;; 
;; optional apply proc to rownum colnum value
;; 
;; NB// If a change is made to this routine please look also at applying
;;      it to the code in Megatest (http://www.kiatoa.com/fossils/megatest)
;;      in the file common.scm
;;
(define (common:sparse-list-generate-index data #!key (proc #f))
  (if (null? data)
      (list '() '())
      (let loop ((hed (car data))
		 (tal (cdr data))
		 (rownames '())
		 (colnames '())
		 (rownum   0)
		 (colnum   0))
	(let* ((rowkey          (car   hed))
	       (colkey          (cadr  hed))
	       (value           (caddr hed))
	       (existing-rowdat (assoc rowkey rownames))
	       (existing-coldat (assoc colkey colnames))
	       (curr-rownum     (if existing-rowdat rownum (+ rownum 1)))
	       (curr-colnum     (if existing-coldat colnum (+ colnum 1)))
	       (new-rownames    (if existing-rowdat rownames (cons (list rowkey curr-rownum) rownames)))
	       (new-colnames    (if existing-coldat colnames (cons (list colkey curr-colnum) colnames))))
	  ;; (debug:print-info 0 "Processing record: " hed )
	  (if proc (proc curr-rownum curr-colnum rowkey colkey value))
	  (if (null? tal)
	      (list new-rownames new-colnames)
	      (loop (car tal)
		    (cdr tal)
		    new-rownames
		    new-colnames
		    (if (> curr-rownum rownum) curr-rownum rownum)
		    (if (> curr-colnum colnum) curr-colnum colnum)
		    ))))))
(define help
  (conc "Usage: refdb action params ...

Note: refdbdir is a path to the directory containg sheet-names.cfg

  import filename.gnumeric refdbdir   : Import a gnumeric file into a txt db directory
  export refdbdir filename.gnumeric   : Export a refdb to a gnumeric file
  edit   refdbdir                     : Edit a refdbdir using gnumeric.
  ls refdbdir                         : List the keys for specified level 
  lookup refdbdir sheetname row col   : Look up a value in the text db   
  getrownames refdb sheetname         : Get a list of row titles
  getcolnames refdb sheetname         : Get a list of column titles

To export to other formats; first export to gnumeric then use ssconvert.

e.g. 

refdb export mydata mydata.gnumeric
ssconvert -T Gnumeric_html:html40 mydata.gnumeric mydata.html 
  
Part of the Megatest tool suite. Learn more at http://www.kiatoa.com/fossils/megatest

Version: " megatest-fossil-hash))

(define (list-sheets path)
  ;; (cond
  ;;  ((and path (not sheet)(not row)(not col))
  (if (file-exists? path)
      (read-file (conc path "/sheet-names.cfg") read-line)
      '()))
;; ((and path sheet (not row)(not col))

(define (lookup path sheet row col)
  (let ((fname (conc path "/" sheet ".dat")))
    (if (file-exists? fname)
	(let ((dat (read-dat fname)))
	  (if (null? dat)
	      #f
	      (let loop ((hed (car dat))
			 (tal (cdr dat)))
		(if (and (equal? row (car hed))
			 (equal? col (cadr hed)))
		    (caddr hed)
		    (if (null? tal)
			#f
			(loop (car tal)(cdr tal)))))))
	#f)))

;; call with proc = car to get row names
;; call with proc = cadr to get col names
(define (get-rowcol-names path sheet proc)
  (let ((fname (conc path "/" sheet ".dat"))
	(cmnt-rx (regexp "^#CMNT\\d+\\s*"))
	(blnk-rx (regexp "^#BLNK\\d+\\s*")))
    (if (file-exists? fname)
	(let ((dat (read-dat fname)))
	  (if (null? dat)
	      '()
	      (let loop ((hed (car dat))
			 (tal (cdr dat))
			 (res '()))
		(let* ((row-name (proc hed))
		       (newres (if (and (not (member row-name res))
					(not (string-search cmnt-rx row-name))
					(not (string-search blnk-rx row-name)))
				   (cons row-name res)
				   res)))
		  (if (null? tal)
		      (reverse newres)
		      (loop (car tal)(cdr tal) newres))))))
	'())))

;; (define (get-col-names path sheet)
;;   (let ((fname (conc path "/" sheet ".dat")))
;;     (if (file-exists? fname)
;; 	(let ((dat (read-dat fname)))
;; 	  (if (null? dat)
;; 	      #f
;; 	      (map cadr dat))))))

(define (edit-refdb path)
  ;; TEMPORARY, REMOVE IN 2014
  (if (not (file-exists? path)) ;; Create new 
      (begin
	(print "\nINFO: Creating new txtdb at " path "\n")
	(create-new-db path)))
  (if (not (file-exists? (conc path "/sxml/_sheets.sxml")))
      (begin
	(print "ERROR: You appear to have the old file structure for txtdb. Please do the following and try again.")
	(print)
	(print "mv " path "/sxml/sheets.sxml " path "/sxml/_sheets.sxml")
	(print "mv " path "/sxml/workbook.sxml " path "/sxml/_workbook.sxml")
	(print)
	(print "Don't forget to remove the old files from your revision control system and add the new.")
	(exit)))
  (let* ((dbname  (pathname-strip-directory path))
	 (tmpf    (conc (create-temporary-file dbname) ".gnumeric")))
    (if (file-exists? (conc path "/sheet-names.cfg"))
	(refdb-export path tmpf))
    (let* ((pid (process-run "gnumeric" (list tmpf))))
      (let loop ((last-mod-time (current-seconds)))
	(let-values (((pid-code exit-status exit-signal)(process-wait pid #t)))
           (if (eq? pid-code 0) ;; still going
	       (if (file-exists? tmpf)
		   (let ((mod-time (file-modification-time tmpf)))
		     (if (> mod-time last-mod-time)
			 (begin
			   (print "saved data to " path)
			   (import-gnumeric-file tmpf path)))
		     (thread-sleep! 0.5)
		     (loop mod-time))
		   (begin
		     (thread-sleep! 0.5)
		     (loop last-mod-time))))))
      ;; all done
      (print "all done, writing new data to " path)
      (import-gnumeric-file tmpf path)
      (print "data written, exiting refdb edit."))))

;;======================================================================
;; This routine dispaches or executes most of the commands for refdb
;;======================================================================
;;
(define (process-action action-str . param)
  (let ((num-params (length param))
	(action     (string->symbol action-str)))
    (cond
     ((eq? num-params 1)
      (case action
	((edit)
	 (edit-refdb (car param)))
	((ls)
	 (map print (list-sheets (car param))))))
     ((eq? num-params 2)
      (let ((param1 (car param))
	    (param2 (cadr param)))
	(case action
	  ((getrownames) (print (string-intersperse (get-rowcol-names param1 param2 car)  " ")))
	  ((getcolnames) (print (string-intersperse (get-rowcol-names param1 param2 cadr) " ")))
	  ((import)      (import-gnumeric-file param1 param2)) ;; fname targname
	  ((export)      (refdb-export param1 param2))
	  (else (print "Unrecognised command " action)(print help)))))
     ((eq? num-params 4)
      (case action
	((lookup)               ;; path    section     row          col 
	 (let ((res (lookup (car param)(cadr param)(caddr param)(cadddr param))))
	   (if res 
	       (print res)
	       (begin
		 (print "")
		 (exit 1))))))))))

(define (main)
  (let* ((args (argv))
	 (prog (car args))
	 (rema (cdr args)))
    (cond
     ((null? rema)(print help))
     ((eq? (length rema) 1)
      (case (string->symbol (car rema))
	((mtedit) ;; Edit a Megatest area
	 (megatest->refdb))))
     ((>= (length rema) 2)
      (apply process-action (car rema)(cdr rema)))
     (else (print help)))))

;;======================================================================
;;  C R E A T E   N E W   D B S
;;======================================================================

(include "metadat.scm")

;; Creates a new db at path with one sheet
(define (create-new-db path)
  (extract-refdb minimal-sxml path))

;;======================================================================
;; M E G A T E S T   S U P P O R T
;;======================================================================

;; Construct a temporary refdb area from the files in a Megatest area
;; 
;; .refdb
;;      megatest.dat    (from megatest.config)
;;      runconfigs.dat  (from runconfigs.config)
;;      tests_test1.dat (from tests/test1/testconfig)
;; etc.
;;

(define (make-sheet-meta-if-needed fname)
  (if (not (file-exists? fname))
      (sxml->file sheet-meta fname)))

(define (megatest->refdb)
  (if (not (file-exists? "megatest.config")) ;; must be at top of Megatest area
      (begin
	(print "ERROR: Must be at top of Megatest area to edit")
	(exit)))
  (create-directory ".refdb/sxml" #t)
  (if (not (file-exists? ".refdb/sxml/_workbook.sxml"))
      (sxml->file workbook-meta  ".refdb/sxml/_workbook.sxml"))
  (file-copy "megatest.config" ".refdb/megatest.dat" #t)
  (make-sheet-meta-if-needed ".refdb/sxml/megatest.sxml")
  (file-copy "runconfigs.config" ".refdb/runconfigs.dat" #t)
  (make-sheet-meta-if-needed ".refdb/sxml/runconfigs.sxml")
  (let ((testnames '()))
    (for-each (lambda (tdir)
		(let* ((testname (pathname-strip-directory tdir))
		       (tconfig  (conc tdir "/testconfig"))
		       (metafile (conc ".refdb/sxml/" testname ".sxml")))
		  (if (file-exists? tconfig)
		      (begin
			(set! testnames (append testnames (list testname)))
			(file-copy tconfig (conc ".refdb/" testname ".dat") #t)
			(make-sheet-meta-if-needed metafile)))))
	      (glob "tests/*"))
    (let ((sheet-names (append (list "megatest" "runconfigs") testnames)))
      (if (not (file-exists? ".refdb/sxml/_sheets.sxml"))
	  (sxml->file (replace-sheet-name-index sheets-meta sheet-names) ".refdb/sxml/_sheets.sxml"))
      (with-output-to-file ".refdb/sheet-names.cfg"
	(lambda ()
	  (map print sheet-names))))))
  
(let ((dotfile (conc (get-environment-variable "HOME") "/.txtdbrc")))
  (if (file-exists? dotfile)
      (load dotfile)))

(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.refdbrc")))
  (if (file-exists? debugcontrolf)
      (load debugcontrolf)))

(main)

#|  
 (define x (refdb:read-gnumeric-xml "testdata-stripped.xml"))



;; Write out sxml
(with-output-to-file "testdata.sxml" (lambda()(pp x)))


;; (serialize-sxml a output: "new.xml")
(with-output-to-file "testdata-stripped.xml" (lambda ()(print (sxml-serializer#serialize-sxml y))))

;; Read in sxml file
(with-input-from-file "testdata.sxml" (lambda ()(set! y (read))))

(find-section x 'http://www.gnumeric.org/v10.dtd:Workbook)

(define sheets (find-section x 'http://www.gnumeric.org/v10.dtd:Sheets))

(define sheet1 (car sheets))
(define cells-sheet1 (find-section sheet1 'http://www.gnumeric.org/v10.dtd:Cells))
(map (lambda (c)(find-section c 'Row)) cells-sheet1)

(for-each (lambda (cell)
	    (let* ((len (length cell))
		   (row (car (find-section cell 'Row)))
		   (col (car (find-section cell 'Col)))
		   (val (let ((res (cdr (filter (lambda (x)(not (list? x))) cell))))
			  (if (null? res) "" (car res)))))
	      (print "Row=" row " col=" col " val=" val)))
	  cells-sheet1)


(map (lambda (c)(filter (lambda (x)(not (list? x))) c)) cells-sheet1)
|#
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Modified utils/Makefile.installall from [3d28c758b8] to [64d1b3ca85].

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

# Copyright 2013, 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.



help :
	@echo You may need to do the following first:
	@echo sudo apt-get install libreadline-dev
	@echo sudo apt-get install libwebkitgtk-dev 
	@echo sudo apt-get install libmotif3 -OR- set KTYPE=26g4
	@echo KTYPE can be 26, 26g4, or 32
	@echo KTYPE=$KTYPE
	@echo You are using PREFIX=$PREFIX
	@echo You are using proxy="$(proxy)"
	@echo If needed set proxy to host.dom:port
	@echo 
	@echo "Set additional_libpath to help find gtk or other libraries, don't forget a leading :"
	@echo ADDITIONAL_LIBPATH=$(ADDITIONAL_LIBPATH)
	@echo  
	@echo To use previous IUP libraries set USEOLDIUP to yes
	@echo USEOLDIUP=$(USEOLDIUP)
	@echo 

	@echo To make all do: make all


# Put the installation here
ifeq ($(PREFIX),)
PREFIX=$(PWD)/target
endif

# Set this on the command line of your make call if needed: make PROXY=host.com:1234
PROXY=

# Select IUP library type
KTYPE=26g4

# Select version of chicken, sqlite3 etc
CHICKEN_VERSION=4.8.0
SQLITE3_VERSION=3071401





# Eggs to install (straightforward ones)
EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \
     dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \
     json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \
     spiffy-directory-listing ssax sxml-serializer sxml-modifications


#
# Derived variables
#

ifeq ($(PROXY),)
PROX=
else
http_proxy=http://$(PROXY)
PROX="-proxy $(PROXY)"
endif

BUILDHOME=$(PWD)
PATH:=$(PREFIX)/bin:$(PATH)
LIBPATH=$(PREFIX)/lib$(ADDITIONAL_LIBPATH)
LD_LIBRARY_PATH=$(LIBPATH)
CHICKEN_INSTALL=$(PREFIX)/bin/chicken-install

|








>
>



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

>
|
>









<
<
<

|
|
>
>
>
>





|
>






|

|
|







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

# Copyright 2013,2014 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.

# make PREFIX=/mfs/pkgs/chicken/chicken-core all

help :
	@echo You may need to do the following first:
	@echo sudo apt-get install libreadline-dev
	@echo sudo apt-get install libwebkitgtk-dev libfreetype6-dev libx11-dev libxpm-dev libxmu-dev libxft-dev libgtk2.0-dev libgl1-mesa-dev libglu1-mesa-dev libpangox-1.0-dev bison
	@echo sudo apt-get install libmotif3

	@echo For IUP set IUPBRANCH, currently $(IUPBRANCH)
	@echo You are using PREFIX=$(PREFIX)
	@echo You are using PROXY="$(PROXY)"
	@echo If needed set PROXY to host.dom:port
	@echo   http_proxy=$(http_proxy)

	@echo   PROX=$(PROX)
	@echo 
	@echo To make all do: make all

	@echo 
	@echo Note: might need to do CSC_OPTIONS='-C "-fPIC"' make

# FPIC=-C "-fPIC"

# Put the installation here
ifeq ($(PREFIX),)
PREFIX=$(PWD)/target
endif

# Set this on the command line of your make call if needed: make PROXY=host.com:1234
PROXY=




# Select version of chicken, sqlite3 etc
CHICKEN_VERSION=4.9.0.1
SQLITE3_VERSION=3080500
# http://www.sqlite.org/2014/sqlite-autoconf-3080500.tar.gz

# Override IUPBRANCH to use other than trunk
IUPBRANCH=iup-3.10.1

# Eggs to install (straightforward ones)
EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \
     dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \
     json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \
     spiffy-directory-listing ssax sxml-serializer sxml-modifications sql-de-lite \
     srfi-19 refdb ini-file sparse-vectors z3

#
# Derived variables
#

ifeq ($(PROXY),)
PROX:=
else
http_proxy:=http://$(PROXY)
PROX:=-proxy $(PROXY)
endif

BUILDHOME=$(PWD)
PATH:=$(PREFIX)/bin:$(PATH)
LIBPATH=$(PREFIX)/lib$(ADDITIONAL_LIBPATH)
LD_LIBRARY_PATH=$(LIBPATH)
CHICKEN_INSTALL=$(PREFIX)/bin/chicken-install
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
ISARCHX86_64=$(shell uname -a | grep x86_64)
ifeq ($(ISARCHX86_64),)
ARCHSIZE=
else
ARCHSIZE=64_
endif

IUPFILES=cd-5.5.1_Linux$(KTYPE)_$(ARCHSIZE)lib.tar.gz im-3.8_Linux$(KTYPE)_$(ARCHSIZE)lib.tar.gz iup-3.6_Linux$(KTYPE)_$(ARCHSIZE)lib.tar.gz
CSCLIBS=$(shell echo $(LD_LIBRARY_PATH) | sed 's/:/ -L/g')

CSC_OPTIONS=-I$(PREFIX)/include -L$(CSCLIBS)

all : chkn eggs libiup sqlite3 logprobin mutils

chkn : $(CHICKEN_INSTALL)

eggs : $(EGGSOFILES)

sqlite3 :  $(CHICKEN_EGG_DIR)/sqlite3.so

libiup : $(PREFIX)/lib/libavcall.a $(CHICKEN_EGG_DIR)/iup.so $(CHICKEN_EGG_DIR)/canvas-draw.so

logprobin : $(PREFIX)/bin/logpro

$(PREFIX)/bin/logpro : $(CHICKEN_EGG_DIR)/regex-literals.so
	$(CHICKEN_INSTALL) logpro

# Silly rule to make installing eggs more makeish, I don't understand why I need the basename
$(CHICKEN_EGG_DIR)/%.so : eggflags/%.flag
	$(CHICKEN_INSTALL) $(PROX) $(shell basename $*)

$(EGGFLAGS) : # $(CHICKEN_INSTALL)
	mkdir -p eggflags
	touch $(EGGFLAGS)

# some setup stuff
#
setup-chicken4x.sh : $(EGGFLAGS)
	(echo "export PATH=$(PATH)" > setup-chicken4x.sh)
	(echo "export LD_LIBRARY_PATH=$(LD_LIBRARY_PATH)" >> setup-chicken4x.sh)
	mkdir -p $(PREFIX)

# Download chicken source
chicken-$(CHICKEN_VERSION).tar.gz : 
	wget http://code.call-cc.org/releases/$(CHICKEN_VERSION)/chicken-$(CHICKEN_VERSION).tar.gz

# NB// Must touch csi.scm since tar puts original date on it and deps are wrong then


chicken-$(CHICKEN_VERSION)/csi.scm : chicken-$(CHICKEN_VERSION).tar.gz
	tar xfvz chicken-$(CHICKEN_VERSION).tar.gz

	touch -c chicken-$(CHICKEN_VERSION)/csi.scm



$(CHICKEN_INSTALL) : chicken-$(CHICKEN_VERSION)/csi.scm setup-chicken4x.sh
	cd chicken-$(CHICKEN_VERSION);make PLATFORM=linux PREFIX=$(PREFIX)
	cd chicken-$(CHICKEN_VERSION);make PLATFORM=linux PREFIX=$(PREFIX) install





sqlite-autoconf-$(SQLITE3_VERSION).tar.gz : 
	wget http://www.sqlite.org/sqlite-autoconf-$(SQLITE3_VERSION).tar.gz

sqlite-autoconf-$(SQLITE3_VERSION) : sqlite-autoconf-$(SQLITE3_VERSION).tar.gz
	tar xfz sqlite-autoconf-$(SQLITE3_VERSION).tar.gz 

$(PREFIX)/bin/sqlite3 : sqlite-autoconf-$(SQLITE3_VERSION)
	(cd sqlite-autoconf-$(SQLITE3_VERSION);./configure --prefix=$(PREFIX);make;make install)

$(CHICKEN_EGG_DIR)/sqlite3.so : $(PREFIX)/bin/sqlite3
	CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) sqlite3




mutils : $(CHICKEN_EGG_DIR)/margs.so $(CHICKEN_EGG_DIR)/qtree.so # $(CHICKEN_EGG_DIR)/dbi.so 





# Get and install my various utilities that haven't been eggified yet.


opensrc/margs/margs.scm opensrc/dbi/dbi.scm opensrc/qtree/qtree.scm : $(CHICKEN_INSTALL) $(CHICKEN_EGG_DIR)/sqlite3.so













	mkdir -p opensrc
	cd opensrc;if [ ! -e opensrc.fossil ]; then fossil clone http://www.kiatoa.com/fossils/opensrc opensrc.fossil; fi
	cd opensrc;if [ -e dbi/dbi.scm ]; then fossil update; else fossil open opensrc.fossil; fi

$(CHICKEN_EGG_DIR)/dbi.so : opensrc/dbi/dbi.scm 
	cd opensrc/dbi;chicken-install

$(CHICKEN_EGG_DIR)/margs.so : opensrc/margs/margs.scm
	cd opensrc/margs;chicken-install

$(CHICKEN_EGG_DIR)/qtree.so : opensrc/qtree/qtree.scm
	cd opensrc/qtree;chicken-install




# 



# IUP


#




ffcall.tar.gz :
	wget http://www.kiatoa.com/matt/iup/ffcall.tar.gz 

ffcall/README : ffcall.tar.gz
	tar xfvz ffcall.tar.gz

	touch -c ffcall/README


$(PREFIX)/lib/libavcall.a : ffcall/README
	cd ffcall;./configure --prefix=$(PREFIX) --enable-shared && make && make install



$(IUPFILES) :



	wget http://www.kiatoa.com/matt/iup/$@


	cd $(PREFIX)/lib;tar xfvz $(BUILDHOME)/$@
	mv $(PREFIX)/lib/include/* $(PREFIX)/include


$(PREFIX)/lib/libiup.so : $(IUPFILES)
	touch -c $(PREFIX)/lib/libiup.so

$(CHICKEN_EGG_DIR)/iup.so : $(PREFIX)/lib/libiup.so
	$(CHICKEN_INSTALL) $(PROX) -D no-library-checks -feature disable-iup-web iup

$(CHICKEN_EGG_DIR)/canvas-draw.so :  $(PREFIX)/lib/libiup.so
	$(CHICKEN_INSTALL) $(PROX) -D no-library-checks canvas-draw


clean :
	rm -rf chicken-4.8.0 eggflags ffcall sqlite-autoconf-$(SQLITE3_VERSION)







<

>
|

|





<
|
|








|












|
|
|

|
>
>
|
|
>
|
>
>

|
|
|

>
>
>
>
|
|

|
|

|
|

|


>
>
>
|
>
>

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

<
|

|
|

|
|

|
|

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

|
|

|
|
>
|
>
|



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

|
|


|


|
>



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
ISARCHX86_64=$(shell uname -a | grep x86_64)
ifeq ($(ISARCHX86_64),)
ARCHSIZE=
else
ARCHSIZE=64_
endif


CSCLIBS=$(shell echo $(LD_LIBRARY_PATH) | sed 's/:/ -L/g')
CSC_OPTIONS="-I$(PREFIX)/include -L$(CSCLIBS) -C \"-fPIC\""
# CSC_OPTIONS=-I$(PREFIX)/include -L$(CSCLIBS)

all : chkn eggs libiup logprobin $(PREFIX)/lib/sqlite3.so $(PREFIX)/bin/hs $(PREFIX)/lib/chicken/7/mutils.so

chkn : $(CHICKEN_INSTALL)

eggs : $(EGGSOFILES)


# libiup : $(PREFIX)/lib/libavcall.a 
libiup : $(CHICKEN_EGG_DIR)/iup.so $(CHICKEN_EGG_DIR)/canvas-draw.so

logprobin : $(PREFIX)/bin/logpro

$(PREFIX)/bin/logpro : $(CHICKEN_EGG_DIR)/regex-literals.so
	$(CHICKEN_INSTALL) logpro

# Silly rule to make installing eggs more makeish, I don't understand why I need the basename
$(CHICKEN_EGG_DIR)/%.so : eggflags/%.flag
	$(CHICKEN_INSTALL) $(PROX) -keep-installed $(shell basename $*)

$(EGGFLAGS) : # $(CHICKEN_INSTALL)
	mkdir -p eggflags
	touch $(EGGFLAGS)

# some setup stuff
#
setup-chicken4x.sh : $(EGGFLAGS)
	(echo "export PATH=$(PATH)" > setup-chicken4x.sh)
	(echo "export LD_LIBRARY_PATH=$(LD_LIBRARY_PATH)" >> setup-chicken4x.sh)
	mkdir -p $(PREFIX)

chicken-core/chicken.scm : chicken-$(CHICKEN_VERSION).tar.gz
	tar xfz chicken-$(CHICKEN_VERSION).tar.gz
	ln -sf chicken-$(CHICKEN_VERSION) chicken-core


chicken-4.9.0rc1.tar.gz : 
	wget http://code.call-cc.org/dev-snapshots/2014/04/17/chicken-4.9.0rc1.tar.gz

chicken-4.9.0.1.tar.gz :
	wget http://code.call-cc.org/releases/4.9.0/chicken-4.9.0.1.tar.gz

# git clone git://code.call-cc.org/chicken-core
# git clone http://code.call-cc.org/git/chicken-core.git

$(CHICKEN_INSTALL) : chicken-core/chicken.scm setup-chicken4x.sh
	cd chicken-core;make PLATFORM=linux PREFIX=$(PREFIX)
	cd chicken-core;make PLATFORM=linux PREFIX=$(PREFIX) install

#======================================================================
# S Q L I T E 3
#======================================================================

sqlite-autoconf-$(SQLITE3_VERSION).tar.gz :
	wget  http://www.sqlite.org/2014/sqlite-autoconf-$(SQLITE3_VERSION).tar.gz

sqlite-autoconf-$(SQLITE3_VERSION)/config.log : sqlite-autoconf-$(SQLITE3_VERSION).tar.gz
	tar xfz  sqlite-autoconf-$(SQLITE3_VERSION).tar.gz

$(PREFIX)/bin/sqlite3 : sqlite-autoconf-$(SQLITE3_VERSION)/config.log
	cd sqlite-autoconf-$(SQLITE3_VERSION);./configure --prefix=$(PREFIX);make;make install

$(PREFIX)/lib/sqlite3.so : $(PREFIX)/bin/sqlite3
	CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) sqlite3

#======================================================================
# N  A N O M S G
#======================================================================

nanomsg-0.5-beta.tar.gz :
	wget http://download.nanomsg.org/nanomsg-0.5-beta.tar.gz

nanomsg-0.5-beta/COPYING : nanomsg-0.5-beta.tar.gz
	tar xfvz nanomsg-0.5-beta.tar.gz

$(PREFIX)/bin/nanocat : nanomsg-0.5-beta/COPYING
	cd nanomsg-0.5-beta;./configure --prefix=$(PREFIX);make;make install

$(PREFIX)/lib/nanomsg.so : $(PREFIX)/bin/nanocat
	CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) nanomsg

#======================================================================
# M A T T S   U T I L S
#======================================================================

# opensrc

opensrc.fossil :
	fossil clone http://www.kiatoa.com/fossils/opensrc opensrc.fossil

opensrc/histstore/histstore.scm : opensrc.fossil
	mkdir -p opensrc

	cd opensrc;fossil open ../opensrc.fossil

$(PREFIX)/lib/chicken/7/mutils.so : opensrc/histstore/histstore.scm
	cd opensrc/mutils;chicken-install

opensrc/histstore/hs : opensrc/histstore/histstore.scm chkn eggs $(PREFIX)/lib/sqlite3.so 
	cd opensrc/histstore;$(PREFIX)/bin/csc histstore.scm -o hs

$(PREFIX)/bin/hs : opensrc/histstore/hs 
	cp -f opensrc/histstore/hs $(PREFIX)/bin/hs

# stml
stml.fossil :
	fossil clone http://www.kiatoa.com/fossils/stml stml.fossil

stml/stml.scm : stml.fossil
	mkdir -p stml
	cd stml;fossil open ../stml.fossil

$(PREFIX)/lib/stml.so
	cd stml;chicken-install

#======================================================================
# I U P 
#======================================================================

ffcall.fossil :
	fossil clone http://www.kiatoa.com/fossils/ffcall ffcall.fossil

ffcall/README : ffcall.fossil
	mkdir -p ffcall
	cd ffcall && if [ -e README ];then fossil update; else fossil open ../ffcall.fossil; fi

# NOTE: This worked fine *without* the enable-shared
#
$(PREFIX)/lib/libavcall.a : ffcall/README
	cd ffcall;./configure --prefix=$(PREFIX) --enable-shared && make && make install

iuplib.fossil :
	fossil clone http://www.kiatoa.com/fossils/iuplib iuplib.fossil

iup/installall.sh : iuplib.fossil
	mkdir -p iup
	cd iup && if [ -e installall.sh ];then fossil update $(IUPBRANCH); else fossil open ../iuplib.fossil;fossil update $(IUPBRANCH); fi

iup/alldone : iup/installall.sh $(PREFIX)/include/iup.h $(PREFIX)/lib/libiup.so
	cd iup && ./makeall.sh

$(PREFIX)/lib/libiup.so $(PREFIX)/include/iup.h : iup/installall.sh iup/alldone
	cd iup && ./installall.sh

# $(PREFIX)/lib/libiup.so : iup/iup/alldone
#	touch -c $(PREFIX)/lib/libiup.so

$(CHICKEN_EGG_DIR)/iup.so : $(PREFIX)/lib/libiup.so
	LD_LIBRARY_PATH=$(LD_LIBRARY_PATH) CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks -feature disable-iup-web iup

$(CHICKEN_EGG_DIR)/canvas-draw.so :  $(PREFIX)/lib/libiup.so
	CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks canvas-draw


clean :
	rm -rf chicken-4.8.0 eggflags ffcall sqlite-autoconf-$(SQLITE3_VERSION)

Deleted utils/Makefile_latest.installall version [a5be37ec2b].

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

# Copyright 2013,2014 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.

# make PREFIX=/mfs/pkgs/chicken/chicken-core all

help :
	@echo You may need to do the following first:
	@echo sudo apt-get install libreadline-dev
	@echo sudo apt-get install libwebkitgtk-dev 
	@echo sudo apt-get install libmotif3
	@echo For IUP set IUPBRANCH, currently $(IUPBRANCH)
	@echo You are using PREFIX=$(PREFIX)
	@echo You are using PROXY="$(PROXY)"
	@echo If needed set PROXY to host.dom:port
	@echo   http_proxy=$(http_proxy)
	@echo   PROX=$(PROX)
	@echo 
	@echo To make all do: make all

# Put the installation here
ifeq ($(PREFIX),)
PREFIX=$(PWD)/target
endif

# Set this on the command line of your make call if needed: make PROXY=host.com:1234
PROXY=

# Select version of chicken, sqlite3 etc
CHICKEN_VERSION=4.9.0.1
SQLITE3_VERSION=3080500
# http://www.sqlite.org/2014/sqlite-autoconf-3080500.tar.gz

# Override IUPBRANCH to use other than trunk
IUPBRANCH=iup-3.10.1

# Eggs to install (straightforward ones)
EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \
     dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \
     json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \
     spiffy-directory-listing ssax sxml-serializer sxml-modifications sql-de-lite \
     srfi-19 refdb ini-file

#
# Derived variables
#

ifeq ($(PROXY),)
PROX:=
else
http_proxy:=http://$(PROXY)
PROX:=-proxy $(PROXY)
endif

BUILDHOME=$(PWD)
PATH:=$(PREFIX)/bin:$(PATH)
LIBPATH=$(PREFIX)/lib$(ADDITIONAL_LIBPATH)
LD_LIBRARY_PATH=$(LIBPATH)
CHICKEN_INSTALL=$(PREFIX)/bin/chicken-install
CHICKEN_EGG_DIR=$(PREFIX)/lib/chicken/6

VPATH=$(CHICKEN_EGG_DIR):$(PWD)/eggflags

vpath %.so $(CHICKEN_EGG_DIR)
vpath %.flag eggflags

EGGSOFILES=$(addprefix $(CHICKEN_EGG_DIR)/,$(addsuffix .so,$(EGGS)))
EGGFLAGS=$(addprefix eggflags/,$(addsuffix .flag,$(EGGS)))

# Stuff needed for IUP
ISARCHX86_64=$(shell uname -a | grep x86_64)
ifeq ($(ISARCHX86_64),)
ARCHSIZE=
else
ARCHSIZE=64_
endif

CSCLIBS=$(shell echo $(LD_LIBRARY_PATH) | sed 's/:/ -L/g')
CSC_OPTIONS="-I$(PREFIX)/include -L$(CSCLIBS)"
# CSC_OPTIONS=-I$(PREFIX)/include -L$(CSCLIBS)

all : chkn eggs libiup logprobin $(PREFIX)/lib/sqlite3.so $(PREFIX)/bin/hs

chkn : $(CHICKEN_INSTALL)

eggs : $(EGGSOFILES)

libiup : $(PREFIX)/lib/libavcall.a $(CHICKEN_EGG_DIR)/iup.so $(CHICKEN_EGG_DIR)/canvas-draw.so

logprobin : $(PREFIX)/bin/logpro

$(PREFIX)/bin/logpro : $(CHICKEN_EGG_DIR)/regex-literals.so
	$(CHICKEN_INSTALL) logpro

# Silly rule to make installing eggs more makeish, I don't understand why I need the basename
$(CHICKEN_EGG_DIR)/%.so : eggflags/%.flag
	$(CHICKEN_INSTALL) $(PROX) -keep-installed $(shell basename $*)

$(EGGFLAGS) : # $(CHICKEN_INSTALL)
	mkdir -p eggflags
	touch $(EGGFLAGS)

# some setup stuff
#
setup-chicken4x.sh : $(EGGFLAGS)
	(echo "export PATH=$(PATH)" > setup-chicken4x.sh)
	(echo "export LD_LIBRARY_PATH=$(LD_LIBRARY_PATH)" >> setup-chicken4x.sh)
	mkdir -p $(PREFIX)

chicken-core/chicken.scm : chicken-$(CHICKEN_VERSION).tar.gz
	tar xfz chicken-$(CHICKEN_VERSION).tar.gz
	ln -sf chicken-$(CHICKEN_VERSION) chicken-core


chicken-4.9.0rc1.tar.gz : 
	wget http://code.call-cc.org/dev-snapshots/2014/04/17/chicken-4.9.0rc1.tar.gz

chicken-4.9.0.1.tar.gz :
	wget http://code.call-cc.org/releases/4.9.0/chicken-4.9.0.1.tar.gz

# git clone git://code.call-cc.org/chicken-core
# git clone http://code.call-cc.org/git/chicken-core.git

$(CHICKEN_INSTALL) : chicken-core/chicken.scm setup-chicken4x.sh
	cd chicken-core;make PLATFORM=linux PREFIX=$(PREFIX)
	cd chicken-core;make PLATFORM=linux PREFIX=$(PREFIX) install

#======================================================================
# S Q L I T E 3
#======================================================================

sqlite-autoconf-$(SQLITE3_VERSION).tar.gz :
	wget  http://www.sqlite.org/2014/sqlite-autoconf-$(SQLITE3_VERSION).tar.gz

sqlite-autoconf-$(SQLITE3_VERSION)/config.log : sqlite-autoconf-$(SQLITE3_VERSION).tar.gz
	tar xfz  sqlite-autoconf-$(SQLITE3_VERSION).tar.gz

$(PREFIX)/bin/sqlite3 : sqlite-autoconf-$(SQLITE3_VERSION)/config.log
	cd sqlite-autoconf-$(SQLITE3_VERSION);./configure --prefix=$(PREFIX);make;make install

$(PREFIX)/lib/sqlite3.so : $(PREFIX)/bin/sqlite3
	CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) sqlite3

#======================================================================
# M A T T S   U T I L S
#======================================================================

opensrc.fossil :
	fossil clone http://www.kiatoa.com/fossils/opensrc opensrc.fossil

opensrc/histstore/histstore.scm : opensrc.fossil
	mkdir -p opensrc
	cd opensrc;fossil open ../opensrc.fossil

opensrc/histstore/hs : opensrc/histstore/histstore.scm chkn eggs $(PREFIX)/lib/sqlite3.so 
	cd opensrc/histstore;$(PREFIX)/bin/csc histstore.scm -o hs

$(PREFIX)/bin/hs : opensrc/histstore/hs 
	cp -f opensrc/histstore/hs $(PREFIX)/bin/hs

#======================================================================
# I U P 
#======================================================================

ffcall.fossil :
	fossil clone http://www.kiatoa.com/fossils/ffcall ffcall.fossil

ffcall/README : ffcall.fossil
	mkdir -p ffcall
	cd ffcall && if [ -e README ];then fossil update; else fossil open ../ffcall.fossil; fi

# NOTE: This worked fine *without* the enable-shared
#
$(PREFIX)/lib/libavcall.a : ffcall/README
	cd ffcall;./configure --prefix=$(PREFIX) --enable-shared && make && make install

iuplib.fossil :
	fossil clone http://www.kiatoa.com/fossils/iuplib iuplib.fossil

iup/installall.sh : iuplib.fossil
	mkdir -p iup
	cd iup && if [ -e installall.sh ];then fossil update $(IUPBRANCH); else fossil open ../iuplib.fossil;fossil update $(IUPBRANCH); fi

iup/alldone : iup/installall.sh $(PREFIX)/include/iup.h $(PREFIX)/lib/libiup.so
	cd iup && ./makeall.sh

$(PREFIX)/lib/libiup.so $(PREFIX)/include/iup.h : iup/installall.sh iup/alldone
	cd iup && ./installall.sh

# $(PREFIX)/lib/libiup.so : iup/iup/alldone
#	touch -c $(PREFIX)/lib/libiup.so

$(CHICKEN_EGG_DIR)/iup.so : $(PREFIX)/lib/libiup.so
	LD_LIBRARY_PATH=$(LD_LIBRARY_PATH) CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks -feature disable-iup-web iup

$(CHICKEN_EGG_DIR)/canvas-draw.so :  $(PREFIX)/lib/libiup.so
	CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks canvas-draw


clean :
	rm -rf chicken-4.8.0 eggflags ffcall sqlite-autoconf-$(SQLITE3_VERSION)
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































































































































































































































































































Modified utils/installall.sh from [1a414abc38] to [504497f8ec].

10
11
12
13
14
15
16

17
18
19
20
21
22
23
#  This program is distributed WITHOUT ANY WARRANTY; without even the
#  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
#  PURPOSE.

echo You may need to do the following first:
echo sudo apt-get install libreadline-dev
echo sudo apt-get install libwebkitgtk-dev 

echo sudo apt-get install libmotif3 -OR- set KTYPE=26g4
echo KTYPE can be 26, 26g4, or 32
echo  
echo KTYPE=$KTYPE
echo You are using PREFIX=$PREFIX
echo You are using proxy="$proxy"
echo 







>







10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
#  This program is distributed WITHOUT ANY WARRANTY; without even the
#  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
#  PURPOSE.

echo You may need to do the following first:
echo sudo apt-get install libreadline-dev
echo sudo apt-get install libwebkitgtk-dev 
echo sudo apt-get install libssl-dev
echo sudo apt-get install libmotif3 -OR- set KTYPE=26g4
echo KTYPE can be 26, 26g4, or 32
echo  
echo KTYPE=$KTYPE
echo You are using PREFIX=$PREFIX
echo You are using proxy="$proxy"
echo 
97
98
99
100
101
102
103

104
105
106
107
108
109
110
111
    make PLATFORM=linux PREFIX=$PREFIX
    make PLATFORM=linux PREFIX=$PREFIX install
    cd $BUILDHOME
fi

# Some eggs are quoted since they are reserved to Bash
# for f in matchable readline apropos base64 regex-literals format "regex-case" "test" coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp rpc csv-xml fmt json md5; do

$CHICKEN_INSTALL $PROX -keep-installed matchable readline apropos base64 regex-literals format "regex-case" "test" coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp rpc csv-xml fmt json md5 awful http-client spiffy uri-common intarweb http-client spiffy-request-vars spiffy-directory-listing ssax sxml-serializer sxml-modifications logpro
#   if ! [[ -e $PREFIX/lib/chicken/6/$f.so ]];then
#     $CHICKEN_INSTALL $PROX $f
#     # $CHICKEN_INSTALL -deploy -prefix $DEPLOYTARG $PROX $f
#   else
#     echo Skipping install of egg $f as it is already installed
#   fi
# done







>
|







98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
    make PLATFORM=linux PREFIX=$PREFIX
    make PLATFORM=linux PREFIX=$PREFIX install
    cd $BUILDHOME
fi

# Some eggs are quoted since they are reserved to Bash
# for f in matchable readline apropos base64 regex-literals format "regex-case" "test" coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp rpc csv-xml fmt json md5; do
# $CHICKEN_INSTALL $PROX -keep-installed matchable readline apropos base64 regex-literals format "regex-case" "test" coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp rpc csv-xml fmt json md5 awful http-client spiffy uri-common intarweb http-client spiffy-request-vars md5 message-digest http-client spiffy-directory-listing
$CHICKEN_INSTALL $PROX -keep-installed matchable readline apropos base64 regex-literals format "regex-case" "test" coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp rpc csv-xml fmt json md5 awful http-client spiffy uri-common intarweb http-client spiffy-request-vars s md5 message-digest piffy-directory-listing ssax sxml-serializer sxml-modifications logpro
#   if ! [[ -e $PREFIX/lib/chicken/6/$f.so ]];then
#     $CHICKEN_INSTALL $PROX $f
#     # $CHICKEN_INSTALL -deploy -prefix $DEPLOYTARG $PROX $f
#   else
#     echo Skipping install of egg $f as it is already installed
#   fi
# done

Modified utils/mk_wrapper from [7459f2e147] to [a9a7628aaa].

1
2
3
4
5
6
7

8




9




10
11
12
13
14

15

16
17



#!/bin/bash

prefix=$1
cmd=$2
target=$3

if [ "$LD_LIBRARY_PATH" != "" ];then

  echo "INFO: Using LD_LIBRARY_PATH=$LD_LIBRARY_PATH" >&2




  echo "export LD_LIBRARY_PATH=$LD_LIBRARY_PATH" > $prefix/bin/.$(lsb_release -sr)/cfg.sh




else
  echo "INFO: LD_LIBRARY_PATH not set" >&2
fi

echo "#!/bin/bash" > $target

echo "source $prefix/bin/.\$(lsb_release -sr)/cfg.sh" >> $target

echo "exec $prefix/bin/.\$(lsb_release -sr)/$cmd \"\$@\"" >> $target











>

>
>
>
>
|
>
>
>
>




|
>
|
>
|
|
>
>
>
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
#!/bin/bash

prefix=$1
cmd=$2
target=$3

if [ "$LD_LIBRARY_PATH" != "" ];then
  cfgfile="$prefix/bin/.$(lsb_release -sr)/cfg.sh"
  echo "INFO: Using LD_LIBRARY_PATH=$LD_LIBRARY_PATH" >&2
( cat << __EOF
if [ "\$LD_LIBRARY_PATH" != "" ];then
  export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:\$LD_LIBRARY_PATH
else
  export LD_LIBRARY_PATH=$LD_LIBRARY_PATH
fi
__EOF
) > $cfgfile
  echo 
else
  echo "INFO: LD_LIBRARY_PATH not set" >&2
fi

# echo "#!/bin/bash" > $target
# if [ "$LD_LIBRARY_PATH" != "" ];then
#   echo "source $prefix/bin/.\$(lsb_release -sr)/cfg.sh" >> $target
# fi
# echo "exec $prefix/bin/.\$(lsb_release -sr)/$cmd \"\$@\"" >> $target
echo "#!/bin/bash" > $target
echo "lsbr=\$(lsb_release -sr)" >> $target
echo "if [[ -e \$lsbr ]];then source \$lsbr;fi" >> $target
echo "exec $prefix/bin/.\$lsbr/$cmd \"\$@\"" >> $target

Modified utils/mt_ezstep from [94c507b08a] to [6865452478].

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
#!/bin/bash

usage="mt_ezstep stepname prevstepname command [args ...]"

if [ "$MT_CMDINFO" == "" ];then
  if [ -e megatest.sh ];then
    source megatest.sh
  else
    echo "ERROR: $0 should be run within a megatest test environment"
    echo "Usage: $usage"
    exit
  fi
fi

# Purpose: This is for the [ezsteps] secton in your testconfig file.
#   DO NOT USE IN YOUR SCRIPTS!
#
# Call like this:
# mt_ezstep stepname prevstepname command ....
# 
if [ "x$1" == "x" ];then
  echo "Usage: $usage"
  exit
fi

# Since the user may not have . on the path and since we are likely to want to 
# run test scripts in the current directory add the current dir to the path
export PATH=$PATH:$PWD

stepname=$1;shift
prevstepname=$1;shift

command=$*

allstatus=99
runstatus=99
logpropstatus=99

prev_env=.ezsteps/${prevstepname}.sh
if [ -e $prev_env ];then

    source $prev_env
fi

# source the environment from the previous step if it exists

# if a logpro file exists then use it otherwise just run the command, nb// was using 2>&1
if [ -e ${stepname}.logpro ];then
   # could do:
   $command 2>&1| tee ${stepname}.log | logpro ${stepname}.logpro ${stepname}.html &> /dev/null
   logprostatus=$?
   # $command 2>&1| logpro ${stepname}.logpro ${stepname}.html &> ${stepname}.log 
   # allstatus=(${PIPESTATUS[0]} ${PIPESTATUS[1]}) 
   allstatus=(${PIPESTATUS[0]} ${PIPESTATUS[1]})
   runstatus=${allstatus[0]}
   # logprostatus=${allstatus[1]}
else
   $command &> ${stepname}.log
   runstatus=$?
   logprostatus=$runstatus
fi

# If the test exits with non-zero, we will record FAIL even if logpro
# says it is a PASS

if [ $runstatus -ne 0 ]; then
    exitstatus=$runstatus
elif [ $logprostatus -eq 0 ]; then
    exitstatus=$logprostatus
elif [ $logprostatus -eq 2 ]; then
    exitstatus=2
elif [ $logprostatus -eq 1 ]; then
    exitstatus=1
else 
    exitstatus=0
fi

# $MT_MEGATEST -env2file .ezsteps/${stepname}
exit $exitstatus




|
|














|

















|
|
>
|
|




|

















|

|

|

|







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
#!/bin/bash

usage="mt_ezstep stepname prevstepname command [args ...]"

if [[ "$MT_CMDINFO" == "" ]];then
  if [[ -e megatest.sh ]];then
    source megatest.sh
  else
    echo "ERROR: $0 should be run within a megatest test environment"
    echo "Usage: $usage"
    exit
  fi
fi

# Purpose: This is for the [ezsteps] secton in your testconfig file.
#   DO NOT USE IN YOUR SCRIPTS!
#
# Call like this:
# mt_ezstep stepname prevstepname command ....
# 
if [[ "x$1" == "x" ]];then
  echo "Usage: $usage"
  exit
fi

# Since the user may not have . on the path and since we are likely to want to 
# run test scripts in the current directory add the current dir to the path
export PATH=$PATH:$PWD

stepname=$1;shift
prevstepname=$1;shift

command=$*

allstatus=99
runstatus=99
logpropstatus=99

# prev_env=".ezsteps/${prevstepname}.sh"
# echo "prev_env=$prev_env"
# if [[ -e "${prev_env}" ]];then
#     source $prev_env
# fi

# source the environment from the previous step if it exists

# if a logpro file exists then use it otherwise just run the command, nb// was using 2>&1
if [[ -e ${stepname}.logpro ]];then
   # could do:
   $command 2>&1| tee ${stepname}.log | logpro ${stepname}.logpro ${stepname}.html &> /dev/null
   logprostatus=$?
   # $command 2>&1| logpro ${stepname}.logpro ${stepname}.html &> ${stepname}.log 
   # allstatus=(${PIPESTATUS[0]} ${PIPESTATUS[1]}) 
   allstatus=(${PIPESTATUS[0]} ${PIPESTATUS[1]})
   runstatus=${allstatus[0]}
   # logprostatus=${allstatus[1]}
else
   $command &> ${stepname}.log
   runstatus=$?
   logprostatus=$runstatus
fi

# If the test exits with non-zero, we will record FAIL even if logpro
# says it is a PASS

if [[ $runstatus -ne 0 ]]; then
    exitstatus=$runstatus
elif [[ $logprostatus -eq 0 ]]; then
    exitstatus=$logprostatus
elif [[ $logprostatus -eq 2 ]]; then
    exitstatus=2
elif [[ $logprostatus -eq 1 ]]; then
    exitstatus=1
else 
    exitstatus=0
fi

# $MT_MEGATEST -env2file .ezsteps/${stepname}
exit $exitstatus

Modified utils/mt_laststep from [14b0f87d14] to [b984c38ecb].

18
19
20
21
22
23
24
25
26

27
28
29
30
31
32
33
# 
# Example: copy files
# mt_runstep copy_files cp $frompath $topath
#
# Use a copy_files.logpro file like this:
# (expect:error in "LogFileBody" = 0 "Any err/error/warn/warning" #/(err|warn)/)
# 
stepname=$1;shift


# Theoretically could call megatest directly like the following line but
# we'll do each individual step so folks can see what is going on.
#
# $MT_MEGATEST -runstep $stepname -logpro ${stepname}.logpro "$*" || exit $?

# First, register the start of this step
$MT_MEGATEST -step $stepname :state start :status n/a 







|

>







18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
# 
# Example: copy files
# mt_runstep copy_files cp $frompath $topath
#
# Use a copy_files.logpro file like this:
# (expect:error in "LogFileBody" = 0 "Any err/error/warn/warning" #/(err|warn)/)
# 
stepname=$1;shifttepname"

echo "stepname=$s
# Theoretically could call megatest directly like the following line but
# we'll do each individual step so folks can see what is going on.
#
# $MT_MEGATEST -runstep $stepname -logpro ${stepname}.logpro "$*" || exit $?

# First, register the start of this step
$MT_MEGATEST -step $stepname :state start :status n/a 

Modified utils/nbfake from [99a526d022] to [9de79bbac2].

1

2







3


4

5

6






7

8
9
10
11
12






13
14







15
16
























17
18

19
20
#!/bin/bash









# Can't always trust $PWD


CURRWD=`pwd`

if [[ $TARGETHOST_LOGF == "" ]]; then

    TARGETHOST_LOGF=NBFAKE-`date +%GWW%V.%u_%T`






fi

echo "#======================================================================"
echo "# NBFAKE Running command:"
echo "#     \"$*\""
echo "#======================================================================"







if [[ $TARGETHOST == ""  ]]; then
  unset TARGETHOST







  TARGETHOST_LOGF_TEMP=$TARGETHOST_LOGF
  unset TARGETHOST_LOGF
























  sh -c "cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* > $TARGETHOST_LOGF_TEMP 2>&1 &"
else

  ssh -n -f $TARGETHOST "sh -c \"cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* > $TARGETHOST_LOGF 2>&1 &\""
fi

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

>
|
<
|
|

>
>
>
>
>
>
|

>
>
>
>
>
>
>
|

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

>
|

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
#!/bin/bash
###############################################################################
#
# nbfake - capture command output in a logfile
#
# nbfake behavior can be changed by setting the following env vars:
#   NBFAKE_HOST       SSH to $NBFAKE_HOST and run command
#   NBFAKE_LOG        Logfile for nbfake output
#
###############################################################################

if [[ -z "$@" ]]; then
  cat <<__EOF

nbfake usage:

nbfake <command to run>

nbfake behavior can be changed by setting the following env vars:
   NBFAKE_HOST       SSH to \$NBFAKE_HOST and run command
   NBFAKE_LOG        Logfile for nbfake output

__EOF
  exit
fi

#==============================================================================

# Setup
#==============================================================================

# Can't always trust $PWD
CURRWD=$(pwd)

# Make sure nbfake host and logfile are set. Fall back to old-style variable names

if [[ -z "$NBFAKE_HOST" && -n "$TARGETHOST" ]]; then 
  MY_NBFAKE_HOST=$TARGETHOST     
  unset TARGETHOST
else
  MY_NBFAKE_HOST=$NBFAKE_HOST
  unset NBFAKE_HOST
fi


if [[ -z "$NBFAKE_LOG" && -n "$TARGETHOST_LOGF" ]]; then 
  MY_NBFAKE_LOG=$TARGETHOST_LOGF
  unset TARGETHOST_LOGF
else
  MY_NBFAKE_LOG=$NBFAKE_LOG
  unset NBFAKE_LOG
fi

# Set default nbfake log

if [[ -z "$MY_NBFAKE_LOG" ]]; then
  MY_NBFAKE_LOG=NBFAKE-$(date +%GWW%V.%u_%T)
fi

#==============================================================================
# Run and log
#==============================================================================

cat <<__EOF >&2
#======================================================================
# NBFAKE logging command to: $MY_NBFAKE_LOG
#     $*
#======================================================================
__EOF

if [[ -z "$MY_NBFAKE_HOST" ]]; then
  # Run locally
  sh -c "cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* >> $MY_NBFAKE_LOG 2>&1 &"
else
  # run remotely
  ssh -n -f $MY_NBFAKE_HOST "sh -c \"cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* >> $MY_NBFAKE_LOG 2>&1 &\""
fi

Deleted utils/nbload version [4b5138d43f].

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
#!/bin/bash 

# load=`uptime|awk '{print $10}'|cut -d, -f1`
load=`uptime|perl -pe 's/.*: (\d+.\d+),.*/$1/'`
if which cpucheck > /dev/null;then
    numcpu=`cpucheck|tail -1|awk '{print $6}'`
elif which lscpu > /dev/null;then
    numcpu=`lscpu|grep "CPU.s.:"|awk '{print $2}'`
else
    numcpu=2
fi

# NB// max_load is in units of percent.
#
lperc=`echo "100 * $load / $numcpu"|bc`
if [[ "x$MAX_ALLOWED_LOAD" == "x" ]]; then
  max_load=100
else
  max_load=$MAX_ALLOWED_LOAD
fi

if [[  $lperc -lt $max_load ]];then
  echo "Load acceptable: lperc=$lperc %, max_load=$max_load %, load=$load, numcpu=$numcpu, MAX_ALLOWED_LOAD=$MAX_ALLOWED_LOAD %"
  echo "Starting command: \"$@\""
  nbfake "$@"
else
  # echo "Load too high: lperc=$lperc, max_load=$max_load, waiting two minutes before trying to run command: \"$@\""
  echo "nbload $@" | at now + 2 minutes 2> /dev/null
fi
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































Added utils/plot-code.scm version [cd37a2db38].





































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
#!/mfs/pkgs/chicken/4.8.0.5/bin/csi -nbq

;; Coming soon (right?) Usage: plot-code file1.scm,file2.scm "fun1,fun2,x*" *.scm > plot.dot
;; Usage: plot-code file1.scm,file2.scm *.scm > plot.dot
;;        dot -Tpdf plot.dot > plot.pdf
;; first param is comma separated list of files to include in the map, use - to do all
;; second param is list of regexs for functions to include in the map
;; third param is list of files to scan

(use regex srfi-69 srfi-13)

(define targs #f) 
(define files (cddddr (argv)))

(let ((targdat (cadddr (argv))))
  (if (equal? targdat "-")
      (set! targs files)
      (set! targs (string-split targdat ","))))

(define filedat-defns (make-hash-table))
(define filedat-usages (make-hash-table))

(define defn-rx (regexp "^\\s*\\(define\\s+\\(([^\\s\\)]+).*"))
(define all-regexs (make-hash-table))

(define all-fns '())

;; for the se

(define (print-err . data)
  (with-output-to-port (current-error-port)
    (lambda ()
      (apply print data))))

(print-err "Making graph for files: " (string-intersperse targs ", "))
(print-err "Looking at files: " (string-intersperse files ", "))

;; Gather the functions
;;
(for-each 
 (lambda (fname)
   (print-err "Processing file " fname)
   (with-input-from-file fname
     (lambda ()
       (let loop ((inl (read-line)))
	 (if (not (eof-object? inl))
	     (let ((match (string-match defn-rx inl)))
	       (if match 
		   (let ((fnname (cadr match)))
		     ;; (print "   " fnname)
		     (set! all-fns (cons fnname all-fns))
		     (hash-table-set! 
		      filedat-defns 
		      fname
		      (cons fnname (hash-table-ref/default filedat-defns fname '())))
		     ))
	       (loop (read-line))))))))
 files)

;; fill up the regex hash
(print-err "Make the huge regex hash")
(for-each
 (lambda (fnname)
   (hash-table-set! all-regexs fnname (regexp (conc "^(|.*[^a-zA-Z]+)" fnname "([^a-zA-Z]+|)$"))))
 (cons "toplevel" all-fns))

(define breadcrumbs (make-hash-table))

(define (have-function inl)
  (let loop ((hed (car all-fns))
	     (tal (cdr all-fns)))
    (if (string-contains inl hed)
	#t
	(if (null? tal)
	    #f
	    (loop (car tal)(cdr tal))))))

(define (look-for-all-calls inl fnname)
  (if (have-function inl) ;; (string-search have-function-rx inl)
      (let loop ((hed (car all-fns))
		 (tal (cdr all-fns))
		 (res '()))
	(let ((match (string-match (hash-table-ref all-regexs hed) inl)))
	  (if match
	      (let ((newres (cons hed res)))
		(if (null? tal)
		    newres
		    (loop (car tal)
			  (cdr tal)
			  newres)))
	      (if (null? tal)
		  res
		  (loop (car tal)(cdr tal) res)))))
      '()))

;; (define mm-header #<<MMHEADER
;; <map version="freeplane 1.2.0">
;; <!--To view this file, download free mind mapping software Freeplane from http://freeplane.sourceforge.net -->
;; 
;; MMHEADER
;; 
;; (define (add-node text)
;;   <node TEXT="homenode" ID="ID_1723255651" CREATED="1283093380553" MODIFIED="1417113442955"><hook NAME="MapStyle">
;; )
;; 
;;  minimal mindmap file
;;  <map version="freeplane 1.2.0">
;;   <!--To view this file, download free mind mapping software Freeplane from http://freeplane.sourceforge.net -->
;;   <node TEXT="homenode" ID="ID_1723255651" CREATED="1283093380553" MODIFIED="1417113442955">
;;   <node TEXT="node1" POSITION="right" ID="ID_1810107939" CREATED="1417113473476" MODIFIED="1417113480425">
;;   <node TEXT="node2" ID="ID_68133256" CREATED="1417113482134" MODIFIED="1417113484466"/>
;;   <node TEXT="node3" ID="ID_1572284821" CREATED="1417113487785" MODIFIED="1417113491589"/>
;;   </node>
;;   </node>
;;   </map>

;; Gather the usages
(print "digraph G {")
(define curr-cluster-num 0)
(define function-calls '())

(for-each
 (lambda (fname)
   (let ((last-func #f))
     (print-err "Processing file " fname)
     (print "subgraph cluster_" curr-cluster-num " {")
     (set! curr-cluster-num (+ curr-cluster-num 1))
     (with-input-from-file fname
       (lambda ()
	 (with-output-to-port (current-error-port)
	   (lambda ()
	     (print "Analyzing file " fname)))
	 (print "label=\"" fname "\";")
	 (let loop ((inl    (read-line))
		    (fnname "toplevel")
		    (allcalls '()))
	   (if (eof-object? inl)
	       (begin
		 (set! function-calls (cons (list fnname allcalls) function-calls))
		 (for-each 
		  (lambda (call-name)
		    (hash-table-set! breadcrumbs call-name #t))
		  allcalls)
		 (print-err "function: " fnname " allcalls: " allcalls))
	       (let ((match (string-match defn-rx inl)))
		 (if match
		     (let ((func-name (cadr match)))
		       (if last-func
			   (print "\"" func-name "\" -> \"" last-func "\";")
			   (print "\"" func-name "\";"))
		       (set! last-func func-name)
		       (hash-table-set! breadcrumbs func-name #t)
		       (loop (read-line)
			     func-name
			     allcalls))
		     (let ((calls (look-for-all-calls inl fnname)))
		       (loop (read-line) fnname (append allcalls calls)))))))))
     (print "}")))
 targs)

(print-err "breadcrumbs: " (hash-table-keys breadcrumbs))
(print-err "function-calls: " function-calls)

(for-each 
 (lambda (function-call)
   (print-err "function-call: " function-call)
   (let ((fnname (car function-call))
	 (calls  (cadr function-call)))
     (for-each
      (lambda (callname)
	(print (if (hash-table-ref/default breadcrumbs callname #f) "" "// ")
	       "\"" fnname "\" -> \"" callname "\";"))
      calls)))
 function-calls)

(print "}")

(exit)

Added utils/trace/trace.import.scm version [937dcb55c1].

































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
;;;; trace.import.scm - GENERATED BY CHICKEN 4.9.0.1 -*- Scheme -*-

(eval '(import
         scheme
         chicken
         csi
         advice
         extras
         ports
         data-structures
         (except srfi-1 break)
         miscmacros))
(##sys#register-compiled-module
  'trace
  (list)
  '((breakpoint . trace#breakpoint)
    (trace . trace#trace)
    (untrace . trace#untrace)
    (break . trace#break)
    (unbreak . trace#unbreak)
    (trace-output-port . trace#trace-output-port)
    (continue . trace#continue)
    (c . trace#c)
    (traced? . trace#traced?)
    (trace-module . trace#trace-module)
    (untrace-module . trace#untrace-module)
    (trace-verbose . trace#trace-verbose)
    (trace/untrace . trace#trace/untrace))
  (list)
  (list))

;; END OF FILE

Added utils/trace/trace.meta version [9714181a62].





















>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
;;;; trace.meta -*- Scheme -*-


((category tools)
 (synopsis "tracing and breakpoints")
 (author "felix winkelmann")
 (license "public domain")
 (needs advice				; don't we all?
	miscmacros)
 (files "tests/run.scm" "trace.meta" "trace.release-info" "trace.scm" "trace.setup") )

Added utils/trace/trace.scm version [dc3560e035].







































































































































































































































































































































































































































































































































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


(module trace (breakpoint 
	       trace untrace
	       break unbreak
	       trace-output-port
	       continue c 
	       traced?
	       trace-module untrace-module
	       trace-verbose
	       trace/untrace)
	       
(import scheme chicken csi)

(use advice extras ports data-structures)
(require-library srfi-1)
(import (except srfi-1 break) miscmacros)


(define *last-breakpoint* #f)
(define *traced-procedures* '())
(define *broken-procedures* '())
(define *trace-indent-level* 0)

(define trace-output-port (make-parameter (current-output-port)))
(define trace-verbose (make-parameter #t))

(define (break-entry name args)
  ;; Does _not_ unwind!
  (##sys#call-with-current-continuation
   (lambda (c)
     (let ((exn (##sys#make-structure
		 'condition
		 '(exn breakpoint)
		 (list '(exn . message) "*** breakpoint ***"
		       '(exn . arguments) (list (cons name args))
		       '(exn . location) name
		       '(exn . continuation) c) ) ) )
       (set! *last-breakpoint* exn)
       (signal exn) ) ) ) )

(define (break-resume exn)
  (let ((a (member '(exn . continuation) (##sys#slot exn 2))))
    (if a
	((cadr a) (void))
	(error "condition has no continuation" exn) ) ) )

(define (breakpoint #!optional (name 'breakpoint))
  (break-entry name '()) )

(define (trace-indent)
  (let ((port (trace-output-port)))
    (do ((i (fxmin 3 *trace-indent-level*) (fx- i 1)))
	((fx<= i 0))
      (write-char #\space port) )
    (fprintf port "[~a] " *trace-indent-level*) ) )

(define (traced-procedure-entry name args)
  (let ((port (trace-output-port)))
    (trace-indent)
    (set! *trace-indent-level* (fx+ 1 *trace-indent-level*))
    (write (cons name args) port)
    (write ", Called from: " port)
    (write (conc (car (reverse (get-call-chain)))))
    (write-char #\newline port)
    (flush-output port) ) )

(define (traced-procedure-exit name results)
  (let ((port (trace-output-port)))
    (set! *trace-indent-level* (fx- *trace-indent-level* 1))
    (trace-indent)
    (fprintf port "~a -> " name)
    (if results
	(for-each
	 (lambda (x)
	   (write x port)
	   (write-char #\space port) )
	 results)
	(display "(escaping)" port))
    (write-char #\newline port)
    (flush-output port) ) )

(define (procedure-name proc)
  (cond ((procedure-information proc) =>
	 (lambda (info)
	   (if (pair? info) (car info) info) ) )
	(else '<unknown>)) )

(define (do-trace procs)
  (for-each
   (lambda (s)
     (ensure procedure? s)
     (cond ((traced? s)
	    (warning "procedure already traced" s) )
	   (else
	    (let ((name (procedure-name s)))
	      (when (trace-verbose)
		(fprintf (current-error-port) "; tracing ~a~%" name))
	      (set! *traced-procedures* (cons (cons s name) *traced-procedures*))
	      (advise 
	       'around s
	       (lambda (next args)
		 (let ((results #f))
		   (dynamic-wind
		       (cut traced-procedure-entry name args)
		       (lambda () 
			 (call-with-values (cut apply next args)
			   (lambda rs
			     (set! results rs)
			     (apply values rs))))
		       (cut traced-procedure-exit name results))))
	       '*trace*)))))
   procs) )

(define (do-untrace-all)
  (define (unadvise* p)
    (ignore-errors (unadvise p '*trace*)))
  (for-each
   (lambda (proc)
     (let ((proc (car proc)))
       (when (trace-verbose)
	 (fprintf (current-error-port) "; untracing ~a~%" (procedure-name proc))
	 (unadvise* proc))))
   *traced-procedures*)
  (set! *traced-procedures* '()))

(define (do-untrace procs)
  (for-each
   (lambda (s)
     (ensure procedure? s)
     (let ((p (assq s *traced-procedures*)) 
	   (name (procedure-name s)))
       (cond ((not p) (warning "procedure not traced" name))
	     (else
	      (when (trace-verbose)
		(fprintf (current-error-port) "; untracing ~a~%" name))
	      (ignore-errors (unadvise s '*trace*))
	      (set! *traced-procedures* 
		(delete 
		 p *traced-procedures* 
		 eq?))))))
   procs) )

(define (do-break procs)
  (for-each
   (lambda (s)
     (let ((name (procedure-name s)))
       (ensure procedure? s)
       (cond ((assq s *broken-procedures*)
	      (warning "procedure already has break-point" name))
	     (else
	      (when (trace-verbose)
		(fprintf (current-error-port) "; setting break-point in ~a~%" name))
	      (set! *broken-procedures* (cons (cons s name) *broken-procedures*))
	      (advise 
	       'before s
	       (lambda (args)
		 (break-entry name args) )
	       '*break*) ) )))
   procs) )

(define (do-unbreak procs)
  (for-each
   (lambda (s)
     (ensure procedure? s)
     (let ((p (assq s *broken-procedures*)) 
	   (name (procedure-name s)))
       (cond ((not p) (warning "procedure has no breakpoint" name))
	     (else
	      (when (trace-verbose)
		(fprintf (current-error-port) "; removing break-point in ~a~%" name))
	      (ignore-errors (unadvise s '*break*))
	      (set! *broken-procedures* (delete p *broken-procedures* eq?) ) ) ) ) )
   procs) )

(define (do-unbreak-all)
  (for-each
   (lambda (bp)
     (ignore-errors (unadvise (car bp) '*break*)))
   *broken-procedures*)
  (set! *broken-procedures* '())
  (void))

(define (trace . procs)
  (cond ((null? procs)
	 (when (pair? *traced-procedures*)
	   (printf "Traced:~%~%")
	   (for-each (lambda (p) (printf "  ~a~%" (cdr p))) *traced-procedures*)) )
	(else
	 (do-trace procs) ) ) )

(define (untrace . procs)
  (cond ((null? procs) (do-untrace-all))
	(else (do-untrace procs)))
  (void))

(define (break . procs)
  (cond ((null? procs)
	 (when (pair? *broken-procedures*)
	   (printf "Breakpoints:~%~%")
	   (for-each (lambda (p) (printf "  ~a~%" (cdr p))) *broken-procedures*)) )
	(else
	 (do-break procs) ) ) )

(define (unbreak . procs)
  (cond ((null? procs) (do-unbreak-all))
	(else (do-unbreak procs))))

(define (continue #!optional (bp *last-breakpoint*))
  (cond (*last-breakpoint*
	 (let ((exn *last-breakpoint*))
	   (set! *last-breakpoint* #f)
	   (break-resume exn) ) )
	(else (display "no breakpoint pending\n") ) ) )

(define c continue)

(define (traced? proc)
  (assq proc *traced-procedures*))

(define (trace/untrace . procs)
  (for-each
   (lambda (proc)
     ((if (traced? proc) do-untrace do-trace) (list proc)))
   procs))

(define (walk-module mname proc)
  (let* ((m (##sys#find-module mname))
	 (exps (nth-value 1 (##sys#module-exports m))))
    (for-each
     (lambda (exp)
       (let* ((realname (cdr exp))
	      (prim (get realname '##core#primitive)))
	 (if prim
	     (warning "export is a core-library primitive - not traced" (car exp))
	     (when (##sys#symbol-has-toplevel-binding? realname)
	       (let ((val (##sys#slot realname 0)))
		 (when (procedure? val)
		   (proc val)))))))
     exps)))

(define (trace-module . mnames)
  (for-each
   (lambda (mname)
     (walk-module mname trace))
   mnames))

(define (untrace-module . mnames)
  (for-each
   (lambda (mname)
     (walk-module 
      mname 
      (lambda (proc)
	(when (traced? proc)
	  (do-untrace (list proc))))))
   mnames))

)

Added utils/trace/trace.setup version [d222d610b4].



















>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
;;;; trace.setup -*- Scheme -*-


(compile -s trace.scm -O3 -d1 -j trace)
(compile -s trace.import.scm -O3 -d0)

(install-extension
 'trace
 '("trace.so" "trace.import.so"))

Added widgets.scm version [3d56925ea9].



























































































































































































































































































































































































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

Modified zmq-transport.scm from [dc7b4eceb5] to [e1f3152a02].

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
;; [ ]  [ ]    7. Turn self ping back on

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

(define *server-loop-heart-beat* (current-seconds))
(define *heartbeat-mutex* (make-mutex))

;;======================================================================
;; S E R V E R
;;======================================================================

(define-inline (zmqsock:get-pub  dat)(vector-ref dat 0))
(define-inline (zmqsock:get-pull dat)(vector-ref dat 1))
(define-inline (zmqsock:set-pub! dat s)(vector-set! dat s 0))
(define-inline (zmqsock:set-pull! dat s)(vector-set! dat s 0))

(define (zmq-transport:run hostn)
  (debug:print 2 "Attempting to start the server ...")
  (if (not *toppath*)
      (if (not (launch:setup-for-run))
	  (begin
	    (debug:print 0 "ERROR: cannot find megatest.config, cannot start server, exiting")
	    (exit))))
  (let* ((db              (open-db)) ;; here we *do not* want to be opening and closing the db
	 (zmq-sdat1       #f)
	 (zmq-sdat2       #f)
	 (pull-socket     #f)







|














|







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
;; [ ]  [ ]    7. Turn self ping back on

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

(define  *server-loop-heart-beat* (current-seconds))
(define *heartbeat-mutex* (make-mutex))

;;======================================================================
;; S E R V E R
;;======================================================================

(define-inline (zmqsock:get-pub  dat)(vector-ref dat 0))
(define-inline (zmqsock:get-pull dat)(vector-ref dat 1))
(define-inline (zmqsock:set-pub! dat s)(vector-set! dat s 0))
(define-inline (zmqsock:set-pull! dat s)(vector-set! dat s 0))

(define (zmq-transport:run hostn)
  (debug:print 2 "Attempting to start the server ...")
  (if (not *toppath*)
      (if (not (setup-for-run))
	  (begin
	    (debug:print 0 "ERROR: cannot find megatest.config, cannot start server, exiting")
	    (exit))))
  (let* ((db              (open-db)) ;; here we *do not* want to be opening and closing the db
	 (zmq-sdat1       #f)
	 (zmq-sdat2       #f)
	 (pull-socket     #f)
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
	  (debug:print 0 "ERROR: Failed to open socket to " conurl)
	  #f))))

(define (zmq-transport:client-connect iface pullport pubport)
  (let* ((push-socket (zmq-transport:client-socket-connect iface pullport type: 'push))
	 (sub-socket  (zmq-transport:client-socket-connect iface pubport
						    type: 'sub
						    subscriptions: (list (client:get-signature) "all")))
	 (zmq-sockets (vector push-socket sub-socket))
	 (login-res   #f))
    (debug:print-info 11 "zmq-transport:client-connect started. Next is login")
    (set! login-res (client:login serverdat zmq-sockets))
    (if (and (not (null? login-res))
	     (car login-res))
	(begin
	  (debug:print-info 2 "Logged in and connected to " iface ":" pullport "/" pubport ".")
	  (set! *runremote* zmq-sockets)
	  zmq-sockets)
	(begin







|



|







283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
	  (debug:print 0 "ERROR: Failed to open socket to " conurl)
	  #f))))

(define (zmq-transport:client-connect iface pullport pubport)
  (let* ((push-socket (zmq-transport:client-socket-connect iface pullport type: 'push))
	 (sub-socket  (zmq-transport:client-socket-connect iface pubport
						    type: 'sub
						    subscriptions: (list (server:get-client-signature) "all")))
	 (zmq-sockets (vector push-socket sub-socket))
	 (login-res   #f))
    (debug:print-info 11 "zmq-transport:client-connect started. Next is login")
    (set! login-res (server:client-login zmq-sockets))
    (if (and (not (null? login-res))
	     (car login-res))
	(begin
	  (debug:print-info 2 "Logged in and connected to " iface ":" pullport "/" pubport ".")
	  (set! *runremote* zmq-sockets)
	  zmq-sockets)
	(begin
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
              (debug:print-info 0 "Max cached queries was " *max-cache-size*)
              (debug:print-info 0 "Server shutdown complete. Exiting")
              (exit)))))))

;; all routes though here end in exit ...
(define (zmq-transport:launch)
  (if (not *toppath*)
      (if (not (launch:setup-for-run))
	  (begin
	    (debug:print 0 "ERROR: cannot find megatest.config, exiting")
	    (exit))))
  (debug:print-info 2 "Starting zmq server")
  (if *toppath* 
      (let* (;; (th1 (make-thread (lambda ()
	     ;;      	       (let ((server-info #f))







|







359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
              (debug:print-info 0 "Max cached queries was " *max-cache-size*)
              (debug:print-info 0 "Server shutdown complete. Exiting")
              (exit)))))))

;; all routes though here end in exit ...
(define (zmq-transport:launch)
  (if (not *toppath*)
      (if (not (setup-for-run))
	  (begin
	    (debug:print 0 "ERROR: cannot find megatest.config, exiting")
	    (exit))))
  (debug:print-info 2 "Starting zmq server")
  (if *toppath* 
      (let* (;; (th1 (make-thread (lambda ()
	     ;;      	       (let ((server-info #f))