Megatest

Check-in [3436c3834f]
Login
Overview
Comment:Attempted merge
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | attempted-merge
Files: files | file ages | folders
SHA1: 3436c3834fa707c89d437fa84be9ef994e332cec
User & Date: mrwellan on 2017-11-17 14:24:11
Other Links: branch diff | manifest | tags
Context
2017-11-17
14:24
Attempted merge Leaf check-in: 3436c3834f user: mrwellan tags: attempted-merge (unpublished)
2017-11-16
17:07
Fix for fixme-matt bug Closed-Leaf check-in: 65fadb2649 user: mrwellan tags: Moved fix to be against the fixme-matt commit
2017-09-13
11:10
Merged v1.65 into v1.64-areas-dashboard in prep to move to basing off v1.65 check-in: adc89fda39 user: mrwellan tags: v1.64-areas-dashboard
Changes

Modified .mtutil.scm from [3e3e4527c3] to [c25417b18d].

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
	  last-name))))

(define (str-first-char->number str)
  (char->integer (string-ref str 0)))
 
;; example of how to set up and write target mappers
;;
(hash-table-set! *target-mappers*
		 'prefix-contour
		 (lambda (target run-name area area-path reason contour mode-patt)
		   (conc contour "/" target)))
(hash-table-set! *target-mappers*
		 'prefix-area-contour
		 (lambda (target run-name area area-path reason contour mode-patt)
		   (conc area "/" contour "/" target)))
  
(hash-table-set! *runname-mappers*
		 'corporate-ww
		 (lambda (target run-name area area-path reason contour mode-patt)
		   (print "corporate-ww called with: target=" target " run-name=" run-name " area=" area " area-path=" area-path " reason=" reason " contour=" contour " mode-patt=" mode-patt)
		   (let* ((last-name   (get-last-runname area-path target))
			  (last-letter (let* ((ch (if (string? last-name)
						      (let ((len (string-length last-name)))
							(substring last-name (- len 1) len))
						      "a"))
					      (chnum (str-first-char->number ch))
					      (a     (str-first-char->number "a"))
					      (z     (str-first-char->number "z")))
					 (if (and (>= chnum a)(<= chnum z))
					     chnum
					     #f)))
			  (next-letter (if last-letter
					   (list->string
					    (list
					     (integer->char
					      (+ last-letter 1)))) ;; surely there is an easier way?
					   "a")))
		     ;; (print "last-name: " last-name " last-letter: " last-letter " next-letter: " next-letter)
		     (conc (seconds->wwdate (current-seconds)) next-letter))))

(hash-table-set! *runname-mappers*
		 'auto
		 (lambda (target run-name area area-path reason contour mode-patt)
		   "auto-eh"))






;; (print "Got here!")








<
|
|
|
<
|
|
|

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

|
<
|
|

>
>
>
>
>
|

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
	  last-name))))

(define (str-first-char->number str)
  (char->integer (string-ref str 0)))
 
;; example of how to set up and write target mappers
;;

(add-target-mapper 'prefix-contour
		   (lambda (target run-name area area-path reason contour mode-patt)
		     (conc contour "/" target)))

(add-target-mapper 'prefix-area-contour
		   (lambda (target run-name area area-path reason contour mode-patt)
		     (conc area "/" contour "/" target)))
  

(add-runname-mapper 'corporate-ww
		    (lambda (target run-name area area-path reason contour mode-patt)
		      (print "corporate-ww called with: target=" target " run-name=" run-name " area=" area " area-path=" area-path " reason=" reason " contour=" contour " mode-patt=" mode-patt)
		      (let* ((last-name   (get-last-runname area-path target))
			     (last-letter (let* ((ch (if (string? last-name)
							 (let ((len (string-length last-name)))
							   (substring last-name (- len 1) len))
							 "a"))
						 (chnum (str-first-char->number ch))
						 (a     (str-first-char->number "a"))
						 (z     (str-first-char->number "z")))
					    (if (and (>= chnum a)(<= chnum z))
						chnum
						#f)))
			     (next-letter (if last-letter
					      (list->string
					       (list
						(integer->char
						 (+ last-letter 1)))) ;; surely there is an easier way?
					      "a")))
			;; (print "last-name: " last-name " last-letter: " last-letter " next-letter: " next-letter)
			(conc (seconds->wwdate (current-seconds)) next-letter))))

(add-runname-mapper 'auto

		    (lambda (target run-name area area-path reason contour mode-patt)
		      "auto-eh"))

;; run only areas where first letter of area name is "a"
;;
(add-area-checker 'first-letter-a
                  (lambda (area target contour)
                    (string-match "^a.*$" area)))


Modified Makefile from [32f21cf39e] to [5be2de8f29].

48
49
50
51
52
53
54
55
56
57
58
59
60
61
62

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

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

mtut: $(OFILES) mtut.scm
	csc $(CSCOPTS) $(OFILES) mtut.scm -o mtut

TCMTOBJS = \
	api.o \
	archive.o \
	cgisetup/models/pgdb.o \
	client.o \







|







48
49
50
51
52
53
54
55
56
57
58
59
60
61
62

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

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

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

TCMTOBJS = \
	api.o \
	archive.o \
	cgisetup/models/pgdb.o \
	client.o \
144
145
146
147
148
149
150



151
152
153
154
155
156
157
$(PREFIX)/bin/newdashboard : $(PREFIX)/bin/.$(ARCHSTR)/ndboard utils/mk_wrapper
	utils/mk_wrapper $(PREFIX) ndboard $(PREFIX)/bin/newdashboard
	chmod a+x $(PREFIX)/bin/newdashboard

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




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

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








>
>
>







144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
$(PREFIX)/bin/newdashboard : $(PREFIX)/bin/.$(ARCHSTR)/ndboard utils/mk_wrapper
	utils/mk_wrapper $(PREFIX) ndboard $(PREFIX)/bin/newdashboard
	chmod a+x $(PREFIX)/bin/newdashboard

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

install-mtut : mtut
	$(INSTALL) mtut $(PREFIX)/bin/mtut

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

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

Modified api.scm from [c4438e36a1] to [00e49270d6].

275
276
277
278
279
280
281

282
283
284
285

286
287
288
289
290
291
292
                   ((get-main-run-stats)           (apply db:get-main-run-stats dbstruct params))
                   ((get-var)                      (apply db:get-var dbstruct params))
                   ((get-run-stats)                (apply db:get-run-stats 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))


                   ;; TEST DATA
                   ((read-test-data)               (apply db:read-test-data dbstruct params))
                   ((read-test-data*)              (apply db:read-test-data* dbstruct params))


                   ;; MISC
                   ((get-latest-host-load)         (apply db:get-latest-host-load dbstruct params))
                   ((have-incompletes?)            (apply db:have-incompletes? dbstruct params))
                   ((login)                        (apply db:login dbstruct params))
                   ((general-call)                 (let ((stmtname   (car params))
                                                         (run-id     (cadr params))







>




>







275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
                   ((get-main-run-stats)           (apply db:get-main-run-stats dbstruct params))
                   ((get-var)                      (apply db:get-var dbstruct params))
                   ((get-run-stats)                (apply db:get-run-stats 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))
		   ((get-steps-info-by-id)         (apply db:get-steps-info-by-id dbstruct params))

                   ;; TEST DATA
                   ((read-test-data)               (apply db:read-test-data dbstruct params))
                   ((read-test-data*)              (apply db:read-test-data* dbstruct params))
                   ((get-data-info-by-id)          (apply db:get-data-info-by-id dbstruct params)) 

                   ;; MISC
                   ((get-latest-host-load)         (apply db:get-latest-host-load dbstruct params))
                   ((have-incompletes?)            (apply db:have-incompletes? dbstruct params))
                   ((login)                        (apply db:login dbstruct params))
                   ((general-call)                 (let ((stmtname   (car params))
                                                         (run-id     (cadr params))

Modified archive.scm from [882dbab237] to [78f500d300].

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
;; 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 srfi-18)
(import (prefix sqlite3 sqlite3:))

(declare (unit archive))
(declare (uses db))
(declare (uses common))

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











<
|







1
2
3
4
5
6
7
8
9
10
11

12
13
14
15
16
17
18
19
;; 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 (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 format md5 message-digest srfi-18)

(declare (unit archive))
(declare (uses db))
(declare (uses common))

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

Modified cgisetup/models/pgdb.scm from [add2d5c9c3] to [875743c283].

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
;;======================================================================
;;  R U N S
;;======================================================================

;; given a target spec id, target and run-name return the run-id
;; if no run found return #f
;;
(define (pgdb:get-run-id dbh spec-id target run-name)
  (dbi:get-one dbh "SELECT id FROM runs WHERE ttype_id=? AND target=? AND run_name=?;"
	       spec-id target run-name))

;; given a run-id return all the run info
;;
(define (pgdb:get-run-info dbh run-id) ;; to join ttype or not?
  (dbi:get-one-row
   dbh   ;; 0    1       2       3      4     5      6       7        8         9         10          11         12
   "SELECT id,target,ttype_id,run_name,state,status,owner,event_time,comment,fail_count,pass_count,last_update,area_id
       FROM runs WHERE id=?;" run-id))

;; refresh the data in a run record
;;
(define (pgdb:refresh-run-info dbh run-id state status owner event-time comment fail-count pass-count) ;; area-id)
  (dbi:exec
   dbh
   "UPDATE runs SET
      state=?,status=?,owner=?,event_time=?,comment=?,fail_count=?,pass_count=?
     WHERE id=?;"
   state status owner event-time comment fail-count pass-count run-id))

;; given all needed info create run record
;;
(define (pgdb:insert-run dbh ttype-id target run-name state status owner event-time comment fail-count pass-count)
  (dbi:exec
   dbh
   "INSERT INTO runs (ttype_id,target,run_name,state,status,owner,event_time,comment,fail_count,pass_count)
      VALUES (?,?,?,?,?,?,?,?,?,?);"
    ttype-id target run-name state status owner event-time comment fail-count pass-count))






















































;;======================================================================
;;  T E S T S
;;======================================================================

;; given run-id, test_name and item_path return test-id
;;







|
|
|



|



|



|



|
|
|



|
|

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







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
;;======================================================================
;;  R U N S
;;======================================================================

;; given a target spec id, target and run-name return the run-id
;; if no run found return #f
;;
(define (pgdb:get-run-id dbh spec-id target run-name area-id)
  (dbi:get-one dbh "SELECT id FROM runs WHERE ttype_id=? AND target=? AND run_name=? and area_id=?;"
	       spec-id target run-name area-id))

;; given a run-id return all the run info
;;
(define (pgdb:get-run-info dbh run-id ) ;; to join ttype or not?
  (dbi:get-one-row
   dbh   ;; 0    1       2       3      4     5      6       7        8         9         10          11         12
   "SELECT id,target,ttype_id,run_name,state,status,owner,event_time,comment,fail_count,pass_count,last_update,area_id
       FROM runs WHERE id=? ;" run-id ))

;; refresh the data in a run record
;;
(define (pgdb:refresh-run-info dbh run-id state status owner event-time comment fail-count pass-count area-id) ;; area-id)
  (dbi:exec
   dbh
   "UPDATE runs SET
      state=?,status=?,owner=?,event_time=?,comment=?,fail_count=?,pass_count=? 
     WHERE id=? and area_id=?;"
   state status owner event-time comment fail-count pass-count run-id area-id))

;; given all needed info create run record
;;
(define (pgdb:insert-run dbh ttype-id target run-name state status owner event-time comment fail-count pass-count area-id)
    (dbi:exec
   dbh
   "INSERT INTO runs (ttype_id,target,run_name,state,status,owner,event_time,comment,fail_count,pass_count,area_id )
      VALUES (?,?,?,?,?,?,?,?,?,?,?);"
    ttype-id target run-name state status owner event-time comment fail-count pass-count area-id))

;;======================================================================
;;  T E S T - S T E P S
;;======================================================================

(define (pgdb:get-test-step-id dbh test-id stepname state)
  (dbi:get-one
    dbh
    "SELECT id FROM test_steps WHERE test_id=? AND stepname=? and state = ? ;"
    test-id stepname state))

(define (pgdb:insert-test-step dbh test-id stepname state status event_time comment logfile)
  (dbi:exec
   dbh
   "INSERT INTO test_steps (test_id,stepname,state,status,event_time,logfile,comment)
       VALUES (?,?,?,?,?,?,?);"
   test-id stepname  state   status  event_time   logfile   comment))

(define (pgdb:update-test-step dbh step-id test-id stepname state status event_time comment logfile)
  (dbi:exec
    dbh
    "UPDATE test_steps SET
         test_id=?,stepname=?,state=?,status=?,event_time=?,logfile=?,comment=?
          WHERE id=?;"
    test-id stepname  state   status  event_time   logfile   comment step-id))


;;======================================================================
;;  T E S T - D A T A
;;======================================================================

(define (pgdb:get-test-data-id dbh test-id category variable)
  (dbi:get-one
    dbh
    "SELECT id FROM test_data WHERE test_id=? AND category=? and variable = ? ;"
    test-id category variable))

(define (pgdb:insert-test-data dbh test-id category variable value expected tol units comment status type)
  (dbi:exec
   dbh
   "INSERT INTO test_data (test_id, category, variable, value, expected, tol, units, comment, status, type)
       VALUES (?,?,?,?,?,?,?,?,?,?);"
   test-id category variable value expected tol units comment status type))

(define (pgdb:update-test-data dbh data-id test-id  category variable value expected tol units comment status type)
  (dbi:exec
    dbh
    "UPDATE test_data SET
         test_id=?, category=?, variable=?, value=?, expected=?, tol=?, units=?, comment=?, status=?, type=?
          WHERE id=?;"
    test-id category variable value expected tol units comment status type data-id ))



;;======================================================================
;;  T E S T S
;;======================================================================

;; given run-id, test_name and item_path return test-id
;;
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
                    SUM(CASE WHEN t.status='PASS' THEN 1 ELSE 0 END) AS pass,
                    SUM(CASE WHEN t.status='FAIL' THEN 1 ELSE 0 END) AS fail,
                    SUM(CASE WHEN t.status IN ('PASS','FAIL') THEN 0 ELSE 1 END) AS other
            FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id
            WHERE t.state='COMPLETED' AND r.target LIKE ? GROUP BY r.target;"
   target-patt))


(define (pgdb:get-latest-run-stats-given-target dbh ttype-id target-patt)
  (dbi:get-rows
   dbh
   ;;    "SELECT COUNT(t.id),t.status,r.target FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id
   ;;         WHERE t.state='COMPLETED' AND ttype_id=? AND r.target LIKE ? GROUP BY r.target,t.status;"
   "SELECT r.target,COUNT(*) AS total,
                    SUM(CASE WHEN t.status='PASS' THEN 1 ELSE 0 END) AS pass,
                    SUM(CASE WHEN t.status='FAIL' THEN 1 ELSE 0 END) AS fail,
                    SUM(CASE WHEN t.status IN ('PASS','FAIL') THEN 0 ELSE 1 END) AS other, r.id
            FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id
            WHERE t.state like '%'  AND ttype_id=? AND r.target LIKE ? 
                 and r.id in 
(SELECT DISTINCT on (target) id from runs where target like ? AND ttype_id=? order by target,event_time desc) GROUP BY r.target,r.id;"


   ttype-id target-patt target-patt ttype-id))



































































(define (pgdb:get-run-stats-history-given-target dbh ttype-id target-patt)
  (dbi:get-rows
   dbh
   ;;    "SELECT COUNT(t.id),t.status,r.target FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id
   ;;         WHERE t.state='COMPLETED' AND ttype_id=? AND r.target LIKE ? GROUP BY r.target,t.status;"
   "SELECT r.run_name,COUNT(*) AS total,
                    SUM(CASE WHEN t.status='PASS' THEN 1 ELSE 0 END) AS pass,
                    SUM(CASE WHEN t.status='FAIL' THEN 1 ELSE 0 END) AS fail,
                    SUM(CASE WHEN t.status IN ('PASS','FAIL') THEN 0 ELSE 1 END) AS other
            FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id
            WHERE t.state like '%'  AND ttype_id=? AND r.target LIKE ? 
                 GROUP BY r.run_name;"
   ttype-id target-patt ))

(define (pgdb:get-all-run-stats-target-slice dbh target-patt)
(dbi:get-rows
   dbh
   "SELECT  r.target, r.run_name,r.event_time, COUNT(*) AS total,
                    SUM(CASE WHEN t.status='PASS' THEN 1 ELSE 0 END) AS pass,
                    SUM(CASE WHEN t.status='FAIL' THEN 1 ELSE 0 END) AS fail,
                    SUM(CASE WHEN t.status IN ('PASS','FAIL') THEN 0 ELSE 1 END) AS other
            FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id
            WHERE r.target LIKE ? 



             







            GROUP BY r.target,r.run_name, r.event_time;"

    target-patt))














(define (pgdb:get-target-types dbh)
  (dbi:get-rows dbh "SELECT id,target_spec FROM ttype;"))
 
 (define (pgdb:get-distict-target-slice dbh)
  (dbi:get-rows dbh " select distinct on (split_part (target, '/', 1)) (split_part (target, '/', 1)) from runs;"))



;; 
(define (pgdb:get-targets dbh target-patt)
  (let ((ttypes (pgdb:get-target-types dbh)))
    (map
     (lambda (ttype-dat)
       (let ((tt-id (vector-ref ttype-dat 0))
	     (ttype (vector-ref ttype-dat 1)))







>
|




|






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















|
|
|
|





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


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







|
>







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
                    SUM(CASE WHEN t.status='PASS' THEN 1 ELSE 0 END) AS pass,
                    SUM(CASE WHEN t.status='FAIL' THEN 1 ELSE 0 END) AS fail,
                    SUM(CASE WHEN t.status IN ('PASS','FAIL') THEN 0 ELSE 1 END) AS other
            FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id
            WHERE t.state='COMPLETED' AND r.target LIKE ? GROUP BY r.target;"
   target-patt))


(define (pgdb:get-latest-run-stats-given-target dbh ttype-id target-patt limit offset)
  (dbi:get-rows
   dbh
   ;;    "SELECT COUNT(t.id),t.status,r.target FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id
   ;;         WHERE t.state='COMPLETED' AND ttype_id=? AND r.target LIKE ? GROUP BY r.target,t.status;"
   "SELECT r.target, r.event_time, COUNT(*) AS total,
                    SUM(CASE WHEN t.status='PASS' THEN 1 ELSE 0 END) AS pass,
                    SUM(CASE WHEN t.status='FAIL' THEN 1 ELSE 0 END) AS fail,
                    SUM(CASE WHEN t.status IN ('PASS','FAIL') THEN 0 ELSE 1 END) AS other, r.id
            FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id
            WHERE t.state like '%'  AND ttype_id=? AND r.target LIKE ? 
                 and r.id in 
           (SELECT DISTINCT on (target) id from runs where target like ? AND ttype_id=? order by target,event_time desc) 
          GROUP BY r.target,r.id 
          order by r.event_time desc limit ? offset ? ;"
   ttype-id target-patt target-patt ttype-id limit offset))

(define (pgdb:get-latest-run-stats-given-pattern dbh patt limit offset)
  (dbi:get-rows
   dbh
   ;;    "SELECT COUNT(t.id),t.status,r.target FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id
   ;;         WHERE t.state='COMPLETED' AND ttype_id=? AND r.target ILIKE ? GROUP BY r.target,t.status;"
   "SELECT r.target, r.event_time, COUNT(*) AS total,
                    SUM(CASE WHEN t.status='PASS' THEN 1 ELSE 0 END) AS pass,
                    SUM(CASE WHEN t.status='FAIL' THEN 1 ELSE 0 END) AS fail,
                    SUM(CASE WHEN t.status IN ('PASS','FAIL') THEN 0 ELSE 1 END) AS other, r.id
            FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id
            WHERE t.state like '%'  AND r.target ILIKE ? 
                 and r.id in 
           (SELECT DISTINCT on (target) id from runs where target ilike ?  order by target,event_time desc) 
          GROUP BY r.target,r.id 
          order by r.event_time desc limit ? offset ? ;"
   patt patt  limit offset))


(define (pgdb:get-count-data-stats-target-latest dbh ttype-id target-patt)
  (dbi:get-rows
   dbh
    "SELECT count(*)  from 
          (SELECT DISTINCT on (target) id 
		from runs where target like ? AND ttype_id = ? 
		order by target, event_time desc
          ) as x;" 
    target-patt ttype-id))

(define  (pgdb:get-latest-run-cnt dbh ttype-id target-patt)
  (let* ((cnt-result (pgdb:get-count-data-stats-target-latest dbh ttype-id target-patt))
         ;(cnt-row (car (cnt-result)))
         (cnt 0) 
       )
    (for-each
     (lambda (row)
      (set! cnt  (vector-ref row 0 ))) 
     cnt-result)

cnt))

(define (pgdb:get-count-data-stats-latest-pattern dbh patt)
  (dbi:get-rows
   dbh
    "SELECT count(*)  from 
          (SELECT DISTINCT on (target) id 
		from runs where target ilike ?  
		order by target, event_time desc
          ) as x;" 
    patt))

(define  (pgdb:get-latest-run-cnt-by-pattern dbh target-patt)
  (let* ((cnt-result (pgdb:get-count-data-stats-latest-pattern dbh target-patt))
         ;(cnt-row (car (cnt-result)))
         (cnt 0) 
       )
    (for-each
     (lambda (row)
      (set! cnt  (vector-ref row 0 ))) 
     cnt-result)

cnt))





(define (pgdb:get-run-stats-history-given-target dbh ttype-id target-patt)
  (dbi:get-rows
   dbh
   ;;    "SELECT COUNT(t.id),t.status,r.target FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id
   ;;         WHERE t.state='COMPLETED' AND ttype_id=? AND r.target LIKE ? GROUP BY r.target,t.status;"
   "SELECT r.run_name,COUNT(*) AS total,
                    SUM(CASE WHEN t.status='PASS' THEN 1 ELSE 0 END) AS pass,
                    SUM(CASE WHEN t.status='FAIL' THEN 1 ELSE 0 END) AS fail,
                    SUM(CASE WHEN t.status IN ('PASS','FAIL') THEN 0 ELSE 1 END) AS other
            FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id
            WHERE t.state like '%'  AND ttype_id=? AND r.target LIKE ? 
                 GROUP BY r.run_name;"
   ttype-id target-patt ))

(define (pgdb:get-all-run-stats-target-slice dbh target-patt limit offset)
    (dbi:get-rows
    dbh
    "SELECT  r.target, r.run_name,r.event_time, COUNT(*) AS total,
                    SUM(CASE WHEN t.status='PASS' THEN 1 ELSE 0 END) AS pass,
                    SUM(CASE WHEN t.status='FAIL' THEN 1 ELSE 0 END) AS fail,
                    SUM(CASE WHEN t.status IN ('PASS','FAIL') THEN 0 ELSE 1 END) AS other
            FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id
            WHERE r.target LIKE ? 
            GROUP BY r.target,r.run_name, r.event_time
             order by r.target,r.event_time desc limit  ? offset ?   ;"
    target-patt limit offset))
     

(define (pgdb:get-count-data-stats-target-slice dbh target-patt)
  (dbi:get-rows
   dbh
    "SELECT count(*)  from (SELECT  r.target, r.run_name,r.event_time, COUNT(*) AS total
            FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id
            WHERE r.target LIKE ?
            GROUP BY r.target,r.run_name, r.event_time 
          ) as x;" 
    target-patt))

(define  (pgdb:get-slice-cnt dbh target-patt)
  (let* ((cnt-result (pgdb:get-count-data-stats-target-slice dbh target-patt))
         ;(cnt-row (car (cnt-result)))
         (cnt 0) 
       )
    (for-each
     (lambda (row)
      (set! cnt  (vector-ref row 0 ))) 
     cnt-result)

cnt))
   

(define (pgdb:get-target-types dbh)
  (dbi:get-rows dbh "SELECT id,target_spec FROM ttype;"))
 
 (define (pgdb:get-distict-target-slice dbh)
  (dbi:get-rows dbh " select distinct on (split_part (target, '/', 1)) (split_part (target, '/', 1)) from runs;"))

  (define (pgdb:get-distict-target-slice3 dbh)
  (dbi:get-rows dbh " select distinct on (split_part (target, '/', 3)) (split_part (target, '/', 3)) from runs;"))
;; 
(define (pgdb:get-targets dbh target-patt)
  (let ((ttypes (pgdb:get-target-types dbh)))
    (map
     (lambda (ttype-dat)
       (let ((tt-id (vector-ref ttype-dat 0))
	     (ttype (vector-ref ttype-dat 1)))
285
286
287
288
289
290
291














292
293
294
295
296
297
298
299


















300
301
302
303
304
305
306

;; create a hash of hashes with keys extracted from all-parts
;; using row-or-col to choose row or column
;;   ht{row key}=>ht{col key}=>data
;;
;; fnum is the field number in the tuples to be split
;;














(define (pgdb:coalesce-runs dbh runs all-parts row-or-col fnum)
  (let* ((data  (make-hash-table)))
    ;;	 (rnums (
    ;; for now just do first => remainder
    (for-each
     (lambda (run)
       (let* ((target (vector-ref run fnum))
	      (parts  (string-split target "/"))


















	      (first  (car parts))
	      (rest   (string-intersperse (cdr parts) "/"))
	      (coldat (hash-table-ref/default data first #f)))
	 (if (not coldat)(let ((newht (make-hash-table)))
			   (hash-table-set! data first newht)
			   (set! coldat newht)))
	 (hash-table-set! coldat rest run)))







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


|
<




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







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

;; create a hash of hashes with keys extracted from all-parts
;; using row-or-col to choose row or column
;;   ht{row key}=>ht{col key}=>data
;;
;; fnum is the field number in the tuples to be split
;;

(define (pgdb:mk-pattern  dot type bp rel)
  (let* ((typ (if (equal? type "all")
               "%"
                type))
        (dotprocess (if (equal? dot "all")
                      "%"
                     dot))
        (rel-num (if (equal? rel "")
                      "%"
                     rel))
        (pattern  (conc "%/" bp "/" dotprocess "/" typ "_" rel-num)))
pattern))

(define (pgdb:coalesce-runs dbh runs all-parts row-or-col fnum)
  (let* ((data  (make-hash-table)))
    

    (for-each
     (lambda (run)
       (let* ((target (vector-ref run fnum))
	      (parts  (string-split target "/"))
	      (first  (car parts))
	      (rest   (string-intersperse (cdr parts) "/"))
	      (coldat (hash-table-ref/default data first #f)))
	 (if (not coldat)(let ((newht (make-hash-table)))
			   (hash-table-set! data first newht)
			   (set! coldat newht)))
	 (hash-table-set! coldat rest run)))
     runs)
    data))


(define (pgdb:coalesce-runs1 runs  )
  (let* ((data  (make-hash-table)))
    
    (for-each
     (lambda (run)
       (let* ((target (vector-ref run 0))
	      (parts  (string-split target "/"))
	      (first  (car parts))
	      (rest   (string-intersperse (cdr parts) "/"))
	      (coldat (hash-table-ref/default data first #f)))
	 (if (not coldat)(let ((newht (make-hash-table)))
			   (hash-table-set! data first newht)
			   (set! coldat newht)))
	 (hash-table-set! coldat rest run)))
377
378
379
380
381
382
383










  (let* ((data  (make-hash-table)))
     (for-each
     (lambda (run)
       (let* ((run-name (vector-ref run 0)))
	 (hash-table-set! data run-name run)))
     runs)
    data))

















>
>
>
>
>
>
>
>
>
>
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
  (let* ((data  (make-hash-table)))
     (for-each
     (lambda (run)
       (let* ((run-name (vector-ref run 0)))
	 (hash-table-set! data run-name run)))
     runs)
    data))

(define (pgdb:get-pg-lst tab2-pages)
    (let loop ((i 1)
             (lst `()))
                       (cond
                        ((> i tab2-pages )
                        lst) 
                      (else 
		  	(loop (+ i 1) (append   lst (list i)))))))

Added cgisetup/pages/filter-defs-template.scm version [af1a6727be].







>
>
>
1
2
3
(define *p* '("a" "b" "c"))
(define *k* '("all" "a"))
(define *d* '("all" 1 2 3 6 5 8 11 12))

Modified cgisetup/pages/home.scm from [25e1fcbe47] to [a4707fbef0].

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

14
15
16
;;======================================================================
;; Copyright 2017, 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 regex)
(load "models/pgdb.scm")

(include "pages/home_ctrl.scm")
(include "pages/home_view.scm")














>



1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
;;======================================================================
;; Copyright 2017, 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 regex)
(load "models/pgdb.scm")
(include "pages/filter-defs.scm")
(include "pages/home_ctrl.scm")
(include "pages/home_view.scm")

Modified cgisetup/pages/home_ctrl.scm from [e5b104a203] to [64b5eee90a].

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

;; a function <pagename>-action is called on POST

(define (home-action action)
  (case (string->symbol action)
    ((filter)
     (let ((target-type   (s:get-input 'target-type))
	   (target-filter (s:get-input 'tfilter))
	   (target        (s:get-input 'target))
	   (row-or-col    (s:get-input 'row-or-col)))
       ;;
       ;; s:set! is a page local var. Better than s:session-var-set! but still not a good idea.
       ;;
       (s:set! "row-or-col" (if (list? row-or-col)
				(string-intersperse row-or-col ",")
				row-or-col))
       (s:set! "target-type" target-type)
       (s:set! "tfilter" target-filter)
       (s:set! "target"  target)
       (s:set! "target-filter" target-filter)))
((filter2)
     (let ((tslice-select   (s:get-input 'tslice-select))
	   (t-slice-filter (s:get-input 't-slice-filter)))
       ;;
       ;; s:set! is a page local var. Better than s:session-var-set! but still not a good idea.
       ;;
       (s:set! "tslice" tslice-select)
       (s:set! "t-slice-patt" t-slice-filter)))
))








|
|
|
|



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

10
11
12
13
14
15
16
17
18
19
20
21
22
23
24


25
26
27
28






29


30
;;======================================================================

;; a function <pagename>-action is called on POST

(define (home-action action)
  (case (string->symbol action)
    ((filter)
     (let ((dot   (s:get-input 'dot))
	   (type (s:get-input 'kit-type))
	   (rel        (s:get-input 'rel-num))
           (bp (s:get-input 'bp)))
       ;;
       ;; s:set! is a page local var. Better than s:session-var-set! but still not a good idea.
       ;;
       


       (s:set! "dot" dot)
       (s:set! "type"  type)
       (s:set! "bp"  bp)







       (s:set! "rel" rel)))))



Modified cgisetup/pages/home_view.scm from [4f70880903] to [f43ad9b3a3].

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

(define (pages:home session db shared)

  (let* ((dbh         (s:db))




	 (ttypes      (pgdb:get-target-types dbh))




	 (selected    (string->number (or (s:get "target-type") "-1")))

         (target-slice (pgdb:get-distict-target-slice dbh)) 
         (selected-slice (or (s:get "tslice") ""))  
	 (curr-trec   (filter (lambda (x)(eq? selected (vector-ref x 0))) ttypes))
	 (curr-ttype  (if (and selected
			       (not (null? curr-trec)))
			  (vector-ref (car curr-trec) 1) #f))
	 (all-parts   (if curr-ttype (append (string-split curr-ttype "/") '("runname" "testname")) '()))


	 (tfilter     (or (s:get "target-filter") "%"))
         (tslice-filter     (or (s:get "t-slice-patt") ""))


         (target-patt   (if (or (equal? selected-slice "") (equal? tslice-filter "" ))


                             "" 
                           (conc selected-slice "/" tslice-filter )))
         (tab2-data (if (equal? target-patt "")
                         `()
                         (pgdb:get-all-run-stats-target-slice dbh target-patt)))
         (tab2-ordered-data (pgdb:coalesce-runs-by-slice tab2-data selected-slice))  
	 (targets     (pgdb:get-targets-of-type dbh selected tfilter))
	 (row-or-col  (string-split (or (s:get "row-or-col") "") ","))
	 (all-data    (if (and selected
			       (not (eq? selected -1)))
                          (pgdb:get-latest-run-stats-given-target dbh selected tfilter)
                           '()  
			 ; (pgdb:get-stats-given-type-target dbh selected tfilter)
			 ; (pgdb:get-stats-given-target dbh tfilter)
			  ))



  (ordered-data (pgdb:coalesce-runs dbh all-data all-parts row-or-col 0)))



   (s:div 'class "col_12" 
        (s:ul 'class "tabs left"
      	(s:li (s:a 'href "#tabr1" "Sliced Filter"))
        (s:li (s:a 'href "#tabr2" "Genral Filter")))
  (s:div 'id "tabr1" 'class "tab-content"
      (s:div 'class "col_11" 
      (s:fieldset    "Filter Targets by slice"
	    (s:form
	     'action "home.filter2" 'method "post"
	     (s:div 'class "col_12"
		    (s:div 'class "col_6"
			   (s:select (map (lambda (x)
					    (let ((t-slice (vector-ref x 0)))
					      (if (equal? t-slice selected-slice)
						  (list t-slice t-slice t-slice #t)
						  (list t-slice t-slice t-slice #f))))
					  target-slice)
				     'name 'tslice-select))
		    (s:div 'class "col_4"
			   (s:input-preserve 'name "t-slice-filter" 'placeholder "Filter remainder target"))
		    (s:div 'class "col_2"
			   (s:input 'type "submit" 'name "set-filter-vals" 'value "Submit")))))
      (s:br) 
      (s:p "&nbsp;&nbsp;Result Format: &nbsp;&nbsp;total / pass / fail / other")
      (s:fieldset	    (conc "Runs data for " target-patt) 
          (let* ((target-keys (hash-table-keys tab2-ordered-data))
		  (run-keys (delete-duplicates (apply  append (map (lambda (sub-key)
					 (let ((subdat (hash-table-ref  tab2-ordered-data sub-key)))
					   (hash-table-keys subdat)))
				       target-keys)))))
            (s:table  'class "striped"
		   (s:tr  (s:th  'class "heading" ) 
 			(map
                	(lambda (th-key) 
                         (s:th 'class "heading" th-key )) 
                    run-keys))
		   (map
		    (lambda (row-key)
		      (s:tr (s:td row-key)
			    (map
			     (lambda (col-key)
			       (let ((val (let* ((ht  (hash-table-ref/default  tab2-ordered-data row-key #f)))
					    (if ht (hash-table-ref/default ht col-key #f)))))
				 (if val
				     (let* ((total (vector-ref val 3))
					    (pass  (vector-ref val 4))
					    (fail  (vector-ref val 5))
					    (other (vector-ref val 6))
					    (passper (round (* (/ pass total) 100)))
					    (target-param (string-substitute "[/]" "_x_" (conc selected-slice "/" row-key) 'all)))
				       (s:td   'style (conc "background: -webkit-linear-gradient(left, green " passper "%, red); background: -o-linear-gradient(right, green " passper "%, red); background: -moz-linear-gradient(right, green " passper "%, red); background: linear-gradient(to right, green " passper "%, red);")
      				      (s:a 'class "white"  'href (s:link-to "run" 'target target-param 'run col-key)
(conc  total "/" pass "/" fail "/" other))))
				     (s:td ""))))
			     run-keys)))
		    target-keys))
))
))
    (s:div 'id "tabr2" 'class "tab-content"
      (s:div 'class "col_11"
	   (s:fieldset    "Area type and target filter"
	    (s:form
	     'action "home.filter#tabr2" 'method "post"
	     (s:div 'class "col_12"
		    (s:div 'class "col_6"
			   (s:select (map (lambda (x)
					    (if x
						(let ((tt-id (vector-ref x 0))

						      (ttype (vector-ref x 1)))



						  (if (eq? tt-id selected)
						      (list ttype tt-id ttype #t)
						      (list ttype tt-id ttype #f)))
						(list "all" -1 "all" (eq? selected -1))))
					  (cons #f ttypes))

				     'name 'target-type))

		    (s:div 'class "col_4"
			   (s:input-preserve 'name "tfilter" 'placeholder "Filter targets"))

		    (s:div 'class "col_2"
			   (s:input 'type "submit" 'name "set-filter-vals" 'value "Submit")))))
           (s:br) 





           (s:p "&nbsp;&nbsp;Result Format: &nbsp;&nbsp;total / pass / fail / other")


           	   (s:fieldset	    (conc "Runs data for " tfilter)
	    ;;
	    ;; A very basic display
	    ;;
	    (let* ((a-keys (pgdb:ordered-data->a-keys ordered-data))
		   (b-keys (pgdb:ordered-data->b-keys ordered-data a-keys)))
	      ;; (c-keys (delete-duplicates b-keys)))
	      (if #f ;; swap rows/cols
		  (s:table
		    (s:tr (s:td "")(map s:tr b-keys))
		   (map
		    (lambda (row-key)
		      (let ((subdat (hash-table-ref ordered-data row-key)))
			(s:tr (s:td row-key)
			      (map
			       (lambda (col-key)
				 (s:td (let ((dat (hash-table-ref/default subdat col-key #f)))
					 (s:td (if dat
						   (list (vector-ref dat 0)(vector-ref dat 1))
						   "")))))
			       b-keys))))
		    a-keys))
		  (s:table  'class "striped"
		   (s:tr  (s:th  'class "heading" ) 
 			(map
                	(lambda (th-key) 
                         (s:th 'class "heading" th-key )) 
                    a-keys))
		   (map
		    (lambda (row-key)
		      (s:tr (s:td row-key)
			    (map
			     (lambda (col-key)
			       (let ((val (let* ((ht  (hash-table-ref/default ordered-data col-key #f)))
					    (if ht (hash-table-ref/default ht row-key #f)))))
				 (if val
				     (let* ((total (vector-ref val 1))

					    (pass  (vector-ref val 2))
					    (fail  (vector-ref val 3))
					    (other (vector-ref val 4))
                                            (id (vector-ref val 5)) 
					    (passper (round (* (/ pass total) 100)))
					    (failper (- 100 passper))
                                             (history (pgdb:get-run-stats-history-given-target dbh selected (conc col-key "/" row-key)))  
         				     (history-hash (pgdb:get-history-hash history))
                                             (history-keys (sort (hash-table-keys history-hash) string>=?))
					    (run-key (string-substitute "[/]" "_x_" (conc col-key "/" row-key) 'all)))
				       (s:td   'style (conc "background: -webkit-linear-gradient(left, green " passper "%, red); background: -o-linear-gradient(right, green " passper "%, red); background: -moz-linear-gradient(right, green " passper "%, red); background: linear-gradient(to right, green " passper "%, red);")
      				      (s:a 'class "white"  'href (s:link-to "run" 'target run-key)
					  (conc "Latest:" total "/" pass "/" fail "/" other)) (s:span " | ") (s:a 'id id 'class "viewmodal"  'title "Click to see description"  "History") (s:br)
                                   (s:div 'id (conc "myModal" id) 'class "modal"
                                        (s:div 'class "modal-content"
                                             (s:span 'id id 'class "close" "&times;") 
    						;(s:p (conc "Modal " id ".."))
                                                 (s:div                                                  
                                                          (s:table 
                                                             (s:tr












>

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


|
>
>
>
|
>
>
>


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



|

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


|
>
>
>
>
>

>
>
|
<
<
<
|

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













|
>
|
|
|
|


|





|







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

(define (pages:home session db shared)
  
  (let* ((dbh         (s:db))
         (limit 50)
         (curr-page   (if (or (equal? (s:get-param "pg") "") (equal? (s:get-param "pg") #f))
                      1
                        (string->number (s:get-param "pg"))))
         
         (offset (- (* limit  curr-page) limit))     
         (dot    (if (s:get-param "dot")
                           (string->number (s:get-param "dot"))
                           (if (and  (s:get "dot") (not (equal? (s:get "dot") "all")))
                             (string->number (s:get "dot"))
                              "all")))
         (type    (if (s:get-param "type")
                           (s:get-param "type")

                       (if (and (s:get "type") (not (equal? (s:get "type") "all")))
                              (s:get "type")
                              "all")))

          (bp    (if (s:get-param "bp")
                           (s:get-param "bp")
                       (if (s:get "bp") 
                              (s:get "bp")
                              "p1273")))
           (rel    (if (s:get-param "rel")
                           (s:get-param "rel")
                       (if (and  (s:get "rel") (not (equal? (s:get "rel") "all")))
                              (s:get "rel")
                              ""))) 

          (pattern  (pgdb:mk-pattern dot type bp rel)) 	 



	; (targets     (pgdb:get-targets-of-type dbh selected tfilter))
	            


	 (all-data       (pgdb:get-latest-run-stats-given-pattern dbh pattern  limit offset))
                           ;'()  )
			 ; (pgdb:get-stats-given-type-target dbh selected tfilter)
			 ; (pgdb:get-stats-given-target dbh tfilter)
			  
         (cnt     (pgdb:get-latest-run-cnt-by-pattern dbh pattern))
         (total-pages (ceiling (/ cnt  limit))) 
         (page-lst (pgdb:get-pg-lst total-pages))
         (ordered-data (pgdb:coalesce-runs1 all-data))
         (rel-val (if (equal? rel "")
                       "%"
                        rel)))
   (s:div 'class "col_12" 
        (s:ul 'class "tabs left"
          








        (map (lambda (x)










            	(s:li (s:a 'href (conc "#" x) x)))









	  *process*))
       (map (lambda (x)
        























       (s:div 'id  x 'class "tab-content"
      (s:div 'class "col_11"
	   (s:fieldset    "Area type and target filter"
	    (s:form
	     'action (conc "home.filter#" x) 'method "post"
	     (s:div 'class "col_12"
                        (s:div 'class "col_3"
			   (s:label "Release Type") (s:select (map (lambda (x)
                                           (if (equal?  x type)  
                                            (list x x x #t)
                                            (list x x x #f)) )
					  *kit-types*)
				     'name "kit-type"))
                   (s:div 'class "col_3"
			   (s:label "Dot") (s:select (map (lambda (x)
                                            (if (equal?  x dot)  
                                            (list x x x #t)
                                            (list x x x #f)))


					  *dots*)
				     'name "dot"))

		   (s:div 'class "col_3"
                            (s:input 'type "hidden" 'value x 'name "bp")
			   (s:label "Release #") (s:input 'type "text" 'name "rel-num" 'value rel-val))
		    (s:div 'class "col_2"
			   (s:input 'type "submit" 'name "set-filter-vals" 'value "Submit")))))
           (s:br)
           ;(s:p (conc dot(string? dot) )) 
             (s:p (map
            (lambda (i) 
          (s:span (s:a 'href (s:link-to "home" 'pg i ) "PAGE " i  )"&nbsp;|&nbsp;"))  
          page-lst))
           (s:p "&nbsp;&nbsp;Result Format: &nbsp;&nbsp;total / pass / fail / other")
            (if (equal? x bp)
             (begin 
           (s:fieldset	    (conc "Runs data for " pattern)



	      (let* ((a-keys (pgdb:ordered-data->a-keys ordered-data))
		   (b-keys (pgdb:ordered-data->b-keys ordered-data a-keys)))
















  		  (s:table  'class "striped"
		   (s:tr  (s:th  'class "heading" ) 
 			(map
                	(lambda (th-key) 
                         (s:th 'class "heading" th-key )) 
                    a-keys))
		   (map
		    (lambda (row-key)
		      (s:tr (s:td row-key)
			    (map
			     (lambda (col-key)
			       (let ((val (let* ((ht  (hash-table-ref/default ordered-data col-key #f)))
					    (if ht (hash-table-ref/default ht row-key #f)))))
				 (if val
				     (let* ((total (vector-ref val 2))
                                            (event-time (vector-ref val 1)) 
					    (pass  (vector-ref val 3))
					    (fail  (vector-ref val 4))
					    (other (vector-ref val 5))
                                            (id (vector-ref val 6)) 
					    (passper (round (* (/ pass total) 100)))
					    (failper (- 100 passper))
                                             (history (pgdb:get-run-stats-history-given-target dbh 1 (conc col-key "/" row-key)))  
         				     (history-hash (pgdb:get-history-hash history))
                                             (history-keys (sort (hash-table-keys history-hash) string>=?))
					    (run-key (string-substitute "[/]" "_x_" (conc col-key "/" row-key) 'all)))
				       (s:td   'style (conc "background: -webkit-linear-gradient(left, green " passper "%, red); background: -o-linear-gradient(right, green " passper "%, red); background: -moz-linear-gradient(right, green " passper "%, red); background: linear-gradient(to right, green " passper "%, red);")
      				      (s:a 'class "white"  'href (s:link-to "run" 'target run-key)
					  (conc "Latest:" total "/" pass "/" fail "/" other)) (s:span "  | ") (s:a 'id id 'class "viewmodal"  'title "Click to see description"  "History") (s:br)
                                   (s:div 'id (conc "myModal" id) 'class "modal"
                                        (s:div 'class "modal-content"
                                             (s:span 'id id 'class "close" "&times;") 
    						;(s:p (conc "Modal " id ".."))
                                                 (s:div                                                  
                                                          (s:table 
                                                             (s:tr
187
188
189
190
191
192
193
194
195
196
197
198
199
200


201

                                                                         (hpass (vector-ref history-row 2))
                                                                         (hfail (vector-ref history-row 3))
                                                                         (hother (vector-ref history-row 4))
                                                                         (passper (round (* (/ hpass htotal) 100))))
                                                                (s:tr (s:td  history-key)
                                                                      (s:td 'style (conc "background: -webkit-linear-gradient(left, green " passper "%, red); background: -o-linear-gradient(right, green " passper "%, red); background: -moz-linear-gradient(right, green " passper "%, red); background: linear-gradient(to right, green " passper "%, red);")
(conc  htotal "/" hpass "/" hfail "/" hother )))))
                                                              history-keys)))

))
 ))
				     (s:td ""))))
			     a-keys)))
		    b-keys)))))))


)))








|
<
<
<


|
>
>
|
>
145
146
147
148
149
150
151
152



153
154
155
156
157
158
159
                                                                         (hpass (vector-ref history-row 2))
                                                                         (hfail (vector-ref history-row 3))
                                                                         (hother (vector-ref history-row 4))
                                                                         (passper (round (* (/ hpass htotal) 100))))
                                                                (s:tr (s:td  history-key)
                                                                      (s:td 'style (conc "background: -webkit-linear-gradient(left, green " passper "%, red); background: -o-linear-gradient(right, green " passper "%, red); background: -moz-linear-gradient(right, green " passper "%, red); background: linear-gradient(to right, green " passper "%, red);")
(conc  htotal "/" hpass "/" hfail "/" hother )))))
                                                              history-keys)))))))



				     (s:td ""))))
			     a-keys)))
		    b-keys))))
)
(begin 
(s:p ""))))))
 *process*))))

Modified cgisetup/pages/index.scm from [5f74568a94] to [33603d85dd].

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

13
14
15
16
;;======================================================================
;; Copyright 2017, 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 regex)

;; (load "models/pgdb.scm")
(include "pages/index_ctrl.scm")
(include "pages/index_view.scm")













>

|
|

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
;;======================================================================
;; Copyright 2017, 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 regex)

;; (load "models/pgdb.scm")
(include  "pages/index_ctrl.scm")
(include  "pages/index_view.scm")

Modified cgisetup/pages/index_ctrl.scm from [afbe8a90ae] to [1874aaac3c].

60
61
62
63
64
65
66
67
68
69
70
71
72
<script type="text/javascript" src="https://ajax.googleapis.com/ajax/libs/jquery/1.6.4/jquery.min.js"></script>
<!--[if lt IE 9]><script src="http://html5shiv.googlecode.com/svn/trunk/html5.js"></script><![endif]-->
EOF
))

(define index:javascript
#<<EOF
<script type="text/javascript" src="/js/prettify.js"></script>                                   <!-- PRETTIFY -->
<script type="text/javascript" src="/js/kickstart.js"></script>                                  <!-- KICKSTART -->
<script type="text/javascript" src="/js/pjhatwal-modal.js "></script>                          <!-- Modal -->
EOF
)








|





60
61
62
63
64
65
66
67
68
69
70
71
72
<script type="text/javascript" src="https://ajax.googleapis.com/ajax/libs/jquery/1.6.4/jquery.min.js"></script>
<!--[if lt IE 9]><script src="http://html5shiv.googlecode.com/svn/trunk/html5.js"></script><![endif]-->
EOF
))

(define index:javascript
#<<EOF
<!-- <script type="text/javascript" src="/js/prettify.js"></script>                                  PRETTIFY -->
<script type="text/javascript" src="/js/kickstart.js"></script>                                  <!-- KICKSTART -->
<script type="text/javascript" src="/js/pjhatwal-modal.js "></script>                          <!-- Modal -->
EOF
)

Modified cgisetup/pages/index_view.scm from [7dcf5f509d] to [5626af0f40].

20
21
22
23
24
25
26







27
28
29
30
31
32
	  (s:title (conc "Megatest")) 
	  (s:head
	   index:kickstart-junk
	   ) 
	  (s:body
	   (s:div 'class "grid flex" 'id "top_of_page"
		  ;; add visible to columns to help visualize them e.g. "col_12 visible"







		  (case (string->symbol page-name)
		    ((index)  (s:call "home"))
		    (else     (s:call page-name))))
	   index:jquery
	   index:javascript
	   ))))))







>
>
>
>
>
>
>






20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
	  (s:title (conc "Megatest")) 
	  (s:head
	   index:kickstart-junk
	   ) 
	  (s:body
	   (s:div 'class "grid flex" 'id "top_of_page"
		  ;; add visible to columns to help visualize them e.g. "col_12 visible"
                  (s:ul 'class "menu"
(s:li (s:a 'href ""  (s:i 'class "fa fa-inbox") "QA Summary")
      (s:ul
	(s:li (s:a 'href "/cgi-bin/megatest.sh/home"  "Component Snapshot"))
        (s:li (s:a 'href "/cgi-bin/megatest.sh/kitprogress"  "Kit/Contour progress"))
 )))
;(s:li (s:a 'href (s:link-to "run" ) "Runs"))) 
		  (case (string->symbol page-name)
		    ((index)  (s:call "home"))
		    (else     (s:call page-name))))
	   index:jquery
	   index:javascript
	   ))))))

Modified client.scm from [950fa4a4a2] to [b8e0e236d3].

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

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

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

(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest matchable)
;; (use zmq)

(use (prefix sqlite3 sqlite3:))

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

(declare (unit client))

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








<
|
|
<
<
<
<
|







8
9
10
11
12
13
14

15
16




17
18
19
20
21
22
23
24
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

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


(use srfi-18 extras tcp s11n srfi-1 posix regex srfi-69 hostinfo md5
     message-digest matchable spiffy uri-common intarweb http-client




     spiffy-request-vars uri-common intarweb directory-utils)

(declare (unit client))

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

Added codescanlib.scm version [85429a3289].































































































































































































































































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

;; gotta compile with csc, doesn't work with csi -s for whatever reason

(use srfi-69)
(use matchable)
(use utils)
(use ports)
(use extras)
(use srfi-1)
(use posix)
(use srfi-12)

;; turn scheme file to a list of sexps, sexps of interest will be in the form of (define (<procname> <args>) <body> )
(define (load-scm-file scm-file)
  ;;(print "load "scm-file)
  (handle-exceptions
   exn
   '()
   (with-input-from-string
       (conc "("
             (with-input-from-file scm-file read-all)
             ")" )
     read)))

;; extract a list of procname, filename, args and body of procedures defined in filename, input from load-scm-file
;;   -- be advised:
;;      * this may be fooled by macros, since this code does not take them into account.
;;      * this code does only checks for form (define (<procname> ... ) <body>)
;;           so it excludes from reckoning
;;               - generated functions, as in things like foo-set! from defstructs,
;;               - define-inline, (
;;               - define procname (lambda ..
;;               - etc...
(define (get-toplevel-procs+file+args+body filename)
  (let* ((scm-tree (load-scm-file filename))
         (procs
          (filter identity
                  (map
                   (match-lambda 
                    [('define ('uses args ...) body ...) #f] ;; filter out (define (uses ...
                    [('define ('unit args ...) body ...) #f] ;; filter out (define (unit ...
                    [('define ('prefix args ...) body ...) #f] ;; filter out (define (prefix ...
                    [('define (defname args ...) body ...) ;; match (define (procname <args>) <body>)
                     (if (atom? defname) ;; filter out things we dont understand (procname is a list, what??)
                         (list defname filename args body)
                         #f)]
                    [else #f] ) scm-tree))))
    procs))


;; given a sexp, return a flat lost of atoms in that sexp
(define (get-atoms-in-body body)
  (cond
   ((null? body) '())
   ((atom? body) (list body))
   (else
    (apply append (map get-atoms-in-body body)))))

;;  given a file, return a list of procname, file, list of atoms in said procname
(define (get-procs+file+atoms file)
  (let* ((toplevel-proc-items (get-toplevel-procs+file+args+body file))
         (res
          (map
           (lambda (item)
             (let* ((proc (car item))
                    (file (cadr item))
                    (args (caddr item))
                    (body (cadddr item))
                    (atoms (append (get-atoms-in-body args) (get-atoms-in-body body))))
               (list proc file atoms)))
           toplevel-proc-items)))
    res))

;; uniquify a list of atoms 
(define (unique-atoms lst)
  (let loop ((lst (flatten lst)) (res '()))
    (if (null? lst)
        (reverse res)
        (let ((c (car lst)))
          (loop (cdr lst) (if (member c res) res (cons c res)))))))

;; given a list of procname, filename, list of procs called from procname, cross reference and reverse
;; returning alist mapping procname to procname that calls said procname
(define (get-callers-alist all-procs+file+calls)
  (let* ((all-procs (map car all-procs+file+calls))
         (caller-ht (make-hash-table))) 
    ;; let's cross reference with a hash table
    (for-each (lambda (proc) (hash-table-set! caller-ht proc '())) all-procs)
    (for-each (lambda (item)
               (let* ((proc (car item))
                      (file (cadr item))
                      (calls (caddr item)))
                 (for-each (lambda (callee)
                             (hash-table-set! caller-ht callee
                                              (cons proc
                                                    (hash-table-ref caller-ht callee))))
                           calls)))
              all-procs+file+calls)
    (map (lambda (x)
           (let ((k (car x))
                 (r (unique-atoms (cdr x))))
             (cons k r)))                    
         (hash-table->alist caller-ht))))

;; create a handy cross-reference of callees to callers in the form of an alist.
(define (get-xref all-scm-files)
  (let* ((all-procs+file+atoms
          (apply append (map get-procs+file+atoms all-scm-files)))
         (all-procs (map car all-procs+file+atoms))
         (all-procs+file+calls  ; proc calls things in calls list
          (map (lambda (item)
                 (let* ((proc (car item))
                        (file (cadr item))
                        (atoms (caddr item))
                        (calls
                         (filter identity
                                 (map
                                  (lambda (x)
                                    (if (and ;; (not (equal? x proc))  ;; uncomment to prevent listing self
                                         (member x all-procs))
                                        x
                                        #f))
                                  atoms))))
                   (list proc file calls)))
               all-procs+file+atoms))
         (callers (get-callers-alist all-procs+file+calls))) 
    callers))

Modified common.scm from [eb2e308b10] to [f2280c4528].

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
;;======================================================================
;; Copyright 2006-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 srfi-1 data-structures posix regex-case (prefix base64 base64:)
     format dot-locking csv-xml z3 ;; sql-de-lite
     hostinfo md5 message-digest typed-records directory-utils stack
     matchable regex posix (srfi 18) extras ;; tcp 
     (prefix nanomsg nmsg:)
     (prefix sqlite3 sqlite3:)
     )

(declare (unit common))

(include "common_records.scm")

;; (require-library margs)












<
<
|
<
|







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


13

14
15
16
17
18
19
20
21
;;======================================================================
;; 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 srfi-1 data-structures posix regex-case (prefix base64 base64:)


     matchable regex posix srfi-18 extras pkts (prefix dbi dbi:)

     (prefix sqlite3 sqlite3:) typed-records directory-utils
     )

(declare (unit common))

(include "common_records.scm")

;; (require-library margs)
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
(define common:get-area-name common:get-testsuite-name)

;; WARNING: This code falls back to using the global Megatest
;;          variable *toppath*
;; 
(define (common:get-db-tmp-area #!key (dbstruct #f))
  (if (and dbstruct (dbr:dbstruct-tmpdb-path dbstruct)) ;; *db-cache-path*
      (dbr:dbstruct-tmpdb-path) ;; *db-cache-path*
      (let ((toppath (or (and dbstruct (dbr:dbstruct-area-path dbstruct)) *toppath*))
	    (tsname  (or (and dbstruct (dbr:dbstruct-area-name dbstruct))(common:get-testsuite-name))))
	(if toppath ;; common:get-create-writeable-dir
	    (handle-exceptions
		exn
		(begin
		  (debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir)







|







635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
(define common:get-area-name common:get-testsuite-name)

;; WARNING: This code falls back to using the global Megatest
;;          variable *toppath*
;; 
(define (common:get-db-tmp-area #!key (dbstruct #f))
  (if (and dbstruct (dbr:dbstruct-tmpdb-path dbstruct)) ;; *db-cache-path*
      (dbr:dbstruct-tmpdb-path dbstruct) ;; *db-cache-path*
      (let ((toppath (or (and dbstruct (dbr:dbstruct-area-path dbstruct)) *toppath*))
	    (tsname  (or (and dbstruct (dbr:dbstruct-area-name dbstruct))(common:get-testsuite-name))))
	(if toppath ;; common:get-create-writeable-dir
	    (handle-exceptions
		exn
		(begin
		  (debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir)
863
864
865
866
867
868
869
870


871
872
873
874
875
876
877
878
      #f
      (let loop ((hed (car dirs))
		 (tal (cdr dirs)))
	(let ((res (or (and (directory? hed)
			    (file-write-access? hed)
			    hed)
		       (handle-exceptions
			exn


			#f
			(create-directory hed #t)))))
	  (if (and (string? res)
		   (directory? res))
	      res
	      (if (null? tal)
		  #f
		  (loop (car tal)(cdr tal))))))))







|
>
>
|







860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
      #f
      (let loop ((hed (car dirs))
		 (tal (cdr dirs)))
	(let ((res (or (and (directory? hed)
			    (file-write-access? hed)
			    hed)
		       (handle-exceptions
			   exn
			   (begin
			     (debug:print-info 0 *default-log-port* "could not create " hed ", this might cause problems down the road.")
			     #f)
			(create-directory hed #t)))))
	  (if (and (string? res)
		   (directory? res))
	      res
	      (if (null? tal)
		  #f
		  (loop (car tal)(cdr tal))))))))
1012
1013
1014
1015
1016
1017
1018
1019




1020
1021
1022
1023
1024
1025
1026
1027
1028

(define (common:args-get-runname)
  (let ((res (or (args:get-arg "-runname")
		 (args:get-arg ":runname")
		 (getenv "MT_RUNNAME"))))
    ;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ...
    res))





(define (common:args-get-target #!key (split #f)(exit-if-bad #f))
  (let* ((keys    (if (hash-table? *configdat*) (keys:config-get-fields *configdat*) '()))
	 (numkeys (length keys))
	 (target  (or (args:get-arg "-reqtarg")
		      (args:get-arg "-target")
		      (getenv "MT_TARGET")))
	 (tlist   (if target (string-split target "/" #t) '()))
	 (valid   (if target
		      (or (null? keys) ;; probably don't know our keys yet








>
>
>
>

|







1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031

(define (common:args-get-runname)
  (let ((res (or (args:get-arg "-runname")
		 (args:get-arg ":runname")
		 (getenv "MT_RUNNAME"))))
    ;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ...
    res))

(define (common:get-fields cfgdat)
  (let ((fields (hash-table-ref/default cfgdat "fields" '())))
    (map car fields)))

(define (common:args-get-target #!key (split #f)(exit-if-bad #f))
  (let* ((keys    (if (hash-table? *configdat*) (common:get-fields *configdat*) '()))
	 (numkeys (length keys))
	 (target  (or (args:get-arg "-reqtarg")
		      (args:get-arg "-target")
		      (getenv "MT_TARGET")))
	 (tlist   (if target (string-split target "/" #t) '()))
	 (valid   (if target
		      (or (null? keys) ;; probably don't know our keys yet
1546
1547
1548
1549
1550
1551
1552
1553
1554




1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
          ((< (+ load (/ (random 250) 1000))         ;; add a random factor to keep from getting in a rut
              (+ best-load (/ (random 250) 1000))  )
           (set! best-load load)
           (set! best-host hostname)))))
     hosts)
    best-host))

(define (common:wait-for-cpuload maxload numcpus waitdelay #!key (count 1000) (msg #f)(remote-host #f))
  (let* ((loadavg (common:get-cpu-load remote-host))




	 (first   (car loadavg))
	 (next    (cadr loadavg))
	 (adjload (* maxload numcpus))
	 (loadjmp (- first next)))
    (cond
     ((and (> first adjload)
	   (> count 0))
      (debug:print-info 0 *default-log-port* "server start delayed " waitdelay " seconds due to load " first " exceeding max of " adjload " on server " (or remote-host (get-host-name)) " (normalized load-limit: " maxload ") " (if msg msg ""))
      (thread-sleep! waitdelay)
      (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host))







|

>
>
>
>


|







1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
          ((< (+ load (/ (random 250) 1000))         ;; add a random factor to keep from getting in a rut
              (+ best-load (/ (random 250) 1000))  )
           (set! best-load load)
           (set! best-host hostname)))))
     hosts)
    best-host))

(define (common:wait-for-cpuload maxload-in numcpus-in waitdelay #!key (count 1000) (msg #f)(remote-host #f))
  (let* ((loadavg (common:get-cpu-load remote-host))
	 (numcpus (if (< 1 numcpus-in) ;; not possible
		      (common:get-num-cpus remote-host)
		      numcpus-in))
	 (maxload (max maxload-in 0.5)) ;; so maxload must be greater than 0.5 for now BUG - FIXME?
	 (first   (car loadavg))
	 (next    (cadr loadavg))
	 (adjload (* maxload (max 1 numcpus))) ;; possible bug where numcpus (or could be maxload) is zero, crude fallback is to at least use 1
	 (loadjmp (- first next)))
    (cond
     ((and (> first adjload)
	   (> count 0))
      (debug:print-info 0 *default-log-port* "server start delayed " waitdelay " seconds due to load " first " exceeding max of " adjload " on server " (or remote-host (get-host-name)) " (normalized load-limit: " maxload ") " (if msg msg ""))
      (thread-sleep! waitdelay)
      (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host))
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
;; check space in dbdir and in megatest dir
;; returns: ok/not dbspace required-space
;;
(define (common:check-db-dir-space)
  (let* ((required (string->number 
		    (or (configf:lookup *configdat* "setup" "dbdir-space-required")
			"100000")))
	 (dbdir    (common:get-db-tmp-area)) ;; (db:get-dbdir))
	 (tdbspace (common:check-space-in-dir dbdir required))
	 (mdbspace (common:check-space-in-dir *toppath* required)))
    (sort (list tdbspace mdbspace) (lambda (a b)
				     (< (cadr a)(cadr b))))))
    
;; check available space in dbdir, exit if insufficient
;;







|







1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
;; check space in dbdir and in megatest dir
;; returns: ok/not dbspace required-space
;;
(define (common:check-db-dir-space)
  (let* ((required (string->number 
		    (or (configf:lookup *configdat* "setup" "dbdir-space-required")
			"100000")))
	 (dbdir    (common:get-db-tmp-area #f)) ;; (db:get-dbdir))
	 (tdbspace (common:check-space-in-dir dbdir required))
	 (mdbspace (common:check-space-in-dir *toppath* required)))
    (sort (list tdbspace mdbspace) (lambda (a b)
				     (< (cadr a)(cadr b))))))
    
;; check available space in dbdir, exit if insufficient
;;
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
   ((equal? status "WARN")    "orange")
   ((equal? status "KILLED")  "orange")
   ((equal? status "KILLREQ") "purple")
   ((equal? status "RUNNING") "blue")
   ((equal? status "ABORT")   "brown")
   (else "black")))

;;======================================================================
;; N A N O M S G   C L I E N T
;;======================================================================

(define (server:get-best-guess-address hostname)
  (let ((res #f))
    (for-each 
     (lambda (adr)
       (if (not (eq? (u8vector-ref adr 0) 127))
	   (set! res adr)))
     ;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME
     (vector->list (hostinfo-addresses (hostname->hostinfo hostname))))
    (string-intersperse 
     (map number->string
	  (u8vector->list
	   (if res res (hostname->ip hostname)))) ".")))


(define (common:send-dboard-main-changed)
  (let* ((dashboard-ips (mddb:get-dashboards)))
    (for-each
     (lambda (ipadr)
       (let* ((soc (common:open-nm-req (conc "tcp://" ipadr)))
	      (msg (conc "main " *toppath*))
	      (res (common:nm-send-receive-timeout soc msg)))
	 (if (not res) ;; couldn't reach that dashboard - remove it from db
	     (print "ERROR: couldn't reach dashboard " ipadr))
	 res))
     dashboard-ips)))
    
    
;;======================================================================
;; D A S H B O A R D   D B 
;;======================================================================

(define (mddb:open-db)
  (let* ((db (open-database (conc (get-environment-variable "HOME") "/.dashboard.db"))))
    (set-busy-handler! db (busy-timeout 10000))
    (for-each
     (lambda (qry)
       (exec (sql db qry)))
     (list 
      "CREATE TABLE IF NOT EXISTS vars       (id INTEGER PRIMARY KEY,key TEXT, val TEXT, CONSTRAINT varsconstraint UNIQUE (key));"
      "CREATE TABLE IF NOT EXISTS dashboards (
          id         INTEGER PRIMARY KEY,
          pid        INTEGER,
          username   TEXT,
          hostname   TEXT,
          ipaddr     TEXT,
          portnum    INTEGER,
          start_time TIMESTAMP DEFAULT (strftime('%s','now')),
             CONSTRAINT hostport UNIQUE (hostname,portnum)
        );"
      ))
    db))

;; register a dashboard 
;;
(define (mddb:register-dashboard port)
  (let* ((pid      (current-process-id))
	 (hostname (get-host-name))
	 (ipaddr   (server:get-best-guess-address hostname))
	 (username (current-user-name)) ;; (car userinfo)))
	 (db      (mddb:open-db)))
    (print "Register monitor, pid: " pid ", hostname: " hostname ", port: " port ", username: " username)
    (exec (sql db "INSERT OR REPLACE INTO dashboards (pid,username,hostname,ipaddr,portnum) VALUES (?,?,?,?,?);")
	   pid username hostname ipaddr port)
    (close-database db)))

;; unregister a monitor
;;
(define (mddb:unregister-dashboard host port)
  (let* ((db      (mddb:open-db)))
    (print "Register unregister monitor, host:port=" host ":" port)
    (exec (sql db "DELETE FROM dashboards WHERE hostname=? AND portnum=?;") host port)
    (close-database db)))

;; get registered dashboards
;;
(define (mddb:get-dashboards)
  (let ((db (mddb:open-db)))
    (query fetch-column
	   (sql db "SELECT ipaddr || ':' || portnum FROM dashboards;"))))
    
;;======================================================================
;;  T E S T   L A U N C H I N G   P E R   I T E M   W I T H   H O S T   T Y P E S
;;======================================================================
;; 
;; [hosts]
;; arm cubie01 cubie02







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







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
   ((equal? status "WARN")    "orange")
   ((equal? status "KILLED")  "orange")
   ((equal? status "KILLREQ") "purple")
   ((equal? status "RUNNING") "blue")
   ((equal? status "ABORT")   "brown")
   (else "black")))

;; ;;======================================================================
;; ;; N A N O M S G   C L I E N T
;; ;;======================================================================
;; 












;; 
;; 
;; (define (common:send-dboard-main-changed)
;;   (let* ((dashboard-ips (mddb:get-dashboards)))
;;     (for-each
;;      (lambda (ipadr)
;;        (let* ((soc (common:open-nm-req (conc "tcp://" ipadr)))
;; 	      (msg (conc "main " *toppath*))
;; 	      (res (common:nm-send-receive-timeout soc msg)))
;; 	 (if (not res) ;; couldn't reach that dashboard - remove it from db
;; 	     (print "ERROR: couldn't reach dashboard " ipadr))
;; 	 res))
;;      dashboard-ips)))
;;     
;;     
;; ;;======================================================================
;; ;; D A S H B O A R D   D B 
;; ;;======================================================================
;; 
;; (define (mddb:open-db)
;;   (let* ((db (open-database (conc (get-environment-variable "HOME") "/.dashboard.db"))))
;;     (set-busy-handler! db (busy-timeout 10000))
;;     (for-each
;;      (lambda (qry)
;;        (exec (sql db qry)))
;;      (list 
;;       "CREATE TABLE IF NOT EXISTS vars       (id INTEGER PRIMARY KEY,key TEXT, val TEXT, CONSTRAINT varsconstraint UNIQUE (key));"
;;       "CREATE TABLE IF NOT EXISTS dashboards (
;;           id         INTEGER PRIMARY KEY,
;;           pid        INTEGER,
;;           username   TEXT,
;;           hostname   TEXT,
;;           ipaddr     TEXT,
;;           portnum    INTEGER,
;;           start_time TIMESTAMP DEFAULT (strftime('%s','now')),
;;              CONSTRAINT hostport UNIQUE (hostname,portnum)
;;         );"
;;       ))
;;     db))
;; 
;; ;; register a dashboard 
;; ;;
;; (define (mddb:register-dashboard port)
;;   (let* ((pid      (current-process-id))
;; 	 (hostname (get-host-name))
;; 	 (ipaddr   (server:get-best-guess-address hostname))
;; 	 (username (current-user-name)) ;; (car userinfo)))
;; 	 (db      (mddb:open-db)))
;;     (print "Register monitor, pid: " pid ", hostname: " hostname ", port: " port ", username: " username)
;;     (exec (sql db "INSERT OR REPLACE INTO dashboards (pid,username,hostname,ipaddr,portnum) VALUES (?,?,?,?,?);")
;; 	   pid username hostname ipaddr port)
;;     (close-database db)))
;; 
;; ;; unregister a monitor
;; ;;
;; (define (mddb:unregister-dashboard host port)
;;   (let* ((db      (mddb:open-db)))
;;     (print "Register unregister monitor, host:port=" host ":" port)
;;     (exec (sql db "DELETE FROM dashboards WHERE hostname=? AND portnum=?;") host port)
;;     (close-database db)))
;; 
;; ;; get registered dashboards
;; ;;
;; (define (mddb:get-dashboards)
;;   (let ((db (mddb:open-db)))
;;     (query fetch-column
;; 	   (sql db "SELECT ipaddr || ':' || portnum FROM dashboards;"))))
    
;;======================================================================
;;  T E S T   L A U N C H I N G   P E R   I T E M   W I T H   H O S T   T Y P E S
;;======================================================================
;; 
;; [hosts]
;; arm cubie01 cubie02
2383
2384
2385
2386
2387
2388
2389





































































































2390
2391
2392
2393
2394
2395
2396
	 (mthome-cfgfile (conc *toppath* "/.mtviews.config")))
    (if (common:file-exists? mthome-cfgfile)
	(read-config mthome-cfgfile view-cfgdat #t))
    ;; we load the home dir file AFTER the MTRAH file so the user can clobber settings when running the dashboard in read-only areas
    (if (common:file-exists? home-cfgfile)
	(read-config home-cfgfile view-cfgdat #t))
    view-cfgdat))






































































































;;======================================================================
;; H I E R A R C H I C A L   H A S H   T A B L E S
;;======================================================================

;; Every element including top element is a vector:
;;   <vector subhash value>







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







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
	 (mthome-cfgfile (conc *toppath* "/.mtviews.config")))
    (if (common:file-exists? mthome-cfgfile)
	(read-config mthome-cfgfile view-cfgdat #t))
    ;; we load the home dir file AFTER the MTRAH file so the user can clobber settings when running the dashboard in read-only areas
    (if (common:file-exists? home-cfgfile)
	(read-config home-cfgfile view-cfgdat #t))
    view-cfgdat))

;;======================================================================
;; Manage pkts, used in servers, tests and likely other contexts so put
;; in common
;;======================================================================

(define common:pkt-spec
  '((server . ((action    . a)
	       (pid       . d)
	       (ipaddr    . i)
	       (port      . p)))
    			  
    (test   . ((cpuuse    . c)
	       (diskuse   . d)
	       (item-path . i)
	       (runname   . r)
	       (state     . s)
	       (target    . t)
	       (status    . u)))))

(define (common:get-pkts-dirs mtconf use-lt)
  (let* ((pktsdirs-str (or (configf:lookup mtconf "setup"  "pktsdirs")
			   (and use-lt
				(conc *toppath* "/lt/.pkts"))))
	 (pktsdirs  (if pktsdirs-str
			(string-split pktsdirs-str " ")
			#f)))
    pktsdirs))

;; use-lt is use linktree "lt" link to find pkts dir
(define (common:with-queue-db mtconf proc #!key (use-lt #f)(toppath-in #f))
  (let* ((pktsdirs (common:get-pkts-dirs mtconf use-lt))
	 (pktsdir  (if pktsdirs (car pktsdirs) #f))
	 (toppath  (or (configf:lookup mtconf "scratchdat" "toppath")
		       toppath-in))
	 (pdbpath  (or (configf:lookup mtconf "setup"  "pdbpath") pktsdir)))
    (cond
     ((not (and  pktsdir toppath pdbpath))
      (debug:print 0 *default-log-port* "ERROR: settings are missing in your megatest.config for area management.")
      (debug:print  0 *default-log-port* "  you need to have pktsdir in the [setup] section."))
     ((not (common:file-exists? pktsdir))
      (debug:print 0 *default-log-port* "ERROR: pkts directory not found " pktsdir))
     ((not (equal? (file-owner pktsdir)(current-effective-user-id)))
      (debug:print 0 *default-log-port* "ERROR: directory " pktsdir " is not owned by " (current-effective-user-name)))
     (else
	(let* ((pdb  (open-queue-db pdbpath "pkts.db"
				    schema: '("CREATE TABLE groups (id INTEGER PRIMARY KEY,groupname TEXT, CONSTRAINT group_constraint UNIQUE (groupname));"))))
	  (proc pktsdirs pktsdir pdb)
	  (dbi:close pdb))))))

(define (common:load-pkts-to-db mtconf)
  (common:with-queue-db
   mtconf
   (lambda (pktsdirs pktsdir pdb)
     (for-each
      (lambda (pktsdir) ;; look at all
	(cond
	 ((not (common:file-exists? pktsdir))
	  (debug:print 0 *default-log-port* "ERROR: packets directory " pktsdir " does not exist."))
	 ((not (directory? pktsdir))
	  (debug:print 0 *default-log-port* "ERROR: packets directory path " pktsdir " is not a directory."))
	 ((not (file-read-access? pktsdir))
	  (debug:print 0 *default-log-port* "ERROR: packets directory path " pktsdir " is not readable."))
	 (else
	  (debug:print-info 0 *default-log-port* "Loading packets found in " pktsdir)
	  (let ((pkts (glob (conc pktsdir "/*.pkt"))))
	    (for-each
	     (lambda (pkt)
	       (let* ((uuid    (cadr (string-match ".*/([0-9a-f]+).pkt" pkt)))
		      (exists  (lookup-by-uuid pdb uuid #f)))
		 (if (not exists)
		     (let* ((pktdat (string-intersperse
				     (with-input-from-file pkt read-lines)
				     "\n"))
			    (apkt   (pkt->alist pktdat))
			    (ptype  (alist-ref 'T apkt)))
		       (add-to-queue pdb pktdat uuid (or ptype 'cmd) #f 0)
		       (debug:print 4 *default-log-port* "Added " uuid " of type " ptype " to queue"))
		     (debug:print 4 *default-log-port* "pkt: " uuid " exists, skipping...")
		     )))
	     pkts)))))
      pktsdirs))))

(define (common:get-pkt-alists pkts)
  (map (lambda (x)
	 (alist-ref 'apkt x)) ;; 'pkta pulls out the alist from the read pkt
       pkts))

;; given list of pkts (alist mode) return list of D cards as Unix epoch, sorted descending
;; also delete duplicates by target i.e. (car pkt)
;;
(define (common:get-pkt-times pkts)
  (delete-duplicates
   (sort 
    (map (lambda (x)
	   `(,(alist-ref 't x) . ,(string->number (alist-ref 'D x))))
	 pkts)
    (lambda (a b)(> (cdr a)(cdr b))))      ;; sort descending
   (lambda (a b)(equal? (car a)(car b))))) ;; remove duplicates by target



;;======================================================================
;; H I E R A R C H I C A L   H A S H   T A B L E S
;;======================================================================

;; Every element including top element is a vector:
;;   <vector subhash value>

Modified configf.scm from [b1611ec83f] to [cfc96f0d59].

13
14
15
16
17
18
19

20
21
22
23
24
25
26
;; Config file handling
;;======================================================================

(use regex regex-case) ;;  directory-utils)
(declare (unit configf))
(declare (uses process))
(declare (uses env))


(include "common_records.scm")

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







>







13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
;; Config file handling
;;======================================================================

(use regex regex-case) ;;  directory-utils)
(declare (unit configf))
(declare (uses process))
(declare (uses env))
(declare (uses keys))

(include "common_records.scm")

;; return list (path fullpath configname)
(define (find-config configname #!key (toppath #f))
  (if toppath
      (let ((cfname (conc toppath "/" configname)))
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
;; pathenvvar will set the named var to the path of the config
(define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f))
  (let* ((curr-dir   (current-directory))
         (configinfo (find-config fname toppath: given-toppath))
	 (toppath    (car configinfo))
	 (configfile (cadr configinfo))
	 (set-fields (lambda (curr-section next-section ht path)
		       (let ((field-names (if ht (keys:config-get-fields ht) '()))
			     (target      (or (getenv "MT_TARGET")(args:get-arg "-reqtarg")(args:get-arg "-target"))))
			 (debug:print-info 9 *default-log-port* "set-fields with field-names=" field-names " target=" target " curr-section=" curr-section " next-section=" next-section " path=" path " ht=" ht)
			 (if (not (null? field-names))(keys:target-set-args field-names target #f))))))
    (if toppath (change-directory toppath)) 
    (if (and toppath pathenvvar)(setenv pathenvvar toppath))
    (let ((configdat  (if configfile 
			  (read-config configfile #f #t environ-patt: environ-patt post-section-procs: (list (cons "^fields$" set-fields)) #f))))







|







399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
;; pathenvvar will set the named var to the path of the config
(define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f))
  (let* ((curr-dir   (current-directory))
         (configinfo (find-config fname toppath: given-toppath))
	 (toppath    (car configinfo))
	 (configfile (cadr configinfo))
	 (set-fields (lambda (curr-section next-section ht path)
		       (let ((field-names (if ht (common:get-fields ht) '()))
			     (target      (or (getenv "MT_TARGET")(args:get-arg "-reqtarg")(args:get-arg "-target"))))
			 (debug:print-info 9 *default-log-port* "set-fields with field-names=" field-names " target=" target " curr-section=" curr-section " next-section=" next-section " path=" path " ht=" ht)
			 (if (not (null? field-names))(keys:target-set-args field-names target #f))))))
    (if toppath (change-directory toppath)) 
    (if (and toppath pathenvvar)(setenv pathenvvar toppath))
    (let ((configdat  (if configfile 
			  (read-config configfile #f #t environ-patt: environ-patt post-section-procs: (list (cons "^fields$" set-fields)) #f))))

Modified dashboard-areas.scm from [ac01c869cc] to [c826774e24].

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

(define (dashboard:areas-summary-updater commondat tabdat tb cell-lookup run-matrix)
  ;; maps data from tabdat view-dat to the matrix
  ;; if input databases have changed, refresh view-dat
  ;; if filters have changed, refresh view-dat from input databases
  ;; if pivots  have changed, refresh view-dat from input databases
  (let* ((runs-hash    (dashboard:areas-get-runs-hash tabdat))
	 (runs-header '("contour_name" "release" "iteration" "testsuite_mode" "id" "runname" "state" "status" "owner" "event_time"))
	 (tree-path    (dboard:tabdat-tree-path tabdat)))
    (dboard:areas-update-tree tabdat runs-hash runs-header tb)
    (print "Tree path: " tree-path)
    (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS
    (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS")
    (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES")

    ;; (if (> max-col (string->number (iup:attribute run-matrix "NUMCOL")))
    (iup:attribute-set! run-matrix "NUMCOL" 10) ;; max-col ))
   
    ;; (let ((effective-max-row (if (< max-row max-visible) max-visible max-row)))
    ;; (if (> effective-max-row (string->number (iup:attribute run-matrix "NUMLIN")))
    (iup:attribute-set! run-matrix "NUMLIN" 10) ;; effective-max-row )))
    (iup:attribute-set! run-matrix "1:1" (conc tree-path))
    (iup:attribute-set! run-matrix "REDRAW" "ALL")))
  
  ;; (dashboard:areas-do-update-rundat tabdat) ;; )
  ;; (dboard:areas-summary-control-panel-updater tabdat)
  ;; (let* ((last-runs-update  (dboard:tabdat-last-runs-update tabdat))
  ;; 	 (runs-dat     (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
  ;; 	 (runs-header  (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
  ;;        (runs         (vector-ref runs-dat 1))
  ;; 	 (run-id       (dboard:tabdat-curr-run-id tabdat))
  ;;        (runs-hash (dashboard:areas-get-runs-hash tabdat))
  ;;        ;; (runs-hash    (let ((ht (make-hash-table)))
  ;; 	 ;;        	 (for-each (lambda (run)
  ;; 	 ;;        		     (hash-table-set! ht (db:get-value-by-header run runs-header "id") run))









|

















|


|







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

(define (dashboard:areas-summary-updater commondat tabdat tb cell-lookup run-matrix)
  ;; maps data from tabdat view-dat to the matrix
  ;; if input databases have changed, refresh view-dat
  ;; if filters have changed, refresh view-dat from input databases
  ;; if pivots  have changed, refresh view-dat from input databases
  (let* ((runs-hash    (dashboard:areas-get-runs-hash commondat tabdat))
	 (runs-header '("contour_name" "release" "iteration" "testsuite_mode" "id" "runname" "state" "status" "owner" "event_time"))
	 (tree-path    (dboard:tabdat-tree-path tabdat)))
    (dboard:areas-update-tree tabdat runs-hash runs-header tb)
    (print "Tree path: " tree-path)
    (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS
    (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS")
    (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES")

    ;; (if (> max-col (string->number (iup:attribute run-matrix "NUMCOL")))
    (iup:attribute-set! run-matrix "NUMCOL" 10) ;; max-col ))
   
    ;; (let ((effective-max-row (if (< max-row max-visible) max-visible max-row)))
    ;; (if (> effective-max-row (string->number (iup:attribute run-matrix "NUMLIN")))
    (iup:attribute-set! run-matrix "NUMLIN" 10) ;; effective-max-row )))
    (iup:attribute-set! run-matrix "1:1" (conc tree-path))
    (iup:attribute-set! run-matrix "REDRAW" "ALL")))
  
  ;; (dashboard:areas-do-update-rundat commondat tabdat) ;; )
  ;; (dboard:areas-summary-control-panel-updater tabdat)
  ;; (let* ((last-runs-update  (dboard:tabdat-last-runs-update tabdat))
  ;; 	 (runs-dat     (db:get-runs-by-patt dbstruct (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
  ;; 	 (runs-header  (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
  ;;        (runs         (vector-ref runs-dat 1))
  ;; 	 (run-id       (dboard:tabdat-curr-run-id tabdat))
  ;;        (runs-hash (dashboard:areas-get-runs-hash tabdat))
  ;;        ;; (runs-hash    (let ((ht (make-hash-table)))
  ;; 	 ;;        	 (for-each (lambda (run)
  ;; 	 ;;        		     (hash-table-set! ht (db:get-value-by-header run runs-header "id") run))
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
	
	;; Bummer - we dont have the global get/set api mapped in chicken
	;; (let* ((modkeys (iup:global "MODKEYSTATE")))
	;;   (BB> "modkeys="modkeys))
	
	(debug:print-info 13 *default-log-port* "click-cb: obj="obj" lin="lin" col="col" status="status)
	;; status is corrupted on Brandon's home machine.  will have to wait until after shutdown to see if it is still broken in PDX SLES

	(let* ((toolpath (car (argv)))
	       (key      (conc lin ":" col))
	       (test-id   (hash-table-ref/default cell-lookup key -1))
	       (run-id   (dboard:tabdat-curr-run-id tabdat))
	       (run-info (mrmt:get-run-info run-id))
	       (target   (mrmt:get-target run-id))
	       (runname  (db:get-value-by-header (db:get-rows run-info)
						 (db:get-header run-info) "runname"))
	       (test-info  (mrmt:get-test-info-by-id run-id test-id))
	       (test-name (db:test-get-testname test-info))
	       (testpatt  (let ((tlast (mrmt:tasks-get-last target runname)))
			    (if tlast
				(let ((tpatt (tasks:task-get-testpatt tlast)))
				  (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017
				      "%"
				      tpatt))
				"%")))
	       (item-path (db:test-get-item-path (mrmt:get-test-info-by-id run-id test-id)))
	       (item-test-path (conc test-name "/" (if (equal? item-path "")
						       "%" 
						       item-path)))
	       (status-chars (char-set->list (string->char-set status)))
	       (testpanel-cmd      (conc toolpath " -test " (dboard:tabdat-curr-run-id tabdat) "," test-id " &")))
	  (debug:print-info 13 *default-log-port* "status-chars=["status-chars"] status=["status"]")
	  (cond







>
|



|
|


|

|






|







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
	
	;; Bummer - we dont have the global get/set api mapped in chicken
	;; (let* ((modkeys (iup:global "MODKEYSTATE")))
	;;   (BB> "modkeys="modkeys))
	
	(debug:print-info 13 *default-log-port* "click-cb: obj="obj" lin="lin" col="col" status="status)
	;; status is corrupted on Brandon's home machine.  will have to wait until after shutdown to see if it is still broken in PDX SLES
	(let* ((dbstruct (dboard:get-dbstruct commondat #f))
	       (toolpath (car (argv)))
	       (key      (conc lin ":" col))
	       (test-id   (hash-table-ref/default cell-lookup key -1))
	       (run-id   (dboard:tabdat-curr-run-id tabdat))
	       (run-info (db:get-run-info dbstruct run-id))
	       (target   (db:get-target dbstruct run-id))
	       (runname  (db:get-value-by-header (db:get-rows run-info)
						 (db:get-header run-info) "runname"))
	       (test-info  (db:get-test-info-by-id dbstruct run-id test-id))
	       (test-name (db:test-get-testname test-info))
	       (testpatt  (let ((tlast (db:tasks-get-last dbstruct target runname)))
			    (if tlast
				(let ((tpatt (tasks:task-get-testpatt tlast)))
				  (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017
				      "%"
				      tpatt))
				"%")))
	       (item-path (db:test-get-item-path (db:get-test-info-by-id dbstruct run-id test-id)))
	       (item-test-path (conc test-name "/" (if (equal? item-path "")
						       "%" 
						       item-path)))
	       (status-chars (char-set->list (string->char-set status)))
	       (testpanel-cmd      (conc toolpath " -test " (dboard:tabdat-curr-run-id tabdat) "," test-id " &")))
	  (debug:print-info 13 *default-log-port* "status-chars=["status-chars"] status=["status"]")
	  (cond
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
					(debug:catch-and-dump
					 (lambda () ;; check that areas-matrix is initialized before calling the updater
					   (if areas-matrix 
					       (dashboard:areas-summary-updater commondat tabdat tb cell-lookup areas-matrix)))
					 "dashboard:areas-summary-updater")
					)
				   (mutex-unlock! update-mutex)))
         (runs-summary-control-panel (dashboard:areas-summary-control-panel tabdat)))
    (dboard:commondat-add-updater commondat areas-summary-updater tab-num: tab-num)
    (dboard:tabdat-runs-tree-set! tabdat tb)
    (iup:vbox
     (iup:split
      #:value 200
      tb
      areas-matrix)
     (dboard:make-controls commondat tabdat extra-widget: runs-summary-control-panel))))

;; this calls dboard:get-tests-for-run-duplicate for each run
;;
;; create a virtual table of all the tests
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
;;
(define (dboard:areas-update-rundat tabdat runnamepatt numruns testnamepatt keypatts)
  (let* ((access-mode      (dboard:tabdat-access-mode tabdat))

         (keys             (dboard:tabdat-keys tabdat))
	 (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2))
         (allruns          (mrmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts))
         ;;(allruns-tree (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f))
         (allruns-tree    (mrmt:get-runs-by-patt keys "%" #f #f #f #f 0)) ;; last-runs-update));;'("id" "runname")
	 (header      (db:get-header allruns))
	 (runs        (db:get-rows   allruns)) ;; RA => Filtered as per runpatt selected
         (runs-tree   (db:get-rows   allruns-tree)) ;; RA => Returns complete list of runs
	 (start-time  (current-seconds))
	 (runs-hash   (let ((ht (make-hash-table)))
			 (for-each (lambda (run)
				     (hash-table-set! ht (db:get-value-by-header run header "id") run))







|














|

>


|

|







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
					(debug:catch-and-dump
					 (lambda () ;; check that areas-matrix is initialized before calling the updater
					   (if areas-matrix 
					       (dashboard:areas-summary-updater commondat tabdat tb cell-lookup areas-matrix)))
					 "dashboard:areas-summary-updater")
					)
				   (mutex-unlock! update-mutex)))
         (runs-summary-control-panel (dashboard:areas-summary-control-panel commondat tabdat)))
    (dboard:commondat-add-updater commondat areas-summary-updater tab-num: tab-num)
    (dboard:tabdat-runs-tree-set! tabdat tb)
    (iup:vbox
     (iup:split
      #:value 200
      tb
      areas-matrix)
     (dboard:make-controls commondat tabdat extra-widget: runs-summary-control-panel))))

;; this calls dboard:get-tests-for-run-duplicate for each run
;;
;; create a virtual table of all the tests
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
;;
(define (dboard:areas-update-rundat commondat tabdat runnamepatt numruns testnamepatt keypatts)
  (let* ((access-mode      (dboard:tabdat-access-mode tabdat))
	 (dbstruct         (dboard:get-dbstruct commondat #f))
         (keys             (dboard:tabdat-keys tabdat))
	 (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2))
         (allruns          (db:get-runs dbstruct runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts))
         ;;(allruns-tree (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f))
         (allruns-tree    (db:get-runs-by-patt dbstruct keys "%" #f #f #f #f 0)) ;; last-runs-update));;'("id" "runname")
	 (header      (db:get-header allruns))
	 (runs        (db:get-rows   allruns)) ;; RA => Filtered as per runpatt selected
         (runs-tree   (db:get-rows   allruns-tree)) ;; RA => Returns complete list of runs
	 (start-time  (current-seconds))
	 (runs-hash   (let ((ht (make-hash-table)))
			 (for-each (lambda (run)
				     (hash-table-set! ht (db:get-value-by-header run header "id") run))
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
	(let loop ((run      (car runs))
		   (tal      (cdr runs))
		   (res     '())
		   (maxtests 0))
	  (let* ((run-id       (db:get-value-by-header run header "id"))
		 (run-struct   (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f))
		 ;; (last-update  (if run-struct (dboard:rundat-last-update run-struct) 0))
		 (key-vals     (mrmt:get-key-vals run-id))
		 (tests-ht     (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
		 ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate
		 ;;  dboard:get-tests-for-run-duplicate - returns a hash table
		 ;;  (dboard:get-tests-dat tabdat run-id last-update))
		 (all-test-ids (hash-table-keys tests-ht))
		 (num-tests    (length all-test-ids)))
	    ;; (print "run-struct: " run-struct)







|







305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
	(let loop ((run      (car runs))
		   (tal      (cdr runs))
		   (res     '())
		   (maxtests 0))
	  (let* ((run-id       (db:get-value-by-header run header "id"))
		 (run-struct   (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f))
		 ;; (last-update  (if run-struct (dboard:rundat-last-update run-struct) 0))
		 (key-vals     (db:get-key-vals dbstruct run-id))
		 (tests-ht     (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
		 ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate
		 ;;  dboard:get-tests-for-run-duplicate - returns a hash table
		 ;;  (dboard:get-tests-dat tabdat run-id last-update))
		 (all-test-ids (hash-table-keys tests-ht))
		 (num-tests    (length all-test-ids)))
	    ;; (print "run-struct: " run-struct)
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
		      (loop run tal new-res newmaxtests) ;; not done getting data for this run
		      (loop (car tal)(cdr tal) new-res newmaxtests)))))))
    (dboard:tabdat-filters-changed-set! tabdat #f)
    (dboard:areas-update-tree tabdat runs-hash header tb)))

;; runs update-rundat using the various filters from the gui
;;
(define (dashboard:areas-do-update-rundat tabdat)
  (dboard:areas-update-rundat

   tabdat
   (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%")
   (dboard:tabdat-numruns tabdat)
   (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
   ;; generate key patterns from the target stored in tabdat
   (let* ((dbkeys (dboard:tabdat-dbkeys tabdat)))
     (let ((fres   (if (dboard:tabdat-target tabdat)
                       (let ((ptparts (append (dboard:tabdat-target tabdat)(make-list (length dbkeys) "%"))))
                         (map (lambda (k v)(list k v)) dbkeys ptparts))
                       (let ((res '()))
                         (for-each (lambda (key)
                                     (if (not (equal? key "runname"))
                                         (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f)))
                                           (if val (set! res (cons (list key val) res))))))
                                   dbkeys)
                         res))))
       fres))))

(define (dashboard:areas-get-runs-hash tabdat)
  (let* ((access-mode       (dboard:tabdat-access-mode tabdat))

         (last-runs-update  0);;(dboard:tabdat-last-runs-update tabdat))
	 (runs-dat     (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
	 (runs-header  (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
         (runs         (vector-ref runs-dat 1))
	 (run-id       (dboard:tabdat-curr-run-id tabdat))
         (runs-hash    (let ((ht (make-hash-table)))
			 (for-each (lambda (run)
				     (hash-table-set! ht (db:get-value-by-header run runs-header "id") run))
				   runs) ht)))







|

>


















|

>

|







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
		      (loop run tal new-res newmaxtests) ;; not done getting data for this run
		      (loop (car tal)(cdr tal) new-res newmaxtests)))))))
    (dboard:tabdat-filters-changed-set! tabdat #f)
    (dboard:areas-update-tree tabdat runs-hash header tb)))

;; runs update-rundat using the various filters from the gui
;;
(define (dashboard:areas-do-update-rundat commondat tabdat)
  (dboard:areas-update-rundat
   commondat 
   tabdat
   (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%")
   (dboard:tabdat-numruns tabdat)
   (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
   ;; generate key patterns from the target stored in tabdat
   (let* ((dbkeys (dboard:tabdat-dbkeys tabdat)))
     (let ((fres   (if (dboard:tabdat-target tabdat)
                       (let ((ptparts (append (dboard:tabdat-target tabdat)(make-list (length dbkeys) "%"))))
                         (map (lambda (k v)(list k v)) dbkeys ptparts))
                       (let ((res '()))
                         (for-each (lambda (key)
                                     (if (not (equal? key "runname"))
                                         (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f)))
                                           (if val (set! res (cons (list key val) res))))))
                                   dbkeys)
                         res))))
       fres))))

(define (dashboard:areas-get-runs-hash commondat tabdat)
  (let* ((access-mode       (dboard:tabdat-access-mode tabdat))
	 (dbstruct          (dboard:get-dbstruct commondat #f))
         (last-runs-update  0);;(dboard:tabdat-last-runs-update tabdat))
	 (runs-dat     (db:get-runs-by-patt dbstruct (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
	 (runs-header  (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
         (runs         (vector-ref runs-dat 1))
	 (run-id       (dboard:tabdat-curr-run-id tabdat))
         (runs-hash    (let ((ht (make-hash-table)))
			 (for-each (lambda (run)
				     (hash-table-set! ht (db:get-value-by-header run runs-header "id") run))
				   runs) ht)))
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
;; open the area dbs, given list of areas that are "cared about"
;;    areas: '( (area_name . path) ... ) ;; NOT necessarily the section [areas] from megatest.config
;;
(define (dboard:areas-open-areas commondat tabdat areas)
  (let ((areas-ht (dboard:commondat-areas commondat)))
    (for-each
     (lambda (area-dat)
       (db:dashboard-open-db areas (car area-dat)(cdr area-dat)))
     areas)))



(define (dboard:areas-update-tree tabdat runs-hash runs-header tb)
  (let* ((tree-path     (dboard:tabdat-tree-path tabdat))
	;; (access-mode   (dboard:tabdat-access-mode tabdat))







|







416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
;; open the area dbs, given list of areas that are "cared about"
;;    areas: '( (area_name . path) ... ) ;; NOT necessarily the section [areas] from megatest.config
;;
(define (dboard:areas-open-areas commondat tabdat areas)
  (let ((areas-ht (dboard:commondat-areas commondat)))
    (for-each
     (lambda (area-dat)
       (db:dashboard-open-dbstruct areas (car area-dat)(cdr area-dat)))
     areas)))



(define (dboard:areas-update-tree tabdat runs-hash runs-header tb)
  (let* ((tree-path     (dboard:tabdat-tree-path tabdat))
	;; (access-mode   (dboard:tabdat-access-mode tabdat))
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
    ;;	       ;;                                             userdata: (conc "run-id: " run-id))))
    ;;	       (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id)
    ;;	       ;; (set! colnum (+ colnum 1))
    ;;	       ))))
    ;; (append new-run-ids run-ids)))) ;; for-each run-id
    ))
    
(define (dashboard:areas-run-id->tests-mindat run-id tabdat runs-hash)
  (let* ((run          (hash-table-ref/default runs-hash run-id #f))
         (key-vals     (mrmt:get-key-vals run-id))
         (testnamepatt (or (dboard:tabdat-test-patts tabdat) "%/%"))
         (tests-ht     (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
         (tests-dat    (dashboard:tests-ht->tests-dat tests-ht)) 
         (tests-mindat (dcommon:minimize-test-data tests-dat)))  ;; reduces data for display
    (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
    (hash-table-set! (dboard:tabdat-last-test-dat tabdat) run-id tests-dat)
    (hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- (current-seconds) 10))
    (when (not run)
        (debug:print-info 13 *default-log-port* "ERROR: NO RUN FOR RUN-ID run-id="run-id)
        (debug:print-info 13 *default-log-port* "runs-hash-> " (hash-table->alist runs-hash))
        )
    tests-mindat))

(define (dashboard:areas-runs-summary-xor-matrix-content tabdat runs-hash #!key (hide-clean #f))

  (let* ((src-run-id (dboard:tabdat-prev-run-id tabdat))
         (dest-run-id (dboard:tabdat-curr-run-id tabdat)))
    (if (and src-run-id dest-run-id)
        (dcommon:xor-tests-mindat 
         (dashboard:run-id->tests-mindat src-run-id tabdat runs-hash)
         (dashboard:run-id->tests-mindat dest-run-id tabdat runs-hash)
         hide-clean: hide-clean)
        #f)))

(define (dashboard:areas-popup-menu  run-id test-id target runname test-name testpatt item-test-path test-info)
  (iup:menu 
   (iup:menu-item
    "Test Control Panel"







|

|













|
>
|



|
|







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
    ;;	       ;;                                             userdata: (conc "run-id: " run-id))))
    ;;	       (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id)
    ;;	       ;; (set! colnum (+ colnum 1))
    ;;	       ))))
    ;; (append new-run-ids run-ids)))) ;; for-each run-id
    ))
    
(define (dashboard:areas-run-id->tests-mindat dbstruct run-id tabdat runs-hash)
  (let* ((run          (hash-table-ref/default runs-hash run-id #f))
         (key-vals     (db:get-key-vals dbstruct run-id))
         (testnamepatt (or (dboard:tabdat-test-patts tabdat) "%/%"))
         (tests-ht     (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
         (tests-dat    (dashboard:tests-ht->tests-dat tests-ht)) 
         (tests-mindat (dcommon:minimize-test-data tests-dat)))  ;; reduces data for display
    (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
    (hash-table-set! (dboard:tabdat-last-test-dat tabdat) run-id tests-dat)
    (hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- (current-seconds) 10))
    (when (not run)
        (debug:print-info 13 *default-log-port* "ERROR: NO RUN FOR RUN-ID run-id="run-id)
        (debug:print-info 13 *default-log-port* "runs-hash-> " (hash-table->alist runs-hash))
        )
    tests-mindat))

(define (dashboard:areas-runs-summary-xor-matrix-content commondat tabdat runs-hash #!key (hide-clean #f))
  (let* ((dbstruct    (dboard:get-dbstruct commondat #f))
	 (src-run-id  (dboard:tabdat-prev-run-id tabdat))
         (dest-run-id (dboard:tabdat-curr-run-id tabdat)))
    (if (and src-run-id dest-run-id)
        (dcommon:xor-tests-mindat 
         (dashboard:run-id->tests-mindat dbstruct src-run-id tabdat runs-hash)
         (dashboard:run-id->tests-mindat dbstruct dest-run-id tabdat runs-hash)
         hide-clean: hide-clean)
        #f)))

(define (dashboard:areas-popup-menu  run-id test-id target runname test-name testpatt item-test-path test-info)
  (iup:menu 
   (iup:menu-item
    "Test Control Panel"
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
    (lambda (obj)
      (dcommon:examine-xterm run-id test-id)))

   (iup:menu-item
    (conc "Kill " item-test-path)
    #:action
    (lambda (obj)
      ;; (mrmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f)
      (common:run-a-command
       (conc "megatest -set-state-status KILLREQ,n/a -target " target
             " -runname " runname
             " -testpatt " item-test-path 
             " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED"))))

   







<







562
563
564
565
566
567
568

569
570
571
572
573
574
575
    (lambda (obj)
      (dcommon:examine-xterm run-id test-id)))

   (iup:menu-item
    (conc "Kill " item-test-path)
    #:action
    (lambda (obj)

      (common:run-a-command
       (conc "megatest -set-state-status KILLREQ,n/a -target " target
             " -runname " runname
             " -testpatt " item-test-path 
             " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED"))))

   
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
               " -runname " runname
	       " -testpatt " item-test-path
	       " -preclean -clean-cache"))))
     (iup:menu-item
      (conc "Kill " item-test-path)
      #:action
      (lambda (obj)
        ;; (mrmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f)
	(common:run-a-command
	 (conc "megatest -set-state-status KILLREQ,n/a -target " target
               " -runname " runname
	       " -testpatt " item-test-path 
	       " -state RUNNING,REMOTEHOSTSTART,LAUNCHED"))))
     (iup:menu-item
      (conc "Delete data : " item-test-path)







<







634
635
636
637
638
639
640

641
642
643
644
645
646
647
               " -runname " runname
	       " -testpatt " item-test-path
	       " -preclean -clean-cache"))))
     (iup:menu-item
      (conc "Kill " item-test-path)
      #:action
      (lambda (obj)

	(common:run-a-command
	 (conc "megatest -set-state-status KILLREQ,n/a -target " target
               " -runname " runname
	       " -testpatt " item-test-path 
	       " -state RUNNING,REMOTEHOSTSTART,LAUNCHED"))))
     (iup:menu-item
      (conc "Delete data : " item-test-path)
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
  (or please-update-buttons
      (and ;; (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) ;; can't use this - it needs to be tab specific
	   (> modtime (- last-db-update-time 3)) ;; add three seconds of margin
	   (> (current-seconds)(+ last-db-update-time 1)))))

;; setup buttons and callbacks to switch between modes in runs summary tab
;;
(define (dashboard:areas-summary-control-panel tabdat)
  (let* ((summary-buttons ;; build buttons
          (map
           (lambda (mode-item)
             (let* ((this-mode (car mode-item))
                    (this-mode-label (cdr mode-item)))
               (iup:button this-mode-label
                           #:action
                           (lambda (obj)
                             (debug:catch-and-dump
                              (lambda ()
                                (dboard:tabdat-runs-summary-mode-set! tabdat this-mode)
                                (dboard:areas-summary-control-panel-updater tabdat))
                              "runs summary control panel updater")))))
           (dboard:tabdat-runs-summary-modes tabdat)))
         (summary-buttons-hbox (apply iup:hbox summary-buttons))
         (xor-runname-labels-hbox
          (iup:hbox
           (let ((temp-label
                  (iup:label "" #:size "125x15" #:fontsize "10" )))
             (dboard:tabdat-runs-summary-source-runname-label-set! tabdat temp-label)
             temp-label
             )
           (let ((temp-label
                  (iup:label "" #:size "125x15" #:fontsize "10")))
             (dboard:tabdat-runs-summary-dest-runname-label-set! tabdat temp-label)
             temp-label))))
    (dboard:tabdat-runs-summary-mode-buttons-set! tabdat summary-buttons)

    ;; maybe wrap in a frame
    (let ((res (iup:vbox summary-buttons-hbox xor-runname-labels-hbox )))
      (dboard:areas-summary-control-panel-updater tabdat)
      res
      )))

(define (dboard:areas-summary-control-panel-updater tabdat)
  (dboard:areas-summary-xor-labels-updater tabdat)
  (dboard:areas-summary-buttons-updater tabdat))

(define (dboard:areas-summary-xor-labels-updater tabdat)
  (let ((source-runname-label (dboard:tabdat-runs-summary-source-runname-label tabdat))
        (dest-runname-label (dboard:tabdat-runs-summary-dest-runname-label tabdat))
        (mode (dboard:tabdat-runs-summary-mode tabdat)))

    (when (and source-runname-label dest-runname-label)
      (case mode
        ((xor-two-runs xor-two-runs-hide-clean)
         (let* ((curr-run-id          (dboard:tabdat-curr-run-id tabdat))
                (prev-run-id          (dboard:tabdat-prev-run-id tabdat))
                (curr-runname (if curr-run-id
                                  (mrmt:get-run-name-from-id curr-run-id)
                                  "None"))
                (prev-runname (if prev-run-id
                                  (mrmt:get-run-name-from-id prev-run-id)
                                  "None")))
           (iup:attribute-set! source-runname-label "TITLE" (conc " SRC: "prev-runname"  "))
           (iup:attribute-set! dest-runname-label "TITLE" (conc "DEST: "curr-runname"  "))))
        (else
         (iup:attribute-set! source-runname-label "TITLE" "")
         (iup:attribute-set! dest-runname-label "TITLE" ""))))))








|











|


















|



|
|


|

|
|
>






|


|







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
  (or please-update-buttons
      (and ;; (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) ;; can't use this - it needs to be tab specific
	   (> modtime (- last-db-update-time 3)) ;; add three seconds of margin
	   (> (current-seconds)(+ last-db-update-time 1)))))

;; setup buttons and callbacks to switch between modes in runs summary tab
;;
(define (dashboard:areas-summary-control-panel commondat tabdat)
  (let* ((summary-buttons ;; build buttons
          (map
           (lambda (mode-item)
             (let* ((this-mode (car mode-item))
                    (this-mode-label (cdr mode-item)))
               (iup:button this-mode-label
                           #:action
                           (lambda (obj)
                             (debug:catch-and-dump
                              (lambda ()
                                (dboard:tabdat-runs-summary-mode-set! tabdat this-mode)
                                (dboard:areas-summary-control-panel-updater commondat tabdat))
                              "runs summary control panel updater")))))
           (dboard:tabdat-runs-summary-modes tabdat)))
         (summary-buttons-hbox (apply iup:hbox summary-buttons))
         (xor-runname-labels-hbox
          (iup:hbox
           (let ((temp-label
                  (iup:label "" #:size "125x15" #:fontsize "10" )))
             (dboard:tabdat-runs-summary-source-runname-label-set! tabdat temp-label)
             temp-label
             )
           (let ((temp-label
                  (iup:label "" #:size "125x15" #:fontsize "10")))
             (dboard:tabdat-runs-summary-dest-runname-label-set! tabdat temp-label)
             temp-label))))
    (dboard:tabdat-runs-summary-mode-buttons-set! tabdat summary-buttons)

    ;; maybe wrap in a frame
    (let ((res (iup:vbox summary-buttons-hbox xor-runname-labels-hbox )))
      (dboard:areas-summary-control-panel-updater commondat tabdat)
      res
      )))

(define (dboard:areas-summary-control-panel-updater commondat tabdat)
  (dboard:areas-summary-xor-labels-updater commondat tabdat)
  (dboard:areas-summary-buttons-updater tabdat))

(define (dboard:areas-summary-xor-labels-updater commondat tabdat)
  (let ((source-runname-label (dboard:tabdat-runs-summary-source-runname-label tabdat))
        (dest-runname-label   (dboard:tabdat-runs-summary-dest-runname-label tabdat))
        (mode                 (dboard:tabdat-runs-summary-mode tabdat))
	(dbstruct             (dboard:get-dbstruct commondat #f)))
    (when (and source-runname-label dest-runname-label)
      (case mode
        ((xor-two-runs xor-two-runs-hide-clean)
         (let* ((curr-run-id          (dboard:tabdat-curr-run-id tabdat))
                (prev-run-id          (dboard:tabdat-prev-run-id tabdat))
                (curr-runname (if curr-run-id
                                  (db:get-run-name-from-id dbstruct curr-run-id)
                                  "None"))
                (prev-runname (if prev-run-id
                                  (db:get-run-name-from-id dbstruct prev-run-id)
                                  "None")))
           (iup:attribute-set! source-runname-label "TITLE" (conc " SRC: "prev-runname"  "))
           (iup:attribute-set! dest-runname-label "TITLE" (conc "DEST: "curr-runname"  "))))
        (else
         (iup:attribute-set! source-runname-label "TITLE" "")
         (iup:attribute-set! dest-runname-label "TITLE" ""))))))

Modified dashboard-tests.scm from [17c63127ed] to [974a2ffdcc].

38
39
40
41
42
43
44




45
46
47

48





49
50
51
52
53
54
55
56
57
;;======================================================================
;; 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 "viewscreen "))) ;; "xterm -geometry 180x20 -e \"")))


(define (dtests:get-post-command #!key (default-override #f))





  (let ((cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command")))
    (or cfg-ovrd default-override " &"))) ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))


(define (test-info-panel testdat store-label widgets)
  (iup:frame 
   #:title "Test Info" ; #:expand "YES"
   (iup:hbox ; #:expand "YES"
    (apply iup:vbox ; #:expand "YES"







>
>
>
>
|
|

>

>
>
>
>
>
|
|







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
;;======================================================================
;; C O M M O N
;;======================================================================

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

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

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


(define (test-info-panel testdat store-label widgets)
  (iup:frame 
   #:title "Test Info" ; #:expand "YES"
   (iup:hbox ; #:expand "YES"
    (apply iup:vbox ; #:expand "YES"

Modified dashboard.scm from [f1ca685f34] to [e2c358fe88].

46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
(include "task_records.scm")
(include "megatest-fossil-hash.scm")
(include "vg_records.scm")

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

Usage: dashboard [options]
  -h                    : this help
  -test run-id,test-id  : control test identified by testid
  -skip-version-check   : skip the version check
  -use-db-cache         : access database via cache 

Misc
  -rows R         : set number of rows
  -cols C         : set number of columns
"))

;;   -server host:port     : connect to host:port instead of db access







|





<







46
47
48
49
50
51
52
53
54
55
56
57
58

59
60
61
62
63
64
65
(include "task_records.scm")
(include "megatest-fossil-hash.scm")
(include "vg_records.scm")

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

Usage: dashboard [options]
  -h                    : this help
  -test run-id,test-id  : control test identified by testid
  -skip-version-check   : skip the version check


Misc
  -rows R         : set number of rows
  -cols C         : set number of columns
"))

;;   -server host:port     : connect to host:port instead of db access
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
			) 
		 (list  "-h"
			"-use-server"
			"-guimonitor"
			"-main"
			"-v"
			"-q"
			"-use-db-cache"
			"-skip-version-check"
			"-repl"
                        "-rh5.11" ;; fix to allow running on rh5.11
			)
		 args:arg-hash
		 0))








|







80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
			) 
		 (list  "-h"
			"-use-server"
			"-guimonitor"
			"-main"
			"-v"
			"-q"
			;; "-use-db-cache"
			"-skip-version-check"
			"-repl"
                        "-rh5.11" ;; fix to allow running on rh5.11
			)
		 args:arg-hash
		 0))

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
  please-update  
  (tabdats            (make-hash-table))
  (update-mutex       (make-mutex))
  (updaters           (make-hash-table))
  (updating           #f)
  uidat                                   ;; needs to move to tabdat at some time
  (hide-not-hide-tabs #f)
  (current-area-path  #f)                 ;; the area of the path where the dashboard was started, if it is a megatest area
  (areas              (make-hash-table))  ;; area-name ==> dbstruct
  ;; (area-dbs           #f)                 ;; use db:dashboard-open-db to add areas to the areas hash  
  )











;; RA => returns the tabdat stored at hashkey passed in commondat-tabdats table (e.g. 0 gives summary)
;;
(define (dboard:common-get-tabdat commondat #!key (tab-num #f))
  (let* ((tnum (or tab-num
		   (dboard:commondat-curr-tab-num commondat)
		   0)) ;; tab-num value is curr-tab-num value in passed commondat
	 (ht   (dboard:commondat-tabdats commondat))
	 (res  (hash-table-ref/default ht tnum #f)))
    (or res
	(let ((new-tabdat  (dboard:tabdat-make-data)))
	  (hash-table-set! ht tnum new-tabdat)
	  new-tabdat))))

;; RA => sets the tabdat passed to the hashkey at commondat:tabdats hash table
;;
(define (dboard:common-set-tabdat! commondat tabnum tabdat)
  (hash-table-set!







|



>
>
>
>
>
>
>
>
>
>










|







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
  please-update  
  (tabdats            (make-hash-table))
  (update-mutex       (make-mutex))
  (updaters           (make-hash-table))
  (updating           #f)
  uidat                                   ;; needs to move to tabdat at some time
  (hide-not-hide-tabs #f)
  (default-area-path  #f)                 ;; the area of the path where the dashboard was started, if it is a megatest area
  (areas              (make-hash-table))  ;; area-name ==> dbstruct
  ;; (area-dbs           #f)                 ;; use db:dashboard-open-db to add areas to the areas hash  
  )

;; general "db getter"
;;
(define (dboard:get-dbstruct commondat area-path-in) ;; area-path=#f gets local connection
  (let ((areas (dboard:commondat-areas commondat))
	(apath (or area-path-in (current-directory))))
    (or (db:dashboard-open-dbstruct areas "local" apath)
	(begin
	  (debug:print 0 *default-debug-port* "Failed to open db in directory " apath ", are you staring dashboard in a Megatest area? Exiting...")
	  (exit 1)))))

;; RA => returns the tabdat stored at hashkey passed in commondat-tabdats table (e.g. 0 gives summary)
;;
(define (dboard:common-get-tabdat commondat #!key (tab-num #f))
  (let* ((tnum (or tab-num
		   (dboard:commondat-curr-tab-num commondat)
		   0)) ;; tab-num value is curr-tab-num value in passed commondat
	 (ht   (dboard:commondat-tabdats commondat))
	 (res  (hash-table-ref/default ht tnum #f)))
    (or res
	(let ((new-tabdat  (dboard:tabdat-make-data commondat)))
	  (hash-table-set! ht tnum new-tabdat)
	  new-tabdat))))

;; RA => sets the tabdat passed to the hashkey at commondat:tabdats hash table
;;
(define (dboard:common-set-tabdat! commondat tabnum tabdat)
  (hash-table-set!
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
(define (dboard:tabdat-test-patts-use vec)    
  (let ((val (dboard:tabdat-test-patts vec)))(if val val ""))) ;;RADT => What is the if for?

;; additional setters for dboard:data
(define (dboard:tabdat-test-patts-set!-use    vec val)
  (dboard:tabdat-test-patts-set! vec (if (equal? val "") #f val)))

(define (dboard:tabdat-make-data)
  (let ((dat (make-dboard:tabdat)))
    (dboard:setup-tabdat dat)
    (dboard:setup-num-rows dat)
    dat))

(define (dboard:setup-tabdat tabdat)
  ;; (dboard:tabdat-dbdir-set! tabdat (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
  ;; (dboard:tabdat-dbfpath-set! tabdat (db:dbfile-path))
  ;; (dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db"))


  ;; HACK ALERT: this is a hack, please fix.
  (if #f
      (dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat))))
      (print "FIXME on line 350"))
  
  (dboard:tabdat-keys-set! tabdat (mrmt:get-keys))
  (dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname")))
  (dboard:tabdat-tot-runs-set! tabdat (mrmt:get-num-runs "%"))
  )

;; RADT => Matrix defstruct addition
(defstruct dboard:graph-dat
    ((id           #f) : string)
    ((color        #f) : vector)
    ((flag         #t) : boolean)
    ((cell         #f) : number)







|

|



|




>
|
|
|
|
|
|
|
|
|







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
(define (dboard:tabdat-test-patts-use vec)    
  (let ((val (dboard:tabdat-test-patts vec)))(if val val ""))) ;;RADT => What is the if for?

;; additional setters for dboard:data
(define (dboard:tabdat-test-patts-set!-use    vec val)
  (dboard:tabdat-test-patts-set! vec (if (equal? val "") #f val)))

(define (dboard:tabdat-make-data commondat)
  (let ((dat (make-dboard:tabdat)))
    (dboard:setup-tabdat commondat dat)
    (dboard:setup-num-rows dat)
    dat))

(define (dboard:setup-tabdat commondat tabdat)
  ;; (dboard:tabdat-dbdir-set! tabdat (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
  ;; (dboard:tabdat-dbfpath-set! tabdat (db:dbfile-path))
  ;; (dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db"))

  (let ((dbstruct (dboard:get-dbstruct commondat #f)))
    ;; HACK ALERT: this is a hack, please fix.
    (if #f
	(dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat))))
	(print "FIXME on line 350"))
    
    (dboard:tabdat-keys-set! tabdat (db:get-keys dbstruct))
    (dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname")))
    (dboard:tabdat-tot-runs-set! tabdat (db:get-num-runs dbstruct "%"))
    ))

;; RADT => Matrix defstruct addition
(defstruct dboard:graph-dat
    ((id           #f) : string)
    ((color        #f) : vector)
    ((flag         #t) : boolean)
    ((cell         #f) : number)
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391

(define (dboard:runsdat-make-init)
  (make-dboard:runsdat
   runs-index: (make-hash-table)
   tests-index: (make-hash-table)
   matrix-dat: (make-sparse-array)))

;; used to keep the rundata from mrmt:get-tests-for-run
;; in sync. 
;;
(defstruct dboard:rundat
  run
  tests-drawn    ;; list of id's already drawn on screen
  tests-notdrawn ;; list of id's NOT already drawn
  rowsused       ;; hash of lists covering what areas used - replace with quadtree







|







387
388
389
390
391
392
393
394
395
396
397
398
399
400
401

(define (dboard:runsdat-make-init)
  (make-dboard:runsdat
   runs-index: (make-hash-table)
   tests-index: (make-hash-table)
   matrix-dat: (make-sparse-array)))

;; used to keep the rundata from db:get-tests-for-run
;; in sync. 
;;
(defstruct dboard:rundat
  run
  tests-drawn    ;; list of id's already drawn on screen
  tests-notdrawn ;; list of id's NOT already drawn
  rowsused       ;; hash of lists covering what areas used - replace with quadtree
537
538
539
540
541
542
543
544

545
546
547
548
549
550
551
552

;; This is roughly the same as dboard:get-tests-dat, should merge them if possible
;;
;; gets all the tests for run-id that match testnamepatt and key-vals, merges them
;;
;;    NOTE: Yes, this is used
;;
(define (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)

  (let* ((start-time   (current-seconds))
	 (access-mode  (dboard:tabdat-access-mode tabdat))
         (num-to-get   (string->number (or (configf:lookup *configdat* "setup" "num-tests-to-get")
                                           "200")))
	 (states       (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)))
	 (statuses     (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)))
         (do-not-use-db-file-timestamps #t) ;; (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps")) ;; this still hosts runs-summary-tab
         (do-not-use-query-timestamps   #t) ;; (configf:lookup *configdat* "setup" "do-not-use-query-timestamps")) ;; this no longer troubles runs-summary-tab







|
>
|







547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563

;; This is roughly the same as dboard:get-tests-dat, should merge them if possible
;;
;; gets all the tests for run-id that match testnamepatt and key-vals, merges them
;;
;;    NOTE: Yes, this is used
;;
(define (dboard:get-tests-for-run-duplicate commondat tabdat run-id run testnamepatt key-vals)
  (let* ((dbstruct     (dboard:get-dbstruct commondat #f))
	 (start-time   (current-seconds))
	 (access-mode  (dboard:tabdat-access-mode tabdat))
         (num-to-get   (string->number (or (configf:lookup *configdat* "setup" "num-tests-to-get")
                                           "200")))
	 (states       (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)))
	 (statuses     (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)))
         (do-not-use-db-file-timestamps #t) ;; (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps")) ;; this still hosts runs-summary-tab
         (do-not-use-query-timestamps   #t) ;; (configf:lookup *configdat* "setup" "do-not-use-query-timestamps")) ;; this no longer troubles runs-summary-tab
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
                        ;;(dboard:tabdat-filters-changed tabdat))
                        0
                        (dboard:rundat-last-update run-dat)))
	 (last-db-time (if do-not-use-db-file-timestamps
			   0
			   (dboard:rundat-last-db-time run-dat)))
	 (db-path      (or (dboard:rundat-db-path run-dat)
			   (let* ((db-dir (common:get-db-tmp-area))
				  (db-pth (conc db-dir "/megatest.db")))
			     (dboard:rundat-db-path-set! run-dat db-pth)
			     db-pth)))
	 (db-mod-time  (common:lazy-sqlite-db-modification-time db-path))
	 (db-modified  (>= db-mod-time last-db-time))
	 (multi-get    (> (dboard:rundat-run-data-offset run-dat) 0))  ;; multi-get in progress
	 (tmptests     (if (or do-not-use-db-file-timestamps
			       (dboard:tabdat-filters-changed tabdat)
			       db-modified)
			   (mrmt:get-tests-for-run run-id testnamepatt states statuses     ;; run-id testpatt states statuses
					      (dboard:rundat-run-data-offset run-dat) ;; query offset
					      num-to-get
					      (dboard:tabdat-hide-not-hide tabdat) ;; no-in
					      sort-by                              ;; sort-by
					      sort-order                           ;; sort-order
					      #f ;; 'shortlist                     ;; qrytype
					      last-update                          ;; last-update







|









|







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
                        ;;(dboard:tabdat-filters-changed tabdat))
                        0
                        (dboard:rundat-last-update run-dat)))
	 (last-db-time (if do-not-use-db-file-timestamps
			   0
			   (dboard:rundat-last-db-time run-dat)))
	 (db-path      (or (dboard:rundat-db-path run-dat)
			   (let* ((db-dir (common:get-db-tmp-area dbstruct))
				  (db-pth (conc db-dir "/megatest.db")))
			     (dboard:rundat-db-path-set! run-dat db-pth)
			     db-pth)))
	 (db-mod-time  (common:lazy-sqlite-db-modification-time db-path))
	 (db-modified  (>= db-mod-time last-db-time))
	 (multi-get    (> (dboard:rundat-run-data-offset run-dat) 0))  ;; multi-get in progress
	 (tmptests     (if (or do-not-use-db-file-timestamps
			       (dboard:tabdat-filters-changed tabdat)
			       db-modified)
			   (db:get-tests-for-run dbstruct run-id testnamepatt states statuses     ;; run-id testpatt states statuses
					      (dboard:rundat-run-data-offset run-dat) ;; query offset
					      num-to-get
					      (dboard:tabdat-hide-not-hide tabdat) ;; no-in
					      sort-by                              ;; sort-by
					      sort-order                           ;; sort-order
					      #f ;; 'shortlist                     ;; qrytype
					      last-update                          ;; last-update
649
650
651
652
653
654
655
656

657
658
659
660
661
662
663
664
665
666
667
668
669
;; 	newdat)))

;; this calls dboard:get-tests-for-run-duplicate for each run
;;
;; create a virtual table of all the tests
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
;;
(define (update-rundat tabdat runnamepatt numruns testnamepatt keypatts)

  (let* ((access-mode      (dboard:tabdat-access-mode tabdat))
         (keys             (mrmt:get-keys))
	 (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2))
         (allruns          (mrmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts))
         ;;(allruns-tree (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f))
         (allruns-tree    (mrmt:get-runs-by-patt keys "%" #f #f #f #f last-runs-update)) ;;'("id" "runname")
	 (header      (db:get-header allruns))
	 (runs        (db:get-rows   allruns)) ;; RA => Filtered as per runpatt selected
         (runs-tree   (db:get-rows   allruns-tree)) ;; RA => Returns complete list of runs
	 (start-time  (current-seconds))
	 (runs-hash   (let ((ht (make-hash-table)))
			 (for-each (lambda (run)
				     (hash-table-set! ht (db:get-value-by-header run header "id") run))







|
>
|
|

|
<
|







660
661
662
663
664
665
666
667
668
669
670
671
672

673
674
675
676
677
678
679
680
;; 	newdat)))

;; this calls dboard:get-tests-for-run-duplicate for each run
;;
;; create a virtual table of all the tests
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
;;
(define (update-rundat commondat tabdat runnamepatt numruns testnamepatt keypatts)
  (let* ((dbstruct         (dboard:get-dbstruct commondat #f)) ;; get access to local area
	 (access-mode      (dboard:tabdat-access-mode tabdat))
         (keys             (db:get-keys dbstruct))
	 (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2))
         (allruns          (db:get-runs dbstruct runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts))

         (allruns-tree    (db:get-runs-by-patt dbstruct keys "%" #f #f #f #f last-runs-update)) ;;'("id" "runname")
	 (header      (db:get-header allruns))
	 (runs        (db:get-rows   allruns)) ;; RA => Filtered as per runpatt selected
         (runs-tree   (db:get-rows   allruns-tree)) ;; RA => Returns complete list of runs
	 (start-time  (current-seconds))
	 (runs-hash   (let ((ht (make-hash-table)))
			 (for-each (lambda (run)
				     (hash-table-set! ht (db:get-value-by-header run header "id") run))
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
	(let loop ((run      (car runs))
		   (tal      (cdr runs))
		   (res     '())
		   (maxtests 0))
	  (let* ((run-id       (db:get-value-by-header run header "id"))
		 (run-struct   (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f))
		 (last-update  (if run-struct (dboard:rundat-last-update run-struct) 0))
		 (key-vals     (mrmt:get-key-vals run-id))
		 (tests-ht     (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
		 ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate
		 ;;  dboard:get-tests-for-run-duplicate - returns a hash table
		 ;;  (dboard:get-tests-dat tabdat run-id last-update))
		 (all-test-ids (hash-table-keys tests-ht))
		 (num-tests    (length all-test-ids)))
	    ;; (print "run-struct: " run-struct)
	    ;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat)







|
|







697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
	(let loop ((run      (car runs))
		   (tal      (cdr runs))
		   (res     '())
		   (maxtests 0))
	  (let* ((run-id       (db:get-value-by-header run header "id"))
		 (run-struct   (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f))
		 (last-update  (if run-struct (dboard:rundat-last-update run-struct) 0))
		 (key-vals     (db:get-key-vals dbstruct run-id))
		 (tests-ht     (dboard:get-tests-for-run-duplicate commondat tabdat run-id run testnamepatt key-vals))
		 ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate
		 ;;  dboard:get-tests-for-run-duplicate - returns a hash table
		 ;;  (dboard:get-tests-dat tabdat run-id last-update))
		 (all-test-ids (hash-table-keys tests-ht))
		 (num-tests    (length all-test-ids)))
	    ;; (print "run-struct: " run-struct)
	    ;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat)
728
729
730
731
732
733
734
735

736
737
738
739
740
741
742
743
744
745
746
747
748
    (dboard:update-tree tabdat runs-hash header tb)))

;; this calls dboard:get-tests-for-run-duplicate for each run
;;
;; create a virtual table of all the tests
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
;;
(define (dboard:update-rundat tabdat runnamepatt numruns testnamepatt keypatts)

  (let* ((access-mode      (dboard:tabdat-access-mode tabdat))
         (keys             (dboard:tabdat-keys tabdat)) ;; (db:dispatch-query access-mode mrmt:get-keys db:get-keys)))
	 (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2))
         (allruns          (mrmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts))
         ;;(allruns-tree (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f))
         (allruns-tree    (mrmt:get-runs-by-patt keys "%" #f #f #f #f 0)) ;; last-runs-update));;'("id" "runname")
	 (header      (db:get-header allruns))
	 (runs        (db:get-rows   allruns)) ;; RA => Filtered as per runpatt selected
         (runs-tree   (db:get-rows   allruns-tree)) ;; RA => Returns complete list of runs
	 (start-time  (current-seconds))
	 (runs-hash   (let ((ht (make-hash-table)))
			 (for-each (lambda (run)
				     (hash-table-set! ht (db:get-value-by-header run header "id") run))







|
>
|
|

|
|
|







739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
    (dboard:update-tree tabdat runs-hash header tb)))

;; this calls dboard:get-tests-for-run-duplicate for each run
;;
;; create a virtual table of all the tests
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
;;
(define (dboard:update-rundat commondat tabdat runnamepatt numruns testnamepatt keypatts)
  (let* ((dbstruct         (dboard:get-dbstruct commondat #f))
	 (access-mode      (dboard:tabdat-access-mode tabdat))
         (keys             (dboard:tabdat-keys tabdat)) 
	 (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2))
         (allruns          (db:get-runs dbstruct runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts))
         ;;(allruns-tree (db:get-runs-by-patt dbstruct (dboard:tabdat-keys tabdat) "%" #f #f #f #f))
         (allruns-tree    (db:get-runs-by-patt dbstruct keys "%" #f #f #f #f 0)) ;; last-runs-update));;'("id" "runname")
	 (header      (db:get-header allruns))
	 (runs        (db:get-rows   allruns)) ;; RA => Filtered as per runpatt selected
         (runs-tree   (db:get-rows   allruns-tree)) ;; RA => Returns complete list of runs
	 (start-time  (current-seconds))
	 (runs-hash   (let ((ht (make-hash-table)))
			 (for-each (lambda (run)
				     (hash-table-set! ht (db:get-value-by-header run header "id") run))
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
	(let loop ((run      (car runs))
		   (tal      (cdr runs))
		   (res     '())
		   (maxtests 0))
	  (let* ((run-id       (db:get-value-by-header run header "id"))
		 (run-struct   (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f))
		 ;; (last-update  (if run-struct (dboard:rundat-last-update run-struct) 0))
		 (key-vals     (mrmt:get-key-vals run-id))
		 (tests-ht     (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
		 ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate
		 ;;  dboard:get-tests-for-run-duplicate - returns a hash table
		 ;;  (dboard:get-tests-dat tabdat run-id last-update))
		 (all-test-ids (hash-table-keys tests-ht))
		 (num-tests    (length all-test-ids)))
	    ;; (print "run-struct: " run-struct)
	    ;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat)







|
|







775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
	(let loop ((run      (car runs))
		   (tal      (cdr runs))
		   (res     '())
		   (maxtests 0))
	  (let* ((run-id       (db:get-value-by-header run header "id"))
		 (run-struct   (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f))
		 ;; (last-update  (if run-struct (dboard:rundat-last-update run-struct) 0))
		 (key-vals     (db:get-key-vals dbstruct run-id))
		 (tests-ht     (dboard:get-tests-for-run-duplicate commondat tabdat run-id run testnamepatt key-vals))
		 ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate
		 ;;  dboard:get-tests-for-run-duplicate - returns a hash table
		 ;;  (dboard:get-tests-dat tabdat run-id last-update))
		 (all-test-ids (hash-table-keys tests-ht))
		 (num-tests    (length all-test-ids)))
	    ;; (print "run-struct: " run-struct)
	    ;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat)
1152
1153
1154
1155
1156
1157
1158
1159

1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
      (if val
	  val
	  (if (not (null? values))
	      (let ((newval (car values)))
		(iup:attribute-set! lb "VALUE" newval)
		newval))))))

(define (dashboard:update-target-selector tabdat #!key (action-proc #f))

  (let* ((runconf-targs (common:get-runconfig-targets))
	 (key-lbs       (dboard:tabdat-key-listboxes tabdat))
	 (db-target-dat (mrmt:get-targets))
	 (header        (vector-ref db-target-dat 0))
	 (db-targets    (vector-ref db-target-dat 1))
	 (munge-target  (lambda (x)            ;; create a target vector from a string. Pad with na if needed.
			  (list->vector
			   (take (append (string-split x "/")
					 (make-list (length header) "na"))
				 (length header)))))







|
>
|

|







1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
      (if val
	  val
	  (if (not (null? values))
	      (let ((newval (car values)))
		(iup:attribute-set! lb "VALUE" newval)
		newval))))))

(define (dashboard:update-target-selector commondat tabdat #!key (action-proc #f))
  (let* ((dbstruct      (dboard:get-dbstruct commondat #f))
	 (runconf-targs (common:get-runconfig-targets))
	 (key-lbs       (dboard:tabdat-key-listboxes tabdat))
	 (db-target-dat (db:get-targets dbstruct))
	 (header        (vector-ref db-target-dat 0))
	 (db-targets    (vector-ref db-target-dat 1))
	 (munge-target  (lambda (x)            ;; create a target vector from a string. Pad with na if needed.
			  (list->vector
			   (take (append (string-split x "/")
					 (make-list (length header) "na"))
				 (length header)))))
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
;;======================================================================
;; R U N   C O N T R O L S
;;======================================================================
;;
;; A gui for launching tests
;;

(define (dboard:target-updater tabdat) ;;  key-listboxes)
  (let ((targ (map (lambda (x)
		     (iup:attribute x "VALUE"))
		   (car (dashboard:update-target-selector tabdat))))
	(curr-runname (dboard:tabdat-run-name tabdat)))
    (dboard:tabdat-target-set! tabdat targ)
    ;; (if (dboard:tabdat-updater-for-runs tabdat)
    ;; 	 ((dboard:tabdat-updater-for-runs tabdat)))
    (if (or (not (equal? curr-runname (dboard:tabdat-run-name tabdat)))
	    (equal? (dboard:tabdat-run-name tabdat) ""))
	(dboard:tabdat-run-name-set! tabdat curr-runname))
    (dashboard:update-run-command tabdat)))

;; used by run-controls
;;
(define (dashboard:update-tree-selector tabdat #!key (action-proc #f))

  (let* ((tb            (dboard:tabdat-runs-tree tabdat))
	 (runconf-targs (common:get-runconfig-targets))
	 (db-target-dat (mrmt:get-targets))
         (runs-tree-ht  (dboard:tabdat-runs-tree-ht tabdat))
	 (header        (vector-ref db-target-dat 0))
	 (db-targets    (vector-ref db-target-dat 1))
	 (munge-target  (lambda (x)            ;; create a target vector from a string. Pad with na if needed.
			  (take (append (string-split x "/")
					(make-list (length header) "na"))
				(length header))))







|


|











|
>
|

|







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
;;======================================================================
;; R U N   C O N T R O L S
;;======================================================================
;;
;; A gui for launching tests
;;

(define (dboard:target-updater commondat tabdat) ;;  key-listboxes)
  (let ((targ (map (lambda (x)
		     (iup:attribute x "VALUE"))
		   (car (dashboard:update-target-selector commondat tabdat))))
	(curr-runname (dboard:tabdat-run-name tabdat)))
    (dboard:tabdat-target-set! tabdat targ)
    ;; (if (dboard:tabdat-updater-for-runs tabdat)
    ;; 	 ((dboard:tabdat-updater-for-runs tabdat)))
    (if (or (not (equal? curr-runname (dboard:tabdat-run-name tabdat)))
	    (equal? (dboard:tabdat-run-name tabdat) ""))
	(dboard:tabdat-run-name-set! tabdat curr-runname))
    (dashboard:update-run-command tabdat)))

;; used by run-controls
;;
(define (dashboard:update-tree-selector commondat tabdat #!key (action-proc #f))
  (let* ((dbstruct      (dboard:get-dbstruct commondat #f))
	 (tb            (dboard:tabdat-runs-tree tabdat))
	 (runconf-targs (common:get-runconfig-targets))
	 (db-target-dat (db:get-targets dbstruct))
         (runs-tree-ht  (dboard:tabdat-runs-tree-ht tabdat))
	 (header        (vector-ref db-target-dat 0))
	 (db-targets    (vector-ref db-target-dat 1))
	 (munge-target  (lambda (x)            ;; create a target vector from a string. Pad with na if needed.
			  (take (append (string-split x "/")
					(make-list (length header) "na"))
				(length header))))
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
	 (test-names    (hash-table-keys all-tests-registry))
	 (sorted-testnames #f)
	 (action        "-run")
	 (cmdln         "")
	 (runlogs       (make-hash-table))
	 ;;; (key-listboxes #f)
	 (update-keyvals (lambda () ;; gets called in dashboard:update-target-selector as "action-proc"
			   (dboard:target-updater (dboard:tabdat-key-listboxes tabdat))))
	 (tests-draw-state (make-hash-table)) ;; use for keeping state of the test canvas
	 (test-patterns-textbox  #f))
    (hash-table-set! tests-draw-state 'first-time #t)
    ;; (hash-table-set! tests-draw-state 'scalef 1)
    (tests:get-full-data test-names test-records '() all-tests-registry)
    (set! sorted-testnames (tests:sort-by-priority-and-waiton test-records))
    







|







1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
	 (test-names    (hash-table-keys all-tests-registry))
	 (sorted-testnames #f)
	 (action        "-run")
	 (cmdln         "")
	 (runlogs       (make-hash-table))
	 ;;; (key-listboxes #f)
	 (update-keyvals (lambda () ;; gets called in dashboard:update-target-selector as "action-proc"
			   (dboard:target-updater commondat (dboard:tabdat-key-listboxes tabdat))))
	 (tests-draw-state (make-hash-table)) ;; use for keeping state of the test canvas
	 (test-patterns-textbox  #f))
    (hash-table-set! tests-draw-state 'first-time #t)
    ;; (hash-table-set! tests-draw-state 'scalef 1)
    (tests:get-full-data test-names test-records '() all-tests-registry)
    (set! sorted-testnames (tests:sort-by-priority-and-waiton test-records))
    
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
	     ;;  key-listboxes))
	     (dcommon:command-tests-tasks-canvas tabdat test-records sorted-testnames tests-draw-state))))
	   (tb (dboard:tabdat-runs-tree tabdat)))
      (dboard:commondat-add-updater 
       commondat 
       (lambda ()
         (if (dashboard:database-changed? commondat tabdat context-key: 'run-control)
             (dashboard:update-tree-selector tabdat)))
       tab-num: tab-num)
      result)))

 ;;(iup:frame
 ;; #:title "Logs" ;; To be replaced with tabs
 ;; (let ((logs-tb (iup:textbox #:expand "YES"
 ;;				   #:multiline "YES")))







|







1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
	     ;;  key-listboxes))
	     (dcommon:command-tests-tasks-canvas tabdat test-records sorted-testnames tests-draw-state))))
	   (tb (dboard:tabdat-runs-tree tabdat)))
      (dboard:commondat-add-updater 
       commondat 
       (lambda ()
         (if (dashboard:database-changed? commondat tabdat context-key: 'run-control)
             (dashboard:update-tree-selector commondat tabdat)))
       tab-num: tab-num)
      result)))

 ;;(iup:frame
 ;; #:title "Logs" ;; To be replaced with tabs
 ;; (let ((logs-tb (iup:textbox #:expand "YES"
 ;;				   #:multiline "YES")))
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
									 (dashboard:run-times-tab-layout-updater commondat tabdat tab-num)
									 (dboard:tabdat-running-layout-set! tabdat #f))
								       "run-times-tab-layout-updater")))
						     ))))))
				   "dashboard:run-times-tab-updater")))
	 (key-listboxes #f) ;; 
	 (update-keyvals (lambda ()
			   (dboard:target-updater tabdat))))
    (dboard:tabdat-drawing-set! tabdat drawing)
    (dboard:commondat-add-updater commondat run-times-tab-updater tab-num: tab-num)
    (iup:split
     #:orientation "VERTICAL" ;; "HORIZONTAL"
     #:value 150
     (iup:vbox








|







1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
									 (dashboard:run-times-tab-layout-updater commondat tabdat tab-num)
									 (dboard:tabdat-running-layout-set! tabdat #f))
								       "run-times-tab-layout-updater")))
						     ))))))
				   "dashboard:run-times-tab-updater")))
	 (key-listboxes #f) ;; 
	 (update-keyvals (lambda ()
			   (dboard:target-updater commondat tabdat))))
    (dboard:tabdat-drawing-set! tabdat drawing)
    (dboard:commondat-add-updater commondat run-times-tab-updater tab-num: tab-num)
    (iup:split
     #:orientation "VERTICAL" ;; "HORIZONTAL"
     #:value 150
     (iup:vbox

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
;; display and manage a single run at a time

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

;; (define (dboard:get-tests-dat tabdat run-id last-update)
;;   (let* ((access-mode     (dboard:tabdat-access-mode tabdat))
;;          (tdat (if run-id (db:dispatch-query access-mode mrmt:get-tests-for-run db:get-tests-for-run
;;                                              run-id 
;; 					     (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
;; 					     (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat))  ;; '()
;; 					     (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)) ;; '()
;; 					     #f #f                                                       ;; offset limit
;; 					     (dboard:tabdat-hide-not-hide tabdat)                        ;; not-in
;; 					     #f #f                                                       ;; sort-by sort-order
;; 					     #f ;; get all? "id,testname,item_path,state,status,event_time,run_duration"                        ;; qryval
;;                                              (if (dboard:tabdat-filters-changed tabdat)
;; 					         0
;; 					         last-update)
;; 					     *dashboard-mode*)
;; 		  '()))) ;; get 'em all
;;     ;; (debug:print 0 *default-log-port* "dboard:get-tests-dat: got " (length tdat) " test records for run " run-id)
;;     (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)
;; 		       (string<= aval bval)))))))


(define (dashboard:safe-cadr-assoc name lst)
  (let ((res (assoc name lst)))
    (if (and res (> (length res) 1))
	(cadr res)
	#f)))

(define (dboard:update-tree tabdat runs-hash runs-header tb)
  (let* ((access-mode   (dboard:tabdat-access-mode tabdat))
         (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 runs-header "event_time"))
				 (time-b   (db:get-value-by-header record-b runs-header "event_time")))
			    (< time-a time-b)))))
         (changed      #f)
	 (last-runs-update  (dboard:tabdat-last-runs-update tabdat)))
	 ;; (runs-dat     (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)))
    (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
    (for-each (lambda (run-id)
		(let* ((run-record (hash-table-ref/default runs-hash run-id #f))
		       (key-vals   (map (lambda (key)(db:get-value-by-header run-record runs-header key))
					(dboard:tabdat-keys tabdat)))
		       (run-name   (db:get-value-by-header run-record runs-header "runname"))
		       (col-name   (conc (string-intersperse key-vals "\n") "\n" run-name))







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


















|







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
;; display and manage a single run at a time

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




























(define (dashboard:safe-cadr-assoc name lst)
  (let ((res (assoc name lst)))
    (if (and res (> (length res) 1))
	(cadr res)
	#f)))

(define (dboard:update-tree tabdat runs-hash runs-header tb)
  (let* ((access-mode   (dboard:tabdat-access-mode tabdat))
         (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 runs-header "event_time"))
				 (time-b   (db:get-value-by-header record-b runs-header "event_time")))
			    (< time-a time-b)))))
         (changed      #f)
	 (last-runs-update  (dboard:tabdat-last-runs-update tabdat)))
	 ;; (runs-dat     (db:get-runs-by-patt dbstruct (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)))
    (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
    (for-each (lambda (run-id)
		(let* ((run-record (hash-table-ref/default runs-hash run-id #f))
		       (key-vals   (map (lambda (key)(db:get-value-by-header run-record runs-header key))
					(dboard:tabdat-keys tabdat)))
		       (run-name   (db:get-value-by-header run-record runs-header "runname"))
		       (col-name   (conc (string-intersperse key-vals "\n") "\n" run-name))
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
        (cond
         ((< 0 (string-compare3 a-test-name b-test-name)) #t)
         ((> 0 (string-compare3 a-test-name b-test-name)) #f)
         ((< 0 (string-compare3 a-item-path b-item-path)) #t)
         (else #f)))))))


(define (dashboard:run-id->tests-mindat run-id tabdat runs-hash)
  (let* ((run          (hash-table-ref/default runs-hash run-id #f))

         (key-vals     (mrmt:get-key-vals run-id))
         (testnamepatt (or (dboard:tabdat-test-patts tabdat) "%/%"))
         (tests-ht     (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
         (tests-dat    (dashboard:tests-ht->tests-dat tests-ht)) 
         (tests-mindat (dcommon:minimize-test-data tests-dat)))  ;; reduces data for display
    (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
    (hash-table-set! (dboard:tabdat-last-test-dat tabdat) run-id tests-dat)
    (hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- (current-seconds) 10))
    (when (not run)
        (debug:print-info 13 *default-log-port* "ERROR: NO RUN FOR RUN-ID run-id="run-id)
        (debug:print-info 13 *default-log-port* "runs-hash-> " (hash-table->alist runs-hash))
        )
    tests-mindat))

(define (dashboard:runs-summary-xor-matrix-content tabdat runs-hash #!key (hide-clean #f))

  (let* ((src-run-id (dboard:tabdat-prev-run-id tabdat))
         (dest-run-id (dboard:tabdat-curr-run-id tabdat)))
    (if (and src-run-id dest-run-id)
        (dcommon:xor-tests-mindat 
         (dashboard:run-id->tests-mindat src-run-id tabdat runs-hash)
         (dashboard:run-id->tests-mindat dest-run-id tabdat runs-hash)
         hide-clean: hide-clean)
        #f)))


(define (dashboard:get-runs-hash tabdat)
  (let* ((access-mode       (dboard:tabdat-access-mode tabdat))

         (last-runs-update  0);;(dboard:tabdat-last-runs-update tabdat))
	 (runs-dat     (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
	 (runs-header  (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
         (runs         (vector-ref runs-dat 1))
	 (run-id       (dboard:tabdat-curr-run-id tabdat))
         (runs-hash    (let ((ht (make-hash-table)))
			 (for-each (lambda (run)
				     (hash-table-set! ht (db:get-value-by-header run runs-header "id") run))
				   runs) ht)))
    runs-hash))
         

(define (dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix)
  ;; (if (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-rundat)
  (dashboard:do-update-rundat tabdat) ;; )
  (dboard:runs-summary-control-panel-updater tabdat)

  (let* ((last-runs-update  (dboard:tabdat-last-runs-update tabdat))
	 (runs-dat     (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
	 (runs-header  (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
         (runs         (vector-ref runs-dat 1))
	 (run-id       (dboard:tabdat-curr-run-id tabdat))
         (runs-hash (dashboard:get-runs-hash tabdat))
         ;; (runs-hash    (let ((ht (make-hash-table)))
	 ;;        	 (for-each (lambda (run)
	 ;;        		     (hash-table-set! ht (db:get-value-by-header run runs-header "id") run))
	 ;;        		   runs)
	 ;;        	 ht))
         )
    (if (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-tree)
        (dboard:update-tree tabdat runs-hash runs-header tb))
    (if run-id
        (let* ((matrix-content
                (case (dboard:tabdat-runs-summary-mode tabdat) 
                  ((one-run) (dashboard:run-id->tests-mindat run-id tabdat runs-hash))
                  ((xor-two-runs) (dashboard:runs-summary-xor-matrix-content tabdat runs-hash))
                  ((xor-two-runs-hide-clean) (dashboard:runs-summary-xor-matrix-content tabdat runs-hash hide-clean: #t))
                  (else (dashboard:run-id->tests-mindat run-id tabdat runs-hash)))))
          (when matrix-content
            (let* ((indices      (common:sparse-list-generate-index matrix-content)) ;;  proc: set-cell))
                   (row-indices  (cadr indices))
                   (col-indices  (car indices))
                   (max-row      (if (null? row-indices) 1 (common:max (map cadr row-indices))))
                   (max-col      (if (null? col-indices) 1 (common:max (map cadr col-indices))))
                   (max-visible  (max (- (dboard:tabdat-num-tests tabdat) 15) 3)) ;; (dboard:tabdat-num-tests tabdat) is proportional to the size of the window
                   (numrows      1)
                   (numcols      1)
                   (changed      #f)
                   )
              
              (dboard:tabdat-filters-changed-set! tabdat #f)
              (let loop ((pass-num 0)
                         (changed  #f))
                ;; Update the runs tree
                ;; (dboard:update-tree tabdat runs-hash runs-header tb)
                







|

>
|

|











|
>
|



|
|




|

>

|












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





|
|
|
|









|
<







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
        (cond
         ((< 0 (string-compare3 a-test-name b-test-name)) #t)
         ((> 0 (string-compare3 a-test-name b-test-name)) #f)
         ((< 0 (string-compare3 a-item-path b-item-path)) #t)
         (else #f)))))))


(define (dashboard:run-id->tests-mindat commondat run-id tabdat runs-hash)
  (let* ((run          (hash-table-ref/default runs-hash run-id #f))
	 (dbstruct     (dboard:get-dbstruct commondat #f))
         (key-vals     (db:get-key-vals dbstruct run-id))
         (testnamepatt (or (dboard:tabdat-test-patts tabdat) "%/%"))
         (tests-ht     (dboard:get-tests-for-run-duplicate commondat tabdat run-id run testnamepatt key-vals))
         (tests-dat    (dashboard:tests-ht->tests-dat tests-ht)) 
         (tests-mindat (dcommon:minimize-test-data tests-dat)))  ;; reduces data for display
    (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
    (hash-table-set! (dboard:tabdat-last-test-dat tabdat) run-id tests-dat)
    (hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- (current-seconds) 10))
    (when (not run)
        (debug:print-info 13 *default-log-port* "ERROR: NO RUN FOR RUN-ID run-id="run-id)
        (debug:print-info 13 *default-log-port* "runs-hash-> " (hash-table->alist runs-hash))
        )
    tests-mindat))

(define (dashboard:runs-summary-xor-matrix-content commondat tabdat runs-hash #!key (hide-clean #f))
  (let* (;; (dbstruct   (dboard:get-dbstruct commondat #f))
	 (src-run-id (dboard:tabdat-prev-run-id tabdat))
         (dest-run-id (dboard:tabdat-curr-run-id tabdat)))
    (if (and src-run-id dest-run-id)
        (dcommon:xor-tests-mindat 
         (dashboard:run-id->tests-mindat commondat src-run-id tabdat runs-hash)
         (dashboard:run-id->tests-mindat commondat dest-run-id tabdat runs-hash)
         hide-clean: hide-clean)
        #f)))


(define (dashboard:get-runs-hash commondat tabdat)
  (let* ((access-mode       (dboard:tabdat-access-mode tabdat))
	 (dbstruct          (dboard:get-dbstruct commondat #f))
         (last-runs-update  0);;(dboard:tabdat-last-runs-update tabdat))
	 (runs-dat     (db:get-runs-by-patt dbstruct (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
	 (runs-header  (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
         (runs         (vector-ref runs-dat 1))
	 (run-id       (dboard:tabdat-curr-run-id tabdat))
         (runs-hash    (let ((ht (make-hash-table)))
			 (for-each (lambda (run)
				     (hash-table-set! ht (db:get-value-by-header run runs-header "id") run))
				   runs) ht)))
    runs-hash))
         

(define (dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix)
  ;; (if (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-rundat)
  (dashboard:do-update-rundat commondat tabdat) ;; )
  (dboard:runs-summary-control-panel-updater commondat tabdat)
  (let* ((dbstruct          (dboard:get-dbstruct commondat #f))
	 (last-runs-update  (dboard:tabdat-last-runs-update tabdat))
	 (runs-dat          (db:get-runs-by-patt dbstruct (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
	 (runs-header       (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
         (runs              (vector-ref runs-dat 1))
	 (run-id            (dboard:tabdat-curr-run-id tabdat))
         (runs-hash         (dashboard:get-runs-hash commondat tabdat)))






    (if (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-tree)
        (dboard:update-tree tabdat runs-hash runs-header tb))
    (if run-id
        (let* ((matrix-content
                (case (dboard:tabdat-runs-summary-mode tabdat) 
                  ((one-run)                 (dashboard:run-id->tests-mindat commondat run-id tabdat runs-hash))
                  ((xor-two-runs)            (dashboard:runs-summary-xor-matrix-content commondat tabdat runs-hash))
                  ((xor-two-runs-hide-clean) (dashboard:runs-summary-xor-matrix-content commondat tabdat runs-hash hide-clean: #t))
                  (else (dashboard:run-id->tests-mindat commondat run-id tabdat runs-hash)))))
          (when matrix-content
            (let* ((indices      (common:sparse-list-generate-index matrix-content)) ;;  proc: set-cell))
                   (row-indices  (cadr indices))
                   (col-indices  (car indices))
                   (max-row      (if (null? row-indices) 1 (common:max (map cadr row-indices))))
                   (max-col      (if (null? col-indices) 1 (common:max (map cadr col-indices))))
                   (max-visible  (max (- (dboard:tabdat-num-tests tabdat) 15) 3)) ;; (dboard:tabdat-num-tests tabdat) is proportional to the size of the window
                   (numrows      1)
                   (numcols      1)
                   (changed      #f))

              
              (dboard:tabdat-filters-changed-set! tabdat #f)
              (let loop ((pass-num 0)
                         (changed  #f))
                ;; Update the runs tree
                ;; (dboard:update-tree tabdat runs-hash runs-header tb)
                
1881
1882
1883
1884
1885
1886
1887



1888
1889
1890
1891
1892
1893
1894
1895

;;======================================================================
;; S U M M A R Y 
;;======================================================================
;;
;; General info about the run(s) and megatest area
(define (dashboard:summary commondat tabdat #!key (tab-num #f))



  (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)))
	 (changed          #f))
    (iup:vbox
     (iup:split
      #:value 300
      (iup:frame 
       #:title "General Info"
       (iup:vbox







>
>
>
|







1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883

;;======================================================================
;; S U M M A R Y 
;;======================================================================
;;
;; General info about the run(s) and megatest area
(define (dashboard:summary commondat tabdat #!key (tab-num #f))
  (let* ((dbstruct         (dboard:get-dbstruct commondat #f))
	 (configdat        (dbr:dbstruct-configdat dbstruct))
	 (rawconfig        configdat)
	 ;; (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)))
	 (changed          #f))
    (iup:vbox
     (iup:split
      #:value 300
      (iup:frame 
       #:title "General Info"
       (iup:vbox
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
               (nonsel-color "170 170 170")
               (current-mode (dboard:tabdat-runs-summary-mode tabdat)))
          (if (eq? this-mode current-mode)
              (iup:attribute-set! this-button "BGCOLOR" sel-color)
              (iup:attribute-set! this-button "BGCOLOR" nonsel-color))
          (loop (cdr buttons-left) (cdr modes-left))))))

(define (dboard:runs-summary-xor-labels-updater tabdat)
  (let ((source-runname-label (dboard:tabdat-runs-summary-source-runname-label tabdat))
        (dest-runname-label (dboard:tabdat-runs-summary-dest-runname-label tabdat))
        (mode (dboard:tabdat-runs-summary-mode tabdat)))

    (when (and source-runname-label dest-runname-label)
      (case mode
        ((xor-two-runs xor-two-runs-hide-clean)
         (let* ((curr-run-id          (dboard:tabdat-curr-run-id tabdat))
                (prev-run-id          (dboard:tabdat-prev-run-id tabdat))
                (curr-runname (if curr-run-id
                                  (mrmt:get-run-name-from-id curr-run-id)
                                  "None"))
                (prev-runname (if prev-run-id
                                  (mrmt:get-run-name-from-id prev-run-id)
                                  "None")))
           (iup:attribute-set! source-runname-label "TITLE" (conc " SRC: "prev-runname"  "))
           (iup:attribute-set! dest-runname-label "TITLE" (conc "DEST: "curr-runname"  "))))
        (else
         (iup:attribute-set! source-runname-label "TITLE" "")
         (iup:attribute-set! dest-runname-label "TITLE" ""))))))

(define (dboard:runs-summary-control-panel-updater tabdat)
  (dboard:runs-summary-xor-labels-updater tabdat)
  (dboard:runs-summary-buttons-updater tabdat))


;; setup buttons and callbacks to switch between modes in runs summary tab
;;
(define (dashboard:runs-summary-control-panel tabdat)
  (let* ((summary-buttons ;; build buttons
          (map
           (lambda (mode-item)
             (let* ((this-mode (car mode-item))
                    (this-mode-label (cdr mode-item)))
               (iup:button this-mode-label
                           #:action
                           (lambda (obj)
                             (debug:catch-and-dump
                              (lambda ()
                                (dboard:tabdat-runs-summary-mode-set! tabdat this-mode)
                                (dboard:runs-summary-control-panel-updater tabdat))
                              "runs summary control panel updater")))))
           (dboard:tabdat-runs-summary-modes tabdat)))
         (summary-buttons-hbox (apply iup:hbox summary-buttons))
         (xor-runname-labels-hbox
          (iup:hbox
           (let ((temp-label
                  (iup:label "" #:size "125x15" #:fontsize "10" )))
             (dboard:tabdat-runs-summary-source-runname-label-set! tabdat temp-label)
             temp-label
             )
           (let ((temp-label
                  (iup:label "" #:size "125x15" #:fontsize "10")))
             (dboard:tabdat-runs-summary-dest-runname-label-set! tabdat temp-label)
             temp-label))))
    (dboard:tabdat-runs-summary-mode-buttons-set! tabdat summary-buttons)

    ;; maybe wrap in a frame
    (let ((res (iup:vbox summary-buttons-hbox xor-runname-labels-hbox )))
      (dboard:runs-summary-control-panel-updater tabdat)
      res
      )))

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

;; This is the Run Summary tab
;; 
(define (dashboard:runs-summary commondat tabdat #!key (tab-num #f))

  (let* ((update-mutex (dboard:commondat-update-mutex commondat))
	 (tb      (iup:treebox
		   #:value 0
		   #:name "Runs"
		   #:expand "YES"
		   #:addexpanded "YES"
		   #:selection-cb
		   (lambda (obj id state)







|

|
|
>






|


|







|
|





|











|


















|












>
|







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
               (nonsel-color "170 170 170")
               (current-mode (dboard:tabdat-runs-summary-mode tabdat)))
          (if (eq? this-mode current-mode)
              (iup:attribute-set! this-button "BGCOLOR" sel-color)
              (iup:attribute-set! this-button "BGCOLOR" nonsel-color))
          (loop (cdr buttons-left) (cdr modes-left))))))

(define (dboard:runs-summary-xor-labels-updater commondat tabdat)
  (let ((source-runname-label (dboard:tabdat-runs-summary-source-runname-label tabdat))
        (dest-runname-label   (dboard:tabdat-runs-summary-dest-runname-label tabdat))
        (mode                 (dboard:tabdat-runs-summary-mode tabdat))
	(dbstruct             (dboard:get-dbstruct commondat #f)))
    (when (and source-runname-label dest-runname-label)
      (case mode
        ((xor-two-runs xor-two-runs-hide-clean)
         (let* ((curr-run-id          (dboard:tabdat-curr-run-id tabdat))
                (prev-run-id          (dboard:tabdat-prev-run-id tabdat))
                (curr-runname (if curr-run-id
                                  (db:get-run-name-from-id dbstruct curr-run-id)
                                  "None"))
                (prev-runname (if prev-run-id
                                  (db:get-run-name-from-id dbstruct prev-run-id)
                                  "None")))
           (iup:attribute-set! source-runname-label "TITLE" (conc " SRC: "prev-runname"  "))
           (iup:attribute-set! dest-runname-label "TITLE" (conc "DEST: "curr-runname"  "))))
        (else
         (iup:attribute-set! source-runname-label "TITLE" "")
         (iup:attribute-set! dest-runname-label "TITLE" ""))))))

(define (dboard:runs-summary-control-panel-updater commondat tabdat)
  (dboard:runs-summary-xor-labels-updater commondat tabdat)
  (dboard:runs-summary-buttons-updater tabdat))


;; setup buttons and callbacks to switch between modes in runs summary tab
;;
(define (dashboard:runs-summary-control-panel commondat tabdat)
  (let* ((summary-buttons ;; build buttons
          (map
           (lambda (mode-item)
             (let* ((this-mode (car mode-item))
                    (this-mode-label (cdr mode-item)))
               (iup:button this-mode-label
                           #:action
                           (lambda (obj)
                             (debug:catch-and-dump
                              (lambda ()
                                (dboard:tabdat-runs-summary-mode-set! tabdat this-mode)
                                (dboard:runs-summary-control-panel-updater commondattabdat))
                              "runs summary control panel updater")))))
           (dboard:tabdat-runs-summary-modes tabdat)))
         (summary-buttons-hbox (apply iup:hbox summary-buttons))
         (xor-runname-labels-hbox
          (iup:hbox
           (let ((temp-label
                  (iup:label "" #:size "125x15" #:fontsize "10" )))
             (dboard:tabdat-runs-summary-source-runname-label-set! tabdat temp-label)
             temp-label
             )
           (let ((temp-label
                  (iup:label "" #:size "125x15" #:fontsize "10")))
             (dboard:tabdat-runs-summary-dest-runname-label-set! tabdat temp-label)
             temp-label))))
    (dboard:tabdat-runs-summary-mode-buttons-set! tabdat summary-buttons)

    ;; maybe wrap in a frame
    (let ((res (iup:vbox summary-buttons-hbox xor-runname-labels-hbox )))
      (dboard:runs-summary-control-panel-updater commondat tabdat)
      res
      )))

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

;; This is the Run Summary tab
;; 
(define (dashboard:runs-summary commondat tabdat #!key (tab-num #f))
  (let* ((dbstruct     (dboard:get-dbstruct commondat #f))
	 (update-mutex (dboard:commondat-update-mutex commondat))
	 (tb      (iup:treebox
		   #:value 0
		   #:name "Runs"
		   #:expand "YES"
		   #:addexpanded "YES"
		   #:selection-cb
		   (lambda (obj id state)
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

                           (debug:print-info 13 *default-log-port* "click-cb: obj="obj" lin="lin" col="col" status="status)
                           ;; status is corrupted on Brandon's home machine.  will have to wait until after shutdown to see if it is still broken in PDX SLES
                           (let* ((toolpath (car (argv)))
                                  (key      (conc lin ":" col))
                                  (test-id   (hash-table-ref/default cell-lookup key -1))
                                  (run-id   (dboard:tabdat-curr-run-id tabdat))
                                  (run-info (mrmt:get-run-info run-id))
                                  (target   (mrmt:get-target run-id))
                                  (runname  (db:get-value-by-header (db:get-rows run-info)
                                                                    (db:get-header run-info) "runname"))
				  (test-info  (mrmt:get-test-info-by-id run-id test-id))
                                  (test-name (db:test-get-testname test-info))
                                  (testpatt  (let ((tlast (mrmt:tasks-get-last target runname)))
                                                (if tlast
                                                    (let ((tpatt (tasks:task-get-testpatt tlast)))
                                                      (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017
                                                          "%"
                                                          tpatt))
                                                    "%")))
                                  (item-path (db:test-get-item-path (mrmt:get-test-info-by-id run-id test-id)))
                                  (item-test-path (conc test-name "/" (if (equal? item-path "")
									"%" 
									item-path)))
                                  (status-chars (char-set->list (string->char-set status)))
                                  (testpanel-cmd      (conc toolpath " -test " (dboard:tabdat-curr-run-id tabdat) "," test-id " &")))
                             (debug:print-info 13 *default-log-port* "status-chars=["status-chars"] status=["status"]")
                             (cond







|
|


|

|

|




|







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

                           (debug:print-info 13 *default-log-port* "click-cb: obj="obj" lin="lin" col="col" status="status)
                           ;; status is corrupted on Brandon's home machine.  will have to wait until after shutdown to see if it is still broken in PDX SLES
                           (let* ((toolpath (car (argv)))
                                  (key      (conc lin ":" col))
                                  (test-id   (hash-table-ref/default cell-lookup key -1))
                                  (run-id   (dboard:tabdat-curr-run-id tabdat))
                                  (run-info (db:get-run-info dbstruct run-id))
                                  (target   (db:get-target dbstruct run-id))
                                  (runname  (db:get-value-by-header (db:get-rows run-info)
                                                                    (db:get-header run-info) "runname"))
				  (test-info  (db:get-test-info-by-id dbstruct run-id test-id))
                                  (test-name (db:test-get-testname test-info))
                                  (testpatt  (let ((tlast (db:tasks-get-last dbstruct target runname)))
                                                (if tlast
                                                    (let ((tpatt (tasks:task-get-testpatt tlast))) ;; tasks:task-get-testpatt is an accessor defined in task_records.scm
                                                      (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017
                                                          "%"
                                                          tpatt))
                                                    "%")))
                                  (item-path (db:test-get-item-path (db:get-test-info-by-id dbstruct run-id test-id)))
                                  (item-test-path (conc test-name "/" (if (equal? item-path "")
									"%" 
									item-path)))
                                  (status-chars (char-set->list (string->char-set status)))
                                  (testpanel-cmd      (conc toolpath " -test " (dboard:tabdat-curr-run-id tabdat) "," test-id " &")))
                             (debug:print-info 13 *default-log-port* "status-chars=["status-chars"] status=["status"]")
                             (cond
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
                 (debug:catch-and-dump
                  (lambda () ;; check that run-matrix is initialized before calling the updater
		    (if run-matrix 
			(dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix)))
                  "dashboard:runs-summary-updater")
                 )
	    (mutex-unlock! update-mutex)))
         (runs-summary-control-panel (dashboard:runs-summary-control-panel tabdat))
         )
    (dboard:commondat-add-updater commondat runs-summary-updater tab-num: tab-num)
    (dboard:tabdat-runs-tree-set! tabdat tb)
    (iup:vbox
     (iup:split
      #:value 200
      tb







|







2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
                 (debug:catch-and-dump
                  (lambda () ;; check that run-matrix is initialized before calling the updater
		    (if run-matrix 
			(dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix)))
                  "dashboard:runs-summary-updater")
                 )
	    (mutex-unlock! update-mutex)))
         (runs-summary-control-panel (dashboard:runs-summary-control-panel commondat tabdat))
         )
    (dboard:commondat-add-updater commondat runs-summary-updater tab-num: tab-num)
    (dboard:tabdat-runs-tree-set! tabdat tb)
    (iup:vbox
     (iup:split
      #:value 200
      tb
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
    (lambda (obj)
      (dcommon:examine-xterm run-id test-id)))

   (iup:menu-item
    (conc "Kill " item-test-path)
    #:action
    (lambda (obj)
      ;; (mrmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f)
      (common:run-a-command
       (conc "megatest -set-state-status KILLREQ,n/a -target " target
             " -runname " runname
             " -testpatt " item-test-path 
             " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED"))))

   







<







2445
2446
2447
2448
2449
2450
2451

2452
2453
2454
2455
2456
2457
2458
    (lambda (obj)
      (dcommon:examine-xterm run-id test-id)))

   (iup:menu-item
    (conc "Kill " item-test-path)
    #:action
    (lambda (obj)

      (common:run-a-command
       (conc "megatest -set-state-status KILLREQ,n/a -target " target
             " -runname " runname
             " -testpatt " item-test-path 
             " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED"))))

   
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
               " -runname " runname
	       " -testpatt " item-test-path
	       " -preclean -clean-cache"))))
     (iup:menu-item
      (conc "Kill " item-test-path)
      #:action
      (lambda (obj)
        ;; (mrmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f)
	(common:run-a-command
	 (conc "megatest -set-state-status KILLREQ,n/a -target " target
               " -runname " runname
	       " -testpatt " item-test-path 
	       " -state RUNNING,REMOTEHOSTSTART,LAUNCHED"))))
     (iup:menu-item
      (conc "Delete data : " item-test-path)







<







2517
2518
2519
2520
2521
2522
2523

2524
2525
2526
2527
2528
2529
2530
               " -runname " runname
	       " -testpatt " item-test-path
	       " -preclean -clean-cache"))))
     (iup:menu-item
      (conc "Kill " item-test-path)
      #:action
      (lambda (obj)

	(common:run-a-command
	 (conc "megatest -set-state-status KILLREQ,n/a -target " target
               " -runname " runname
	       " -testpatt " item-test-path 
	       " -state RUNNING,REMOTEHOSTSTART,LAUNCHED"))))
     (iup:menu-item
      (conc "Delete data : " item-test-path)
2577
2578
2579
2580
2581
2582
2583

2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
			      (conc "xterm -e " editor)
			      editor)
			  " " tconfig " &")))
	  (system cmd))))
     ))))

(define (make-dashboard-buttons commondat) ;;  runs-sum-dat new-view-dat)

  (let* ((stats-dat       (dboard:tabdat-make-data))
	 (runs-dat        (dboard:tabdat-make-data))
	 (onerun-dat      (dboard:tabdat-make-data)) ;; name for run-summary structure 
	 (runcontrols-dat (dboard:tabdat-make-data))
	 (runtimes-dat    (dboard:tabdat-make-data))
	 (areas-dat       (dboard:tabdat-make-data))
	 (nruns           (dboard:tabdat-numruns runs-dat))
	 (ntests          (dboard:tabdat-num-tests runs-dat))
	 (keynames        (dboard:tabdat-dbkeys runs-dat))
	 (nkeys           (length keynames))
	 (runsvec         (make-vector nruns))
	 (header          (make-vector nruns))
	 (lftcol          (make-vector ntests))







>
|
|
|
|
|
|







2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
			      (conc "xterm -e " editor)
			      editor)
			  " " tconfig " &")))
	  (system cmd))))
     ))))

(define (make-dashboard-buttons commondat) ;;  runs-sum-dat new-view-dat)
  (let* ((dbstruct        (dboard:get-dbstruct commondat #f))
	 (stats-dat       (dboard:tabdat-make-data commondat))
	 (runs-dat        (dboard:tabdat-make-data commondat))
	 (onerun-dat      (dboard:tabdat-make-data commondat)) ;; name for run-summary structure 
	 (runcontrols-dat (dboard:tabdat-make-data commondat))
	 (runtimes-dat    (dboard:tabdat-make-data commondat))
	 (areas-dat       (dboard:tabdat-make-data commondat))
	 (nruns           (dboard:tabdat-numruns runs-dat))
	 (ntests          (dboard:tabdat-num-tests runs-dat))
	 (keynames        (dboard:tabdat-dbkeys runs-dat))
	 (nkeys           (length keynames))
	 (runsvec         (make-vector nruns))
	 (header          (make-vector nruns))
	 (lftcol          (make-vector ntests))
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
    (let loop ((testnum  0)
	       (res      '()))
      (cond
       ((>= testnum ntests)
	;; now lftlst will be an hbox with the test keys and the test name labels
	(set! lftlst (append lftlst (list (iup:hbox  #:expand "HORIZONTAL"
						     (iup:valuator #:valuechanged_cb (lambda (obj)
										       (let ((val (string->number (iup:attribute obj "VALUE")))
											     (oldmax  (string->number (iup:attribute obj "MAX")))
											     (newmax  (* 10 (length (dboard:tabdat-all-test-names runs-dat)))))
											 (dboard:commondat-please-update-set! commondat #t)
											 (dboard:tabdat-start-test-offset-set! runs-dat (inexact->exact (round (/ val 10))))
											 (debug:print 6 *default-log-port* "(dboard:tabdat-start-test-offset runs-dat) " (dboard:tabdat-start-test-offset runs-dat) " val: " val " newmax: " newmax " oldmax: " oldmax)
											 (if (< val 10)
											     (iup:attribute-set! obj "MAX" newmax))







|







2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
    (let loop ((testnum  0)
	       (res      '()))
      (cond
       ((>= testnum ntests)
	;; now lftlst will be an hbox with the test keys and the test name labels
	(set! lftlst (append lftlst (list (iup:hbox  #:expand "HORIZONTAL"
						     (iup:valuator #:valuechanged_cb (lambda (obj)
	668									       (let ((val (string->number (iup:attribute obj "VALUE")))
											     (oldmax  (string->number (iup:attribute obj "MAX")))
											     (newmax  (* 10 (length (dboard:tabdat-all-test-names runs-dat)))))
											 (dboard:commondat-please-update-set! commondat #t)
											 (dboard:tabdat-start-test-offset-set! runs-dat (inexact->exact (round (/ val 10))))
											 (debug:print 6 *default-log-port* "(dboard:tabdat-start-test-offset runs-dat) " (dboard:tabdat-start-test-offset runs-dat) " val: " val " newmax: " newmax " oldmax: " oldmax)
											 (if (< val 10)
											     (iup:attribute-set! obj "MAX" newmax))
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
			      ;; (print "pressed= " pressed " x= " x " y= " y " rem=" rem " btn=" btn " string? " (string? btn))
			      (if  (substring-index "3" btn)
				   (if (eq? pressed 1)
				       (let* ((toolpath (car (argv)))
					      (buttndat (hash-table-ref (dboard:tabdat-buttondat runs-dat) button-key))
					      (test-id  (db:test-get-id (vector-ref buttndat 3)))
					      (run-id   (db:test-get-run_id (vector-ref buttndat 3)))
					      (run-info (mrmt:get-run-info run-id))
					      (target   (mrmt:get-target run-id))
					      (runname  (db:get-value-by-header (db:get-rows run-info)
										(db:get-header run-info) "runname"))
					      (test-info (mrmt:get-test-info-by-id run-id test-id))
					      (test-name (db:test-get-testname test-info))
					      (testpatt  (let ((tlast (mrmt:tasks-get-last target runname)))
							   (if tlast
							       (let ((tpatt (tasks:task-get-testpatt tlast)))
								 (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017
								     "%"
								     tpatt))
							       "%")))
                                              (item-path (db:test-get-item-path (mrmt:get-test-info-by-id run-id test-id)))
                                              (item-test-path (conc test-name "/" (if (equal? item-path "")
									"%" 
									item-path))))
					 (iup:show (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu
						   #:x 'mouse
						   #:y 'mouse
						   #:modal? "NO")







|
|


|

|






|







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
			      ;; (print "pressed= " pressed " x= " x " y= " y " rem=" rem " btn=" btn " string? " (string? btn))
			      (if  (substring-index "3" btn)
				   (if (eq? pressed 1)
				       (let* ((toolpath (car (argv)))
					      (buttndat (hash-table-ref (dboard:tabdat-buttondat runs-dat) button-key))
					      (test-id  (db:test-get-id (vector-ref buttndat 3)))
					      (run-id   (db:test-get-run_id (vector-ref buttndat 3)))
					      (run-info (db:get-run-info dbstruct run-id))
					      (target   (db:get-target dbstruct run-id))
					      (runname  (db:get-value-by-header (db:get-rows run-info)
										(db:get-header run-info) "runname"))
					      (test-info (db:get-test-info-by-id dbstruct run-id test-id))
					      (test-name (db:test-get-testname test-info))
					      (testpatt  (let ((tlast (db:tasks-get-last dbstruct target runname)))
							   (if tlast
							       (let ((tpatt (tasks:task-get-testpatt tlast)))
								 (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017
								     "%"
								     tpatt))
							       "%")))
                                              (item-path (db:test-get-item-path (db:get-test-info-by-id dbstruct run-id test-id)))
                                              (item-test-path (conc test-name "/" (if (equal? item-path "")
									"%" 
									item-path))))
					 (iup:show (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu
						   #:x 'mouse
						   #:y 'mouse
						   #:modal? "NO")
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
		(< (db:test-get-event_time (hash-table-ref testsdat (car a)))
		   (db:test-get-event_time (hash-table-ref testsdat (car b))))))))))

;; run times tab data updater
;;
(define (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num)
  (let* ((access-mode      (dboard:tabdat-access-mode tabdat))

         (last-runs-update (dboard:tabdat-last-runs-update tabdat))
         (runs-dat      (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
	 (runs-header   (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
	 (runs-hash     (let ((ht (make-hash-table)))
			  (for-each (lambda (run)
				      (hash-table-set! ht (db:get-value-by-header run runs-header "id") run))
				    (vector-ref runs-dat 1))
			  ht))
	 (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 runs-header "event_time"))
				       (time-b   (db:get-value-by-header record-b runs-header "event_time")))
				  (< time-a time-b)))))
	 (tb            (dboard:tabdat-runs-tree tabdat))
	 (num-runs      (length (hash-table-keys runs-hash)))
	 (update-start-time (current-seconds))
	 (inc-mode      #f))
    (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
    ;; fill in the tree
    (if (and tb 
	     (not inc-mode))
	(for-each
	 (lambda (run-id)
	   (let* ((run-record (hash-table-ref/default runs-hash run-id #f))







>

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

|







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
		(< (db:test-get-event_time (hash-table-ref testsdat (car a)))
		   (db:test-get-event_time (hash-table-ref testsdat (car b))))))))))

;; run times tab data updater
;;
(define (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num)
  (let* ((access-mode      (dboard:tabdat-access-mode tabdat))
	 (dbstruct         (dboard:get-dbstruct commondat #f))
         (last-runs-update (dboard:tabdat-last-runs-update tabdat))
         (runs-dat         (db:get-runs-by-patt dbstruct (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
	 (runs-header      (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
	 (runs-hash        (let ((ht (make-hash-table)))
			     (for-each (lambda (run)
					 (hash-table-set! ht (db:get-value-by-header run runs-header "id") run))
				       (vector-ref runs-dat 1))
			     ht))
	 (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 runs-header "event_time"))
					  (time-b   (db:get-value-by-header record-b runs-header "event_time")))
				     (< time-a time-b)))))
	 (tb               (dboard:tabdat-runs-tree tabdat))
	 (num-runs         (length (hash-table-keys runs-hash)))
	 (update-start-time (current-seconds))
	 (inc-mode         #f))
    (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
    ;; fill in the tree
    (if (and tb 
	     (not inc-mode))
	(for-each
	 (lambda (run-id)
	   (let* ((run-record (hash-table-ref/default runs-hash run-id #f))
3075
3076
3077
3078
3079
3080
3081
3082

3083
3084
3085
3086
3087
3088
3089
		(vg:drawing-libs-set! dwg (make-hash-table))
		(vg:drawing-insts-set! dwg (make-hash-table))
		(vg:drawing-cache-set! dwg '())
		(dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table))
		;; (dboard:tabdat-allruns-set! tabdat '())
		(dboard:tabdat-max-row-set! tabdat 0)
		(dboard:tabdat-last-filter-str-set! tabdat filtrstr)))
	  (update-rundat tabdat

			 runpatt
			 ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") 
			 (dboard:tabdat-numruns tabdat)
			 testpatt ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
			 ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%")
			 
			 targpatt







|
>







3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
		(vg:drawing-libs-set! dwg (make-hash-table))
		(vg:drawing-insts-set! dwg (make-hash-table))
		(vg:drawing-cache-set! dwg '())
		(dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table))
		;; (dboard:tabdat-allruns-set! tabdat '())
		(dboard:tabdat-max-row-set! tabdat 0)
		(dboard:tabdat-last-filter-str-set! tabdat filtrstr)))
	  (update-rundat commondat
			 tabdat
			 runpatt
			 ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") 
			 (dboard:tabdat-numruns tabdat)
			 testpatt ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
			 ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%")
			 
			 targpatt
3544
3545
3546
3547
3548
3549
3550
3551
3552

3553
3554
3555
3556
3557
3558
3559
;; 
;;  removing the tabdat-values proc 
;;
;; (define (tabdat-values tabdat)

;; runs update-rundat using the various filters from the gui
;;
(define (dashboard:do-update-rundat tabdat)
  (dboard:update-rundat

   tabdat
   (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%")
   (dboard:tabdat-numruns tabdat)
   (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
   ;; generate key patterns from the target stored in tabdat
   (let* ((dbkeys (dboard:tabdat-dbkeys tabdat)))
     (let ((fres   (if (dboard:tabdat-target tabdat)







|

>







3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
;; 
;;  removing the tabdat-values proc 
;;
;; (define (tabdat-values tabdat)

;; runs update-rundat using the various filters from the gui
;;
(define (dashboard:do-update-rundat commondat tabdat)
  (dboard:update-rundat
   commondat
   tabdat
   (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%")
   (dboard:tabdat-numruns tabdat)
   (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
   ;; generate key patterns from the target stored in tabdat
   (let* ((dbkeys (dboard:tabdat-dbkeys tabdat)))
     (let ((fres   (if (dboard:tabdat-target tabdat)
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
   (lambda ()
     (let* ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))
	    (dbkeys (dboard:tabdat-dbkeys tabdat)))
       ;;(print "RA => calling runs-tab-updater with commondat " commondat " tab-num " tab-num)
       ;;(tabdat-values tabdat) ;;RA added 
       ;; (pp (dboard:tabdat->alist tabdat))
       ;; (if (dashboard:database-changed? commondat tabdat context-key: 'runs-rundat)      
       (dashboard:do-update-rundat tabdat)
       ;;(debug:print-info 13 *default-log-port* "dashboard:runs-tab-updater")
       ;;(inspect tabdat)

       (let ((uidat (dboard:commondat-uidat commondat)))
	 ;;(print "RA => Calling update-buttons with tabdat : " tabdat " uidat " uidat)
	 (update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat)))
       ))







|







3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
   (lambda ()
     (let* ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))
	    (dbkeys (dboard:tabdat-dbkeys tabdat)))
       ;;(print "RA => calling runs-tab-updater with commondat " commondat " tab-num " tab-num)
       ;;(tabdat-values tabdat) ;;RA added 
       ;; (pp (dboard:tabdat->alist tabdat))
       ;; (if (dashboard:database-changed? commondat tabdat context-key: 'runs-rundat)      
       (dashboard:do-update-rundat commondat tabdat)
       ;;(debug:print-info 13 *default-log-port* "dashboard:runs-tab-updater")
       ;;(inspect tabdat)

       (let ((uidat (dboard:commondat-uidat commondat)))
	 ;;(print "RA => Calling update-buttons with tabdat : " tabdat " uidat " uidat)
	 (update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat)))
       ))

Modified db.scm from [bfb6181eca] to [a590ce171e].

84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
;;   NOTE: This does do a sync (the db:open-db proc only does an initial sync if called with do-sync: #t
;;   NOTE: Longer term consider replacing db:open-db with this
;;
;; NOTE: loose ends!!
;;    db:open-db              -> not properly using tmpdb path
;;    common:get-db-tmp-area  -> using *toppath* and common:get-testsuite-area
;;    
(define (db:dashboard-open-db areas area-name area-path)
  ;; 0. check for already existing dbstruct in areas hash, return it if found
  ;; 1. do minimal read of megatest.config, store configdat, keys in dbstruct
  ;; 2. get homehost
  ;; 3. create /tmp db area  (if needed)
  ;; 4. sync data to /tmp db (or update if exists)
  ;; 5. return dbstruct
  (if (hash-table-exists? areas area-name)







|







84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
;;   NOTE: This does do a sync (the db:open-db proc only does an initial sync if called with do-sync: #t
;;   NOTE: Longer term consider replacing db:open-db with this
;;
;; NOTE: loose ends!!
;;    db:open-db              -> not properly using tmpdb path
;;    common:get-db-tmp-area  -> using *toppath* and common:get-testsuite-area
;;    
(define (db:dashboard-open-dbstruct areas area-name area-path)
  ;; 0. check for already existing dbstruct in areas hash, return it if found
  ;; 1. do minimal read of megatest.config, store configdat, keys in dbstruct
  ;; 2. get homehost
  ;; 3. create /tmp db area  (if needed)
  ;; 4. sync data to /tmp db (or update if exists)
  ;; 5. return dbstruct
  (if (hash-table-exists? areas area-name)
3165
3166
3167
3168
3169
3170
3171















3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
















3191
3192
3193
3194
3195
3196
3197
       (sqlite3:for-each-row 
	(lambda (id test-id stepname state status event-time logfile comment)
	  (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment) res)))
	db
	"SELECT id,test_id,stepname,state,status,event_time,logfile,comment 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)







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



















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







3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
       (sqlite3:for-each-row 
	(lambda (id test-id stepname state status event-time logfile comment)
	  (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment) res)))
	db
	"SELECT id,test_id,stepname,state,status,event_time,logfile,comment 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-info-by-id dbstruct  test-step-id)
   (db:with-db
    dbstruct
    #f 
    #f
    (lambda (db)
      (let* ((res (vector #f #f #f #f #f #f #f #f)))
        (sqlite3:for-each-row 
       (lambda (id test-id stepname state status event-time logfile comment)
         (set! res (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment)))
       db
       "SELECT id,test_id,stepname,state,status,event_time,logfile,comment FROM test_steps WHERE id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
       test-step-id)
        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 
;;======================================================================

 (define (db:get-data-info-by-id dbstruct  test-data-id)
   (db:with-db
    dbstruct
    #f 
    #f
    (lambda (db)
      (let* ((res (vector #f #f #f #f #f #f #f #f #f #f #f)))
        (sqlite3:for-each-row 
       (lambda (id test-id  category variable value expected tol units comment status type )
         (set! res (vector id test-id  category variable value expected tol units comment status type)))
       db
       "SELECT id,test_id, category, variable, value, expected, tol, units, comment, status, type FROM test_data WHERE id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
       test-data-id)
        res))))


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

Modified docs/Makefile from [ef7610ee8e] to [d02c979809].

11
12
13
14
15
16
17


html/megatest.html : megatest.lyx
	elyxer megatest.lyx html/megatest.html
	fossil add html/*

megatest.pdf : megatest.lyx
	lyx -e pdf2 megatest.lyx










>
>
11
12
13
14
15
16
17
18
19
html/megatest.html : megatest.lyx
	elyxer megatest.lyx html/megatest.html
	fossil add html/*

megatest.pdf : megatest.lyx
	lyx -e pdf2 megatest.lyx

pkts.pdf : pkts.dot
	dot -Tpdf pkts.dot -o pkts.pdf

Added docs/pkts.dot version [efa03bf87d].























































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
digraph megatest_pkts {
  ranksep=0.05
  // rankdir=LR

node [shape=box,style=filled];
  
  "SENSORS" [ label = "{ Sensor Processing | { file | git | fossil | script }}"
	      shape = "record"; ];
  
  "RUNS"    [ label = "{ Runs Processing | { launch | clean | re-run | archive } | { dispatcher }}";
	      shape = "record"; ];

  "WORK"    [ label = "{ Work Items | { start task | task competed }}";
	      shape = "record"; ];

  "USERREQ" [ label = "{ User Requests (Unix and Web) | { launch | clean | re-run | archive }}";
	      shape = "record"; ];

  "MTAREA1" [ label = "{ Megatest Area 1 | { parallel job\nmanagement | test\nmanagement | data\nrollup }}";
	      shape = "record"; ];
  
  "MTAREA2" [ label = "{ Megatest Area 2 | { parallel job\nmanagement | test\nmanagement | data\nrollup }}";
	      shape = "record"; ];
  
  "MTAREA3" [ label = "More Megatest Areas ... ";
	      shape = "record"; ];

  "PGDB"    [ label = "postgres database";
	      shape = "cylinder"; ];

  "WEBAPP"  [ label = "{ Web View | { Runs | Contours | Control | Time View }}";
	      shape = "record"; ];

  // "WEBCTRL" [ label = "{ Web View \n(control) }";
  //	      shape = "record"; ];
  
  "SENSORS" -> "SPKTS";
  "RUNS"    -> "run pkts";
  "run pkts" -> "RUNS";
  "WORK"    -> "work pkts";
  "work pkts" -> "RUNS";
  "USERREQ" -> "user request pkts";
  "SPKTS"   -> "RUNS";
  "user request pkts" -> "RUNS";
  "RUNS"    -> "MTAREA1" -> "PGDB";
  "RUNS"    -> "MTAREA2" -> "PGDB";
  "RUNS"    -> "MTAREA3" -> "PGDB";
  "PGDB"    -> "WEBAPP";
  // "WEBCTRL" -> "run pkts";
  
  subgraph cluster_pkts {
    label="Packets";
    "SPKTS" [ label = "Sensor Packets" ];
    "run pkts";
    "work pkts";
    "user request pkts";
  }
}

Added docs/pkts.pdf version [d5020c63eb].

cannot compute difference between binary files

Modified ezsteps.scm from [7343e2c83a] to [c762a5a017].

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

;; 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 directory-utils)
(import (prefix sqlite3 sqlite3:))

(declare (unit ezsteps))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
;; (declare (uses sdb))












|
<







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

14
15
16
17
18
19
20

;; 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 srfi-1 posix regex srfi-69 directory-utils)


(declare (unit ezsteps))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
;; (declare (uses sdb))

Added get-config-settings.sh version [3a902c0f68].





>
>
1
2
 grep configf:lookup *.scm | sed 's/^.*:lookup//; s/^-number//; s/^ //' | grep -v '^\(section\|test-conf\|tconfig\|testconfig\|dat\|config\|views-cfgdat\)' | perl -pe 's/^\s*(\*configdat\*|configdat|mtconf)//; s/^\s+//; s/\).*$//; s/"//g' | awk '{print $1,$2}' | sort | grep -v section | sort | uniq

Modified http-transport.scm from [151d15c33c] to [8eb0d5e749].

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

;; 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 posix-extras) ;; sqlite3
;; (import (prefix sqlite3 sqlite3:))

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

;; Configurations for server
(tcp-buffer-size 2048)
(max-connections 2048) 













|
<







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

14
15
16
17
18
19
20

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


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

;; Configurations for server
(tcp-buffer-size 2048)
(max-connections 2048) 

Modified keys.scm from [c68ef5527f] to [4dd65969ab].

62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
	   (list key targ))
	 keys targtweaked)))

;;======================================================================
;; config file related routines
;;======================================================================

(define (keys:config-get-fields confdat)
  (let ((fields (hash-table-ref/default confdat "fields" '())))
    (map car fields)))

(define (keys:make-key/field-string confdat)
  (let ((fields (configf:get-section confdat "fields")))
    (string-join
     (map (lambda (field)(conc (car field) " " (cadr field)))
	  fields)
     ",")))








|
<
<
<







62
63
64
65
66
67
68
69



70
71
72
73
74
75
76
	   (list key targ))
	 keys targtweaked)))

;;======================================================================
;; config file related routines
;;======================================================================

(define keys:config-get-fields common:get-fields)



(define (keys:make-key/field-string confdat)
  (let ((fields (configf:get-section confdat "fields")))
    (string-join
     (map (lambda (field)(conc (car field) " " (cadr field)))
	  fields)
     ",")))

Modified launch.scm from [d2bf0c2411] to [dd33d34146].

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







<
<
<







19
20
21
22
23
24
25



26
27
28
29
30
31
32
(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
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
	       (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 (common:file-exists? fulln)
                                                   (file-execute-access? fulln))
                                              fulln
                                              runscript))))) ;; assume it is on the path
	       ) ;; (rollup-status 0)

	  (if contour (setenv "MT_CONTOUR" contour))







|







446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
	       (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 work-area "/" runscript)))
	                                  (if (and (common:file-exists? fulln)
                                                   (file-execute-access? fulln))
                                              fulln
                                              runscript))))) ;; assume it is on the path
	       ) ;; (rollup-status 0)

	  (if contour (setenv "MT_CONTOUR" contour))
515
516
517
518
519
520
521
522
523
524
525
526
527
528




























529
530
531
532
533
534
535
	;;    	  (handle-exceptions
	;;    	      exn
	;;    	      (debug:print 0 *default-log-port* "Failed to create directory " logdir " expect problems, message: " ((condition-property-accessor 'exn 'message) exn))
	;;    	    (create-directory logdir #t)))))
	;;    	  
	  ;; NFS might not have propagated the directory meta data to the run host - give it time if needed
	  (let loop ((count 0))
	    (if (or (common:file-exists? top-path)
		    (> count 10))
		(change-directory top-path)
		(begin
		  (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " top-path " not found")
		  (thread-sleep! 10)
		  (loop (+ count 1)))))




























	  (launch:setup) ;; should be properly in the top-path now
	  (set! tconfigreg (tests:get-all))
	  (let ((sighand (lambda (signum)
			   ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting
			   (if (eq? signum signal/stop)
			       (debug:print-error 0 *default-log-port* "attempt to STOP process. Exiting."))
			   (set! *time-to-exit* #t)







|

|

|


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







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
	;;    	  (handle-exceptions
	;;    	      exn
	;;    	      (debug:print 0 *default-log-port* "Failed to create directory " logdir " expect problems, message: " ((condition-property-accessor 'exn 'message) exn))
	;;    	    (create-directory logdir #t)))))
	;;    	  
	  ;; NFS might not have propagated the directory meta data to the run host - give it time if needed
	  (let loop ((count 0))
	    (if (or (common:directory-exists? work-area)
		    (> count 10))
		(change-directory work-area)
		(begin
		  (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " work-area " not found")
		  (thread-sleep! 10)
		  (loop (+ count 1)))))

          (if (not (string=?  (common:real-path work-area)(common:real-path (current-directory))))
              (begin
                (debug:print 0 *default-log-port*
                             "INFO: we are expecting to be in directory " work-area "\n"
                             "     but we are actually in the directory " (current-directory) "\n"
                             "     doing another change dir.")
                (change-directory work-area)))
          
	  ;; spot check that the files in testpath are available. Too often NFS delays cause problems here.
	  (let ((files      (glob (conc testpath "/*")))
		(bad-files '()))
	    (for-each
	     (lambda (fullname)
	       (let* ((fname (pathname-strip-directory fullname))
                      (targn (conc work-area "/" fname)))
		 (if (not (file-exists? targn))
		     (set! bad-files (cons fname bad-files)))))
	     files)
	    (if (not (null? bad-files))
                (begin
                  (debug:print 0 *default-log-port* "INFO: test data from " testpath " not copied properly or filesystem problems causing data to not be found. Re-running the copy command.")
                  (debug:print 0 *default-log-port* "INFO: missing files from " work-area ": " (string-intersperse bad-files ", "))
                  (launch:test-copy testpath work-area))))

          ;; one more time, change to the work-area directory
          (change-directory work-area)
          
	  (launch:setup) ;; should be properly in the top-path now
	  (set! tconfigreg (tests:get-all))
	  (let ((sighand (lambda (signum)
			   ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting
			   (if (eq? signum signal/stop)
			       (debug:print-error 0 *default-log-port* "attempt to STOP process. Exiting."))
			   (set! *time-to-exit* #t)
557
558
559
560
561
562
563

564
565
566
567
568
569
570
571
		 (test-host (if test-info
				(db:test-get-host        test-info)
				(begin
				  (debug:print 0 *default-log-port* "ERROR: failed to find a record for test-id " test-id ", exiting.")
				  (exit))))
		 (test-pid  (db:test-get-process_id  test-info)))
	    (cond

	     ((member (db:test-get-state test-info) '("INCOMPLETE" "KILLED" "UNKNOWN" "KILLREQ" "STUCK")) ;; prior run of this test didn't complete, go ahead and try to rerun
	      (debug:print 0 *default-log-port* "INFO: test is INCOMPLETE or KILLED, treat this execute call as a rerun request")
	      ;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")
	      (rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f)
	      ) ;; prime it for running
	     ((member (db:test-get-state test-info) '("RUNNING" "REMOTEHOSTSTART"))
	      (if (process:alive-on-host? test-host test-pid)
		  (debug:print-error 0 *default-log-port* "test state is "  (db:test-get-state test-info) " and process " test-pid " is still running on host " test-host ", cannot proceed")







>
|







582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
		 (test-host (if test-info
				(db:test-get-host        test-info)
				(begin
				  (debug:print 0 *default-log-port* "ERROR: failed to find a record for test-id " test-id ", exiting.")
				  (exit))))
		 (test-pid  (db:test-get-process_id  test-info)))
	    (cond
             ;; -mrw- I'm removing KILLREQ from this list so that a test in KILLREQ state is treated as a "do not run" flag.
	     ((member (db:test-get-state test-info) '("INCOMPLETE" "KILLED" "UNKNOWN" "STUCK")) ;; prior run of this test didn't complete, go ahead and try to rerun
	      (debug:print 0 *default-log-port* "INFO: test is INCOMPLETE or KILLED, treat this execute call as a rerun request")
	      ;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")
	      (rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f)
	      ) ;; prime it for running
	     ((member (db:test-get-state test-info) '("RUNNING" "REMOTEHOSTSTART"))
	      (if (process:alive-on-host? test-host test-pid)
		  (debug:print-error 0 *default-log-port* "test state is "  (db:test-get-state test-info) " and process " test-pid " is still running on host " test-host ", cannot proceed")
1067
1068
1069
1070
1071
1072
1073
















1074
1075
1076
1077
1078
1079
1080
	(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 or no disk with enough space")
		    (debug:print-error 0 *default-log-port* "No valid disks found in megatest.config. Please add some to your [disks] section and ensure the directory exists and has enough space!\n    You can change minspace in the [setup] section of megatest.config. Current setting is: " minspace))
		(exit 1))))))) ;; TODO - move the exit to the calling location and return #f

















;; Desired directory structure:
;;
;;  <linkdir> - <target> - <testname> -.
;;                                     |
;;                                     v
;;  <rundir>  -  <target>  -    <testname> -|- <itempath(s)>







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







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
	(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 or no disk with enough space")
		    (debug:print-error 0 *default-log-port* "No valid disks found in megatest.config. Please add some to your [disks] section and ensure the directory exists and has enough space!\n    You can change minspace in the [setup] section of megatest.config. Current setting is: " minspace))
		(exit 1))))))) ;; TODO - move the exit to the calling location and return #f

(define (launch:test-copy test-src-path test-path)
  (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 *default-log-port* "ERROR: problem with running \"" cmd "\""))))


;; Desired directory structure:
;;
;;  <linkdir> - <target> - <testname> -.
;;                                     |
;;                                     v
;;  <rundir>  -  <target>  -    <testname> -|- <itempath(s)>
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
	   (if (not (common: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 *default-log-port* "ERROR: problem with running \"" cmd "\"")))
	  (list lnkpathf lnkpath ))
	(if (and test-src-path (> remtries 0))
	    (begin
	      (debug:print-error 0 *default-log-port* "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)))))







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







1274
1275
1276
1277
1278
1279
1280




1281








1282
1283
1284
1285
1286
1287
1288
	   (if (not (common: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




	  (launch:test-copy test-src-path test-path)








	  (list lnkpathf lnkpath ))
	(if (and test-src-path (> remtries 0))
	    (begin
	      (debug:print-error 0 *default-log-port* "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)))))

Modified lock-queue.scm from [27c3c65ee2] to [d7fae23ac5].

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









<
|







1
2
3
4
5
6
7
8
9

10
11
12
13
14
15
16
17
;; 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 (prefix sqlite3 sqlite3:) srfi-18)

(declare (unit lock-queue))
(declare (uses common))
(declare (uses tasks))

;;======================================================================
;; attempt to prevent overlapping updates of rollup files by queueing

Modified megatest-version.scm from [4677c6dd43] to [79665d4b93].

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.6428)






|

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.6502)

Modified megatest.config from [a8d97f813e] to [f4675900d6].

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

## commented out due to a bug in v1.6501 in mtutil
[fields]
a text
b text
c text





[setup]
pktsdirs /tmp/pkts /some/other/source

[areas]
#         path=path-to-area;targtrans=script_to_transform_target
local     path=.

fullrun   path=tests/fullrun
# targtrans is name of scheme proc stored in .mtutil.scm, which lives in PWD where mtutil is run

# ext-tests path=ext-tests; targtrans=prefix-contour;
ext       path=ext-tests

[contours]
#     mode-patt/tag-expr


quick selector=QUICKPATT/quick
full  areas=fullrun,ext-tests; selector=MAXPATT/

all   areas=fullrun,ext-tests
snazy areas=%; selector=QUICKPATT/

[nopurpose]




















[server]
timeout 1






>
>
>
>


|




>
|

>





>
>
|
|
>
|
|


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



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

## commented out due to a bug in v1.6501 in mtutil
[fields]
a text
b text
c text
usercode    .mtutil.scm
areafilter  area-to-run
targtrans   generic-target-translator
runtrans    generic-runname-translator

[setup]
pktsdirs /tmp/mt_pkts /some/other/source

[areas]
#         path=path-to-area;targtrans=script_to_transform_target
local     path=.
# someqa     path=../megatestqa/someqa; targtrans=somefunc; areafilter=area-to-run
fullrun   path=tests/fullrun; 
# targtrans is name of scheme proc stored in .mtutil.scm, which lives in PWD where mtutil is run
#           the target translator can return: a/target OR (list/of targets/to apply/run) OR #f i.e. run nothing
# ext-tests path=ext-tests; targtrans=prefix-contour;
ext       path=ext-tests

[contours]
#     mode-patt/tag-expr
quick areas=ext;    selector=/QUICKPATT
quick2 areafn=check-area; selector=/QUICKPATT
# quick areas=fullrun,ext-tests; selector=QUICKPATT/quick
# full  areas=fullrun,ext-tests; selector=MAXPATT/
# short areas=fullrun,ext-tests; selector=MAXPATT/
# all   areas=fullrun,ext-tests
# snazy selector=QUICKPATT/

[nopurpose]

[access]
ext matt:admin mattw:owner

[accesstypes]
admin run rerun resume remove set-ss
owner run rerun resume remove
badguy set-ss

[setup]
maxload 1.2

[listeners]
localhost:12345  contact=matt@kiatoa.com
localhost:54321  contact=matt@kiatoa.com

[listener]
script nbfake echo


[server]
timeout 1

Modified megatest.scm from [d2c3028f31] to [a6fd98e3db].

9
10
11
12
13
14
15

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

;; (include "common.scm")
;; (include "megatest-version.scm")

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


(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 readline apropos json http-client directory-utils rpc typed-records;; (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))







>
|
|





<
<
<







9
10
11
12
13
14
15
16
17
18
19
20
21
22
23



24
25
26
27
28
29
30

;; (include "common.scm")
;; (include "megatest-version.scm")

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

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

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




(require-library mutils)

;; (use zmq)

(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
;;                            from prior runs with same keys
;;  -daemonize              : fork into background and disconnect from stdin/out

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

Usage: megatest [options]
  -h                      : this help
  -manual                 : show the Megatest user manual
  -version                : print megatest version (currently " megatest-version ")

Launching and managing runs
  -run                    : run all tests or as specified by -testpatt







|







86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
;;                            from prior runs with same keys
;;  -daemonize              : fork into background and disconnect from stdin/out

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

Launching and managing runs
  -run                    : run all tests or as specified by -testpatt
112
113
114
115
116
117
118

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


Selectors (e.g. use for -runtests, -remove-runs, -set-state-status, -list-runs etc.)
  -target key1/key2/...   : run for key1, key2, etc.
  -reqtarg key1/key2/...  : run for key1, key2, etc. but key1/key2 must be in runconfigs
  -testpatt patt1/patt2,patt3/...  : % is wildcard
  -runname                : required, name for this particular test run
  -state                  : Applies to runs, tests or steps depending on context







>







110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
  -unlock                 : unlock run specified by target and runname
  -set-run-status status  : sets status for run to status, requires -target and -runname
  -get-run-status         : gets status for run specified by target and runname
  -run-wait               : wait on run specified by target and runname
  -preclean               : remove the existing test directory before running the test
  -clean-cache            : remove the cached megatest.config and runconfigs.config files
  -no-cache               : do not use the cached config files. 
  -one-pass               : launch as many tests as you can but do not wait for more to be ready

Selectors (e.g. use for -runtests, -remove-runs, -set-state-status, -list-runs etc.)
  -target key1/key2/...   : run for key1, key2, etc.
  -reqtarg key1/key2/...  : run for key1, key2, etc. but key1/key2 must be in runconfigs
  -testpatt patt1/patt2,patt3/...  : % is wildcard
  -runname                : required, name for this particular test run
  -state                  : Applies to runs, tests or steps depending on context
345
346
347
348
349
350
351

352
353
354
355
356
357
358
			;; misc
			"-repl"
			"-lock"
			"-unlock"
			"-list-servers"
			"-kill-servers"
                        "-run-wait"      ;; wait on a run to complete (i.e. no RUNNING)

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

			;; misc queries
			"-list-disks"
			"-list-targets"
			"-list-db-targets"







>







344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
			;; misc
			"-repl"
			"-lock"
			"-unlock"
			"-list-servers"
			"-kill-servers"
                        "-run-wait"      ;; wait on a run to complete (i.e. no RUNNING)
			"-one-pass"       ;;
			"-local"         ;; run some commands using local db access
                        "-generate-html"

			;; misc queries
			"-list-disks"
			"-list-targets"
			"-list-db-targets"

Added minimt/Makefile version [1ca1494fdb].

























>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
minimt : minimt.scm db.scm setup.scm direct.scm
	csc minimt.scm

run    : minimt
	export PATH="$(PWD)":$(PATH) ; minimt runrun foo/bar run1 

runseq : clean run 
	sleep 5;tail -F runtest/*log

clean :
	rm -rf runtest/*

Added minimt/db.scm version [a9b4773d46].



























































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
;; pretend to be a simplified Megatest

(use sql-de-lite defstruct)

;; init the db - NOTE: takes a db NOT a dbconn
;;
(define (init-db db)
  (with-transaction
   db
   (lambda ()
     (for-each
      (lambda (qrystr)
	(exec (sql db qrystr)))
      '("CREATE TABLE IF NOT EXISTS runs 
           (id        INTEGER PRIMARY KEY,
            target    TEXT NOT NULL,
            run_name  TEXT NOT NULL,
            state     TEXT NOT NULL,
            status    TEXT NOT NULL,
            CONSTRAINT runs_constraint UNIQUE (run_name));"
	"CREATE TABLE IF NOT EXISTS tests
           (id        INTEGER PRIMARY KEY,
            run_id    INTEGER NOT NULL,
            test_name TEXT NOT NULL,
            state     TEXT NOT NULL,
            status    TEXT NOT NULL,
            start_time INTEGER DEFAULT (strftime('%s','now')),
            end_time   INTEGER DEFAULT -1,
            CONSTRAINT tests_constraint UNIQUE (run_id,test_name));"
	"CREATE TABLE IF NOT EXISTS steps
           (id        INTEGER PRIMARY KEY,
            test_id   INTEGER NOT NULL,
            step_name  TEXT NOT NULL,
            state     TEXT NOT NULL,
            status    TEXT NOT NULL,
            CONSTRAINT step_constraint UNIQUE (test_id,step_name));")))))

(defstruct dbconn-dat
  dbh       ;; the database handle
  writeable ;; do we have write access?
  path      ;; where the db lives
  name      ;; name of the db
  )

;; open the database, return a dbconn struct
(define (open-create-db path fname init)
  (let* ((fullname       (conc path "/" fname))
	 (already-exists (file-exists? fullname))
	 (write-access   (and (file-write-access? path)
			      (or (not already-exists)
				  (and already-exists
				       (file-write-access? fullname)))))
	 (db             (if (or already-exists write-access)
			     (open-database fullname)
			     (begin
			       (print "FATAL: No existing db and no write access thus cannot create " fullname)  ;; no db and no write access cannot proceed.
			       (exit 1))))
	 (dbconn         (make-dbconn-dat)))
    (set-busy-handler! db (busy-timeout 120000)) ;; set a busy timeout
    (exec (sql db "PRAGMA synchronous=0;"))
    (if (and init write-access (not already-exists))
	(init db))
    (dbconn-dat-dbh-set!       dbconn db)
    (dbconn-dat-writeable-set! dbconn write-access)
    (dbconn-dat-path-set!      dbconn path)
    (dbconn-dat-name-set!      dbconn fname)
    dbconn))

(define-inline (get-db dbconn)
  (dbconn-dat-dbh dbconn))

;; RUNS

;; create a run
(define (create-run dbconn target run-name)
  (exec (sql (get-db dbconn) "INSERT INTO runs (run_name,target,state,status) VALUES (?,?,'NEW','na');")
	run-name target))

;; get a run id
(define (get-run-id dbconn target run-name)
  (first-column (query fetch (sql (get-db dbconn) "SELECT id FROM runs WHERE target=? AND run_name=?;")
		       target run-name)))

;; TESTS

(defstruct test-dat
  id
  run-id
  test-name
  state
  status)

;; create a test
(define (create-test dbconn run-id test-name)
  (exec (sql (get-db dbconn) "INSERT INTO tests (run_id,test_name,state,status) VALUES (?,?,'NOT_STARTED','na');")
	run-id test-name))

;; get a test id
(define (get-test-id dbconn run-id test-name)
  (first-column (query fetch (sql (get-db dbconn) "SELECT id FROM tests WHERE run_id=? AND test_name=?;")
		       run-id test-name)))

(define-inline (test-row->test-dat row)
    (make-test-dat
     id:        (list-ref row 0)
     run-id:    (list-ref row 1)
     test-name: (list-ref row 2)
     state:     (list-ref row 3)
     status:    (list-ref row 4)))
  
;; get the data for given test-id
(define (test-get-record dbconn test-id)
  (let* ((row (query fetch-row (sql (get-db dbconn) "SELECT id,run_id,test_name,state,status FROM tests WHERE test_id=?;")
		     test-id)))
    (test-row->test-dat row)))

;; get a bunch of tests data
(define (test-get-tests dbconn run-ids test-name-patt)
  (let* ((rows (query fetch-rows
		      (sql (get-db dbconn)
			   (conc "SELECT id,run_id,test_name,state,status FROM tests WHERE test_name LIKE ? AND run_id IN ("
				 (string-intersperse (map conc run-ids) ",") ");"))
		      test-name-patt)))
    (map test-row->test-dat rows)))
   
(define (test-set-state-status dbconn test-id new-state new-status)
  (exec (sql (get-db dbconn) "UPDATE tests SET state=?,status=?,end_time=? WHERE id=?;")
	new-state new-status (current-seconds) test-id))

;; STEPS

;; create a step
(define (create-step dbconn test-id step-name)
  (exec (sql (get-db dbconn) "INSERT INTO steps (test_id,step_name,state,status) VALUES (?,?,'NOT_STARTED','na');")
	test-id step-name))

;; get a step id
(define (get-step-id dbconn test-id step-name)
  (first-column (query fetch (sql (get-db dbconn) "SELECT id FROM steps WHERE test_id=? AND step_name=?;")
		       test-id step-name)))

(define (step-set-state-status dbconn step-id new-state new-status)
  (exec (sql (get-db dbconn) "UPDATE steps SET state=?,status=? WHERE id=?;")
	new-state new-status step-id))

;;======================================================================
;; Statistics gathering
;;======================================================================

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

(define (update-stats key duration)
  (let ((rec (or (hash-table-ref/default *stats* key #f)
		 (let ((new (vector 0 0 0)))
		   (hash-table-set! *stats* key new)
		   new))))
    (vector-set! rec 0 (+ (vector-ref rec 0) 1))        ;; num calls
    (vector-set! rec 1 (+ (vector-ref rec 1) duration)) ;; total duration
    (if (> duration (vector-ref rec 2) )
	(vector-set! rec 2 duration))))

(define (statwrap name proc)
  (lambda params
    (let ((start-time (current-milliseconds))
	  (res        (apply proc params)))
      (update-stats name (- (current-milliseconds) start-time))
      res)))

(define (print-stats statdat)
  (hash-table-for-each
   statdat
   (lambda (key val)
     (print key " count: " (vector-ref val 0) " avg: " (/ (vector-ref val 1)(vector-ref val 0)) " max: " (vector-ref val 2)))))

Added minimt/direct.scm version [54cabed7c0].























>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
;; direct API, call the db calls directly
(define rmt:create-run            (statwrap 'create-run  create-run))
(define rmt:create-step           (statwrap 'create-step create-step))
(define rmt:create-test           (statwrap 'create-test create-test))
(define rmt:get-test-id           (statwrap 'get-test-id get-test-id))
(define rmt:get-run-id            (statwrap 'get-run-id  get-run-id))
(define rmt:open-create-db        (statwrap 'open        open-create-db))
(define rmt:step-set-state-status (statwrap 'step-set-state-status step-set-state-status))
(define rmt:test-set-state-status (statwrap 'test-set-state-status test-set-state-status))
(define rmt:test-get-tests        (statwrap 'test-get-tests        test-get-tests))

Added minimt/minimt.scm version [b536a35340].













































































































































































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

(include "db.scm")

;; define following in setup.scm
;;    *remotehost*  => host for "tests"
;;    *homehost*    => host for servers
;;    *homepath*    => directory from which to run
;;    *numtests*    => how many tests to simulate for each run
;;    *numruns*     => how many runs to simulate
;;    
(include "setup.scm")

(include "direct.scm") ;; direct db calls

;; RUN A TEST
(define (run-test dbconn run-id test-name)
  (rmt:create-test dbconn run-id test-name)
  (let ((test-id (rmt:get-test-id dbconn run-id test-name)))
    (rmt:test-set-state-status dbconn test-id "LAUNCHED" "na")
    (thread-sleep! *launchdelay*)
    (rmt:test-set-state-status dbconn test-id "RUNNING" "na")
    (let loop ((step-num 0))
      (let ((step-name (conc "step" step-num)))
       (rmt:create-step dbconn test-id step-name)
       (let ((step-id (get-step-id dbconn test-id step-name)))
	 (rmt:step-set-state-status dbconn step-id "START" -1)
	 (thread-sleep! *stepdelay*)
	 (rmt:step-set-state-status dbconn step-id "END" 0)
	 (print"   STEP: " step-name " done.")))
      (if (< step-num *numsteps*)
	  (loop (+ step-num 1))))
    ;; we will do a large but bogus read to simulate the logic in Megatest
    (rmt:test-get-tests dbconn `(,run-id) "%")
    (rmt:test-set-state-status dbconn test-id "COMPLETED" (if (> (random 10) 2) "PASS" "FAIL"))
    (print "TEST: " test-name " done.")
    (print "Stats:")
    (print-stats *stats*)
    test-id))

;; RUN A RUN
(define (run-run dbconn target run-name num-tests)
  (rmt:create-run dbconn target run-name)
  (let ((run-id (rmt:get-run-id dbconn target run-name)))
    (let loop ((test-num 0))
      (system (conc "NBFAKE_LOG=test-" test-num "-run-id-" run-id ".log NBFAKE_HOST=" *remotehost* " nbfake minimt runtest " run-id " test-" test-num))
      (if (< test-num num-tests)
	  (loop (+ test-num 1))))))

;; Do what is asked
(let ((args (cdr (argv))))
  (if (< (length args) 1)
      (print
       "Usage: minimt [options]" "
  runtest run-id testname
  runrun  target runname")
      (let ((cmd    (car args))
	    (dbconn (rmt:open-create-db *homepath* "mt.db" init-db)))
	(thread-sleep! 0.5) ;; be sure the db is written out to disk? Should really not be needed.
	(change-directory *homepath*)
	(case (string->symbol cmd)
	  ((runtest)
	   (let ((run-id    (string->number (cadr args)))
		 (test-name (caddr args)))
	     (print "Launching test " test-name " for run-id " run-id)
	     (run-test dbconn run-id test-name)))
	  ((runrun)
	   (let ((target   (cadr args))
		 (run-name (caddr args)))
	     (run-run dbconn target run-name *numtests*)
	     (print "Use: sqlite3 runtest/mt.db 'select max(end_time)-min(start_time) from tests;' to see the total run time")
	     ))
	  ((runall)
	   (for-each
	    (lambda (target)
	      (let loop ((run-num 0))
		(thread-sleep! *rundelay*)
		(system (conc "NBFAKE_LOG=run-" target "-" run-num ".log nbfake minimt runrun " target " run-" run-num))
		(if (< run-num *numruns*)
		    (loop (+ run-num 1)))))
	    *targets*))
	  ((server)
	   (start-server dbconn))
	  (else
	   (print "Command: " cmd " not recognised. Run without params to see help.")))
	(close-database (dbconn-dat-dbh dbconn)))))

Added minimt/queued.scm version [71e1ba00f3].



































































































































































































































































































































































































































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

(use nanomsg defstruct srfi-18)

;;======================================================================
;; Commands
;;======================================================================

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

(defstruct cmd
  key
  proc
  ctype ;; command type; 'r (read), 'w (write) or 't (transaction)
  )

(define (register-command key ctype proc)
  (hash-table-set! *commands*
		   key
		   (make-cmd key: key ctype: ctype proc: proc)))

(define (get-proc key)
  (cmd-proc (hash-table-ref key *commands*)))

(for-each
 (lambda (dat)
   (apply register-command dat))
 `( (create-run    w ,create-run)
    (create-step   w ,create-step)
    (create-test   w ,create-test)
    (get-test-id   r ,get-test-id)
    (get-run-id    r ,get-run-id)
    ;; (open-db       w ,open-create-db)
    (step-set-ss   w ,step-set-state-status)
    (test-set-ss   w ,test-set-state-status)
    (test-get-tests r ,test-get-tests) ))

;;======================================================================
;; Server/client stuff
;;======================================================================

(define-inline (encode data)
  (with-output-to-string
    (lambda ()
      (write data))))

(define-inline (decode data)
  (with-input-from-string
      data
    (lambda ()
      (read))))
  
;;======================================================================
;; Command queue
;;======================================================================

(defstruct qitem
  command
  params
  host-port)

(define *cmd-queue* '())
(define *queue-mutex* (make-mutex))

(define (queue-push cmddat)
  (mutex-lock! *queue-mutex*)
  (set! *cmd-queue* (cons cmddat *cmd-queue*))
  (mutex-unlock! *queue-mutex*))

;; get all the cmds of type ctype and return them, also remove them from the queue
(define (queue-take ctype)
  (mutex-lock! *queue-mutex*)
  (let ((res (filter (lambda (x)(eq? (cmd-ctype x) ctype))       *cmd-queue*))
	(rem (filter (lambda (x)(not (eq? (cmd-ctype x) ctype))) *cmd-queue*)))
    (set! *queue* rem)
    (mutex-unlock! *queue-mutex*)
    res))

(define (queue-process-commands dbconn commands)
  (for-each
   (lambda (qitem)
     (let ((soc (request-connect (qitem-host-port qitem))) ;; we will be sending the data back to host-port via soc
	   (cmd (hash-table-ref/default *commands* (qitem-command qitem) #f)))
       (if cmd
	   (let* ((res (apply (get-proc cmd) dbconn (qitem-params qitem)))
		  (pkg (encode `((r . ,res)))))
	     (nn-send soc pkg)
	     (if (not (eq? (nn-recv soc)) "ok")
		 (print "Client failed to receive properly the data from " cmd " request"))))))
   commands))

;; the continuously running queue processor
;;
(define ((queue-processor dbconn))
  (let loop ()
    (queue-process-commands dbconn (queue-take 'r))  ;; reads first, probably largest numbers of them
    (queue-process-commands dbconn (queue-take 'w))  ;; writes next
    (queue-process-commands dbconn (queue-take 't))  ;; lastly process transactions
    (thread-sleep! 0.2)                              ;; open up the db for any other processes to access
    (loop)))

;;======================================================================
;; Client stuff
;;======================================================================

;; client struct
(defstruct client
  host-port
  socket
  last-access)

(define *clients* (make-hash-table)) ;; host:port -> client struct
(define *client-mutex* (make-mutex))

;; add a channel or return existing channel, this is a normal req
;; 
(define (request-connect host-port)
  (mutex-lock! *client-mutex*)
  (let* ((curr (hash-table-ref/default *clients* host-port #f)))
    (if curr
	(begin
	  (mutex-unlock! *client-mutex*)
	  curr)
	(let ((req (nn-socket 'req)))
	  (nn-connect req host-port) ;; "inproc://test")
	  (hash-table-set! *clients* host-port req)
	  (mutex-unlock! *client-mutex*)
	  req))))

;; open up a channel to the server and send a package of info for the server to act on
;; host-port needs to be found and provided
;;
(define (generic-db-access host-port)
  (let* ((soc (request-connect host-port))
	 ;; NEED *MY* host/port also to let the server know where to send the results
	 )))
    

(define (client-send-receive soc msg)
  (nn-send soc msg)
  (nn-recv soc))
  
;;======================================================================
;; Server
;;======================================================================

(defstruct srvdat
  host
  port
  soc)

;; remember, everyone starts a server, both client and the actual server alike.
;; clients start a server for the server to return results to.
;;
(define (start-raw-server #!key (given-host-name #f))
  (let ((srvdat    (let loop ((portnum 10000))
		     (handle-exceptions
			 exn
			 (if (< portnum 64000)
			     (loop (+ portnum 1))
			     #f)
		       (let* ((rep (nn-socket 'rep)))
			 (nn-bind rep (conc "tcp://*:" portnum)) ;; "inproc://test")
			 (make-srvdat port: portnum soc: rep)))))
	(host-name (or give-host-name (get-host-name)))
	(soc       (srvdat-soc srvdat)))
    (srvdat-host-set! srvdat host-name)
    srvdat))

;; The actual *server* side server
;;
(define (start-server dbconn #!key (given-host-name #f))
  (let* ((srvdat    (start-raw-server given-host-name: given-host-name))
	 (host-name (srvdat-host srvdat))
	 (soc       (srvdat-soc srvdat)))
    
    ;; start the queue processor
    (thread-start! (queue-processory dbconn) "Queue processor")
    ;; msg is an alist
    ;;  'r host:port  <== where to return the data
    ;;  'p params     <== data to apply the command to
    ;;  'e j|s|l      <== encoding of the params. default is s (sexp), if not specified is assumed to be default
    ;;  'c command    <== look up the function to call using this key
    ;;
    (let loop ((msg-in (nn-recv soc)))
      (if (not (equal? msg-in "quit"))
	  (let* ((dat        (decode msg-in))
		 (host-port  (alist-ref 'r dat)) ;; this is for the reverse req rep where the server is a client of the original client
		 (params     (alist-ref 'p dat))
		 (command    (let ((c (alist-ref 'c dat)))(if c (string->symbol c) #f)))
		 (all-good   (and host-port params command (hash-table-exists? *commands* command))))
	    (if all-good
		(let ((cmddat (make-qitem
			       command:   command
			       host-port: host-port
			       params:    params)))
		  (queue-push cmddat) 		;; put request into the queue
		  (nn-send soc "queued"))         ;; reply with "queued"
		(print "ERROR: BAD request " dat))
	    (loop (nn-recv soc)))))
    (nn-close soc)))
  
;;======================================================================
;; Gasket layer
;;======================================================================

(define rmt:open-create-db open-create-db)
(define (rmt:create-run . params)
  
  

Added minimt/setup.scm version [db4ef679a3].



































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
(define *remotehost* "orion")
(define *homehost*   "zeus")
(define *homepath*   "/nfs/phoebe/disk1/home/mfs_matt/data/megatest/minimt/runtest")
(define *numsteps*   20)
(define *numtests*   20)
(define *numruns*    5)
(define *targets*    '("targ1"))
(define *testdelay*  0)
(define *rundelay*   0)
(define *launchdelay* 0)
(define *stepdelay*   0)

(use trace)
(trace-call-sites #t)
(trace
;;  open-create-db
 )

Modified mlaunch.scm from [4f4e7034c8] to [dc94b7feb1].

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








|
<





13
14
15
16
17
18
19
20

21
22
23
24
25
;; 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 format)


(declare (unit mlaunch))
(declare (uses db))
(declare (uses common))

Modified mt-pg.sql from [538f0610d2] to [c919648701].

59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
       owner      TEXT DEFAULT '',
       event_time INTEGER DEFAULT extract(epoch from now()),
       comment    TEXT DEFAULT '',
       fail_count INTEGER DEFAULT 0,
       pass_count INTEGER DEFAULT 0,
       last_update INTEGER DEFAULT extract(epoch from now()),
       area_id     INTEGER DEFAULT 0,
       CONSTRAINT runsconstraint UNIQUE (target,ttype_id,run_name));

CREATE TABLE IF NOT EXISTS run_stats (
       id     SERIAL PRIMARY KEY,
       run_id INTEGER,
       state  TEXT,
       status TEXT,
       count  INTEGER,







|







59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
       owner      TEXT DEFAULT '',
       event_time INTEGER DEFAULT extract(epoch from now()),
       comment    TEXT DEFAULT '',
       fail_count INTEGER DEFAULT 0,
       pass_count INTEGER DEFAULT 0,
       last_update INTEGER DEFAULT extract(epoch from now()),
       area_id     INTEGER DEFAULT 0,
       CONSTRAINT runsconstraint UNIQUE (target,ttype_id,run_name, area_id));

CREATE TABLE IF NOT EXISTS run_stats (
       id     SERIAL PRIMARY KEY,
       run_id INTEGER,
       state  TEXT,
       status TEXT,
       count  INTEGER,
206
207
208
209
210
211
212


















213
214
215
216
       test_id      INTEGER,
       state        TEXT DEFAULT 'new',
       status       TEXT DEFAULT 'n/a',
       archive_type TEXT DEFAULT 'bup',
       du           INTEGER,
       archive_path TEXT);
 



















-- TRUNCATE archive_blocks, archive_allocations, extradat, metadat,
-- access_log, tests, test_steps, test_data, test_rundat, archives, runs,
-- run_stats, test_meta, tasks_queue, archive_disks;







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




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
       test_id      INTEGER,
       state        TEXT DEFAULT 'new',
       status       TEXT DEFAULT 'n/a',
       archive_type TEXT DEFAULT 'bup',
       du           INTEGER,
       archive_path TEXT);
 
CREATE TABLE IF NOT EXISTS users(
   id SERIAL  PRIMARY KEY   ,
   usename           TEXT    NOT NULL,
   fullname          TEXT    NOT NULL, 
   email             TEXT    NOT NULL, 
   deleted           INTEGER     default 0
);
 
CREATE TABLE IF NOT EXISTS webviews(
   id SERIAL  PRIMARY KEY   ,
   owner_id          INTEGER NOT NULL,
   name              TEXT    NOT NULL, 
   ttype_id          INTEGER DEFAULT 0,
   view_specifics    TEXT   ,
   col               TEXT    NOT NULL,
   row               TEXT    NOT NULL,
   deleted           INTEGER     default 0
);

-- TRUNCATE archive_blocks, archive_allocations, extradat, metadat,
-- access_log, tests, test_steps, test_data, test_rundat, archives, runs,
-- run_stats, test_meta, tasks_queue, archive_disks;

Modified mtut.scm from [1a4e185888] to [57ec5ff542].

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
;; Copyright 2006-2017, 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")

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

(use srfi-1 posix srfi-69 readline ;;  regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras)
     srfi-18 extras format pkts pkts regex regex-case
     (prefix dbi dbi:)
     (prefix nanomsg nmsg:))

(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))
(declare (uses configf))
;; (declare (uses rmt))

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

(require-library stml)



(define *target-mappers*  (make-hash-table)) ;; '())
(define *runname-mappers* (make-hash-table)) ;; '())












































;; this needs some thought regarding security implications.
;;
;;   i. Check that owner of the file and calling user are same?
;;  ii. Check that we are in a legal megatest area?
;; iii. Have some form of authentication or record of the md5sum or similar of the file?
;;  iv. Use compiled version in preference to .scm version. Thus there is a manual "blessing"
;;      required to use .mtutil.scm.
;;
(if (common:file-exists? "megatest.config")
    (if (common:file-exists? ".mtutil.so")
	(load ".mtutil.so")
	(if (common:file-exists? ".mtutil.scm")
	(load ".mtutil.scm"))))

;; Disabled help items
;;  -rollup                 : (currently disabled) fill run (set by :runname)  with latest test(s)
;;                            from prior runs with same keys
;; Contour actions
;;    import                  : import pkts
;;    dispatch                : dispatch queued run jobs from imported pkts
;;    rungen                  : look at input sense list in [rungen] and generate run pkts

(define help (conc "
mtutil, part of the Megatest tool suite, documentation at http://www.kiatoa.com/fossils/megatest
  version " megatest-version "
  license GPL, Copyright Matt Welland 2006-2017

Usage: mtutil action [options]
  -h                       : this help
  -manual                  : show the Megatest user manual
  -version                 : print megatest version (currently " megatest-version ")

Actions:
   run                     : initiate runs
   remove                  : remove runs
   rerun                   : register action for processing
   set-ss                  : set state/status
   archive                 : compress and move test data to archive disk
   kill                    : stop tests or entire runs
   db                      : database utilities


Contour actions:
   process                 : runs import, rungen and dispatch 





Selectors 
  -immediate               : apply this action immediately, default is to queue up actions
  -area areapatt1,area2... : apply this action only to the specified areas
  -target key1/key2/...    : run for key1, key2, etc.
  -test-patt p1/p2,p3/...  : % is wildcard
  -run-name                : required, name for this particular test run
  -contour contourname     : run all targets for contourname, requires -run-name, -target
  -state-status c/p,c/f    : Specify a list of state and status patterns
  -tag-expr tag1,tag2%,..  : select tests with tags matching expression
  -mode-patt key           : load testpatt from <key> in runconfigs instead of default TESTPATT
                             if -testpatt and -tagexpr are not specified
  -new state/status        : specify new state/status for set-ss

Misc 
  -start-dir path          : switch to this directory before running mtutil
  -set-vars V1=1,V2=2      : Add environment variables to a run NB// these are
                                 overwritten by values set in config files.
  -log logfile             : send stdout and stderr to logfile
  -repl                    : start a repl (useful for extending megatest)
  -load file.scm           : load and run file.scm
  -debug N|N,M,O...        : enable debug messages 0-N or N and M and O ...

Utility
 db pgschema               : emit postgresql schema; do \"mtutil db pgschema | psql -d mydb\"

Examples:

# Start a megatest run in the area \"mytests\"
mtutil run -area mytests -target v1.63/aa3e -mode-patt MYPATT -tag-expr quick

# Start a contour
mtutil run -contour quick -target v1.63/aa3e 

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

;; args and pkt key specs
;;
(define *arg-keys*
  ;; used keys
  ;;    a  - action

  '(("-area"          . G) ;; maps to group
    ("-target"        . t)
    ("-run-name"      . n)
    ("-state"         . e)

    ("-status"        . s)

    ("-contour"       . c)

    ("-test-patt"     . p)  ;; idea, enhance margs ("-test-patt" "-testpatt") => yields one value in "-test-patt"
    ("-mode-patt"     . o)

    ("-tag-expr"      . x)
    ("-item-patt"     . i)
    ("-sync-to"       . k)
    ("-append-config" . d)
    ;; misc


    ("-start-dir"     . S)
    ("-msg"           . M)

    ("-set-vars"      . v)
    ("-debug"         . #f)  ;; for *verbosity* > 2
    ("-load"          . #f)  ;; load and exectute a scheme file
    ("-log"           . #f)
    ))
(define *switch-keys*

  '(("-h"             . #f)
    ("-help"          . #f)
    ("--help"         . #f)
    ("-manual"        . #f)
    ("-version"       . #f)
    ;; misc	      
    ("-repl"          . #f)
    ("-immediate"     . I)
    ("-preclean"      . r)
    ("-rerun-all"     . u)

    ))

;; alist to map actions to old megatest commands
(define *action-keys*
  '((run         . "-run")
    (sync        . "")
    (archive     . "-archive")
    (set-ss      . "-set-state-status")
    (remove      . "-remove-runs")))
























;; inlst is an alternative input
;;
(define (lookup-param-by-key key #!key (inlst #f))
  (fold (lambda (a res)
	  (if (eq? (cdr a) key)
	      (car a)
|















|

|











>
>
|
|
>

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












|















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


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

















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

>
>
|
|
>
|
<
<
|


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









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







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
; Copyright 2006-2017, 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")

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

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

(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))
(declare (uses configf))
;; (declare (uses rmt))

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

(require-library stml)

;; stuff for the mapper and checker functions
;;
(define *target-mappers*  (make-hash-table)) 
(define *runname-mappers* (make-hash-table)) 
(define *area-checkers*   (make-hash-table)) 

;; helpers for mappers/checkers
(define (add-target-mapper name proc)
  (hash-table-set! *target-mappers* name proc))
(define (add-runname-mapper name proc)
  (hash-table-set! *runname-mappers* name proc))
(define (add-area-checker name proc)
  (hash-table-set! *area-checkers* name proc))

;; given a runkey, xlatr-key and other info return one of the following:
;;   list of targets, null list to skip processing
;;   
(define (map-targets mtconf aval-alist runkey area contour #!key (xlatr-key-in #f))
  (let* ((xlatr-key (or xlatr-key-in
                        (conf-get/default mtconf aval-alist 'targtrans)))
         (proc      (hash-table-ref/default *target-mappers* xlatr-key #f)))
    (if proc
        (begin
          (print "Using target mapper: " xlatr-key)
          (handle-exceptions
           exn
           (begin
             (print "FAILED TO RUN TARGET MAPPER FOR " area ", called " xlatr-key)
             (print "   function is: " (hash-table-ref/default *target-mappers* xlatr-key #f ) )
             (print " message: " ((condition-property-accessor 'exn 'message) exn))
             runkey)
           (proc runkey area contour)))
        (begin
          (if xlatr-key 
              (print "ERROR: Failed to find named target translator " xlatr-key ", using original target."))
          `(,runkey))))) ;; no proc then use runkey

;; given mtconf and areaconf extract a translator/filter, first look at areaconf
;; then if not found look at default
;;
(define (conf-get/default mtconf areaconf keyname #!key (default #f))
  (let ((res (or (alist-ref keyname areaconf)
                 (configf:lookup mtconf "default" (conc keyname))
                 default)))
    (if res
        (string->symbol res)
        res)))
  
;; this needs some thought regarding security implications.
;;
;;   i. Check that owner of the file and calling user are same?
;;  ii. Check that we are in a legal megatest area?
;; iii. Have some form of authentication or record of the md5sum or similar of the file?
;;  iv. Use compiled version in preference to .scm version. Thus there is a manual "blessing"
;;      required to use .mtutil.scm.
;;
(if (common:file-exists? "megatest.config")
    (if (common:file-exists? ".mtutil.so")
	(load ".mtutil.so")
	(if (common:file-exists? ".mtutil.scm")
            (load ".mtutil.scm"))))

;; Disabled help items
;;  -rollup                 : (currently disabled) fill run (set by :runname)  with latest test(s)
;;                            from prior runs with same keys
;; Contour actions
;;    import                  : import pkts
;;    dispatch                : dispatch queued run jobs from imported pkts
;;    rungen                  : look at input sense list in [rungen] and generate run pkts

(define help (conc "
mtutil, part of the Megatest tool suite, documentation at http://www.kiatoa.com/fossils/megatest
  version " megatest-version "
  license GPL, Copyright Matt Welland 2006-2017

Usage: mtutil action [options]
  -h                         : this help
  -manual                    : show the Megatest user manual
  -version                   : print megatest version (currently " megatest-version ")
			     
Actions:		     
   run                       : initiate runs
   remove                    : remove runs
   rerun                     : register action for processing
   set-ss                    : set state/status
   archive                   : compress and move test data to archive disk
   kill                      : stop tests or entire runs
   db                        : database utilities
   areas, contours, setup    : show areas, contours or setup section from megatest.config

Contour actions:
   process                   : runs import, rungen and dispatch 
			     
Trigger propagation actions:
   tsend a=b,c=d...          : send trigger info to all recpients in the [listeners] section
   tlisten -port N           : listen for trigger info on port N
			     
Selectors 		     
  -immediate                 : apply this action immediately, default is to queue up actions
  -area areapatt1,area2...   : apply this action only to the specified areas
  -target key1/key2/...      : run for key1, key2, etc.
  -test-patt p1/p2,p3/...    : % is wildcard
  -run-name                  : required, name for this particular test run
  -contour contourname       : run all targets for contourname, requires -run-name, -target
  -state-status c/p,c/f      : Specify a list of state and status patterns
  -tag-expr tag1,tag2%,..    : select tests with tags matching expression
  -mode-patt key             : load testpatt from <key> in runconfigs instead of default TESTPATT
                               if -testpatt and -tagexpr are not specified
  -new state/status          : specify new state/status for set-ss
			     
Misc 			     
  -start-dir path            : switch to this directory before running mtutil
  -set-vars V1=1,V2=2        : Add environment variables to a run NB// these are
                                   overwritten by values set in config files.
  -log logfile               : send stdout and stderr to logfile
  -repl                      : start a repl (useful for extending megatest)
  -load file.scm             : load and run file.scm
  -debug N|N,M,O...          : enable debug messages 0-N or N and M and O ...
			     
Utility			     
 db pgschema                 : emit postgresql schema; do \"mtutil db pgschema | psql -d mydb\"

Examples:

# Start a megatest run in the area \"mytests\"
mtutil run -area mytests -target v1.63/aa3e -mode-patt MYPATT -tag-expr quick

# Start a contour
mtutil run -contour quick -target v1.63/aa3e 

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

;; args and pkt key specs
;;
(define *arg-keys*
  ;; used keys
  ;;    a  - action
  '(
    ("-area"            . G) ;; maps to group
    ("-contour"         . c)
    ("-append-config"   . d)
    ("-state"           . e)
    ("-item-patt"       . i)
    ("-sync-to"         . k)
    ("-new"             . l) ;; l (see below) is new-ss
    ("-run-name"        . n)
    ("-mode-patt"       . o)
    ("-test-patt"       . p)  ;; idea, enhance margs ("-test-patt" "-testpatt") => yields one value in "-test-patt"
    ("-status"          . s)
    ("-target"          . t)
    ("-tag-expr"        . x)



    ;; misc
    ("-debug"           . #f)  ;; for *verbosity* > 2
    ("-load"            . #f)  ;; load and exectute a scheme file
    ("-log"             . #f)
    ("-msg"             . M)
    ("-start-dir"       . S)
    ("-set-vars"        . v)


    ("-config"          . r)
    ))
(define *switch-keys*
  '(
    ("-h"               . #f)
    ("-help"            . #f)
    ("--help"           . #f)
    ("-manual"          . #f)
    ("-version"         . #f)
    ;; misc	        
    ("-repl"            . #f)
    ("-immediate"       . I)
    ("-preclean"        . r)
    ("-rerun-all"       . u)
    ("-prepend-contour" . w)
    ))

;; alist to map actions to old megatest commands
(define *action-keys*
  '((run         . "-run")
    (sync        . "")
    (archive     . "-archive")
    (set-ss      . "-set-state-status")
    (remove      . "-remove-runs")))

;; Card types:
;;
;; A action
;; U username (Unix)
;; D timestamp
;; T card type

;; utilitarian alist for standard cards
;;
(define *additional-cards*
  '(
    ;; Standard Cards
    (A  . action    )
    (D  . timestamp )
    (T  . cardtype  )
    (U  . user      ) ;; username
    (Z  . shar1sum  )

    ;; Extras
    (a  . runkey    ) ;; needed for matching up pkts with target derived from runkey
    ;; (l  . new-ss    ) ;; new state/status
    ))

;; inlst is an alternative input
;;
(define (lookup-param-by-key key #!key (inlst #f))
  (fold (lambda (a res)
	  (if (eq? (cdr a) key)
	      (car a)
178
179
180
181
182
183
184
185

186
187
188
189
190
191
192
;;
(define (param-translate param)
  (or (alist-ref (string->symbol param)
		 '((-tag-expr  . "-tagexpr")
		   (-mode-patt . "--modepatt")
		   (-run-name  . "-runname")
		   (-test-patt . "-testpatt")
		   (-msg       . "-m")))

      param))

(define (val->alist val)
  (let ((val-list (string-split-fields ";\\s*" val #:infix)))
    (if val-list
	(map (lambda (x)
	       (let ((f (string-split-fields "\\s*=\\s*" x #:infix)))







|
>







256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
;;
(define (param-translate param)
  (or (alist-ref (string->symbol param)
		 '((-tag-expr  . "-tagexpr")
		   (-mode-patt . "--modepatt")
		   (-run-name  . "-runname")
		   (-test-patt . "-testpatt")
		   (-msg       . "-m")
		   (-new       . "-set-state-status")))
      param))

(define (val->alist val)
  (let ((val-list (string-split-fields ";\\s*" val #:infix)))
    (if val-list
	(map (lambda (x)
	       (let ((f (string-split-fields "\\s*=\\s*" x #:infix)))
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
	  (else ;; have some unrecognised junk? spit out error message
	   (print "ERROR: fossil timeline returned unrecognisable junk \"" inl "\"")
	   (loop (get-line) date node time))))
       (else ;; no more datat and last node on branch not found
	(close-input-port timeline-port)
	(values  (common:date-time->seconds (conc date " " time)) node))))))


;;======================================================================
;; GLOBALS
;;======================================================================

;; Card types:
;;
;; a action
;; u username (Unix)
;; D timestamp
;; T card type

;; process args
(define *action* (if (> (length (argv)) 1)
		     (cadr (argv))
		     #f))
(define remargs (args:get-args 
		 (if *action* (cdr (argv)) (argv)) ;; args:get-args dumps first in argv list (the program name)
		 (map car *arg-keys*)







<




<
<
<
<
<
<
<







337
338
339
340
341
342
343

344
345
346
347







348
349
350
351
352
353
354
	  (else ;; have some unrecognised junk? spit out error message
	   (print "ERROR: fossil timeline returned unrecognisable junk \"" inl "\"")
	   (loop (get-line) date node time))))
       (else ;; no more datat and last node on branch not found
	(close-input-port timeline-port)
	(values  (common:date-time->seconds (conc date " " time)) node))))))


;;======================================================================
;; GLOBALS
;;======================================================================








;; process args
(define *action* (if (> (length (argv)) 1)
		     (cadr (argv))
		     #f))
(define remargs (args:get-args 
		 (if *action* (cdr (argv)) (argv)) ;; args:get-args dumps first in argv list (the program name)
		 (map car *arg-keys*)
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
;; Add args that use remargs here
;;
(if (and (not (null? remargs))
	 (not (or
	       (args:get-arg "-runstep")
	       (args:get-arg "-envcap")
	       (args:get-arg "-envdelta")
	       (member *action* '("db"))   ;; very loose checks on db.

	       )))
    (debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv))  " ")))

(if (or (args:any? "-h" "help" "-help" "--help")
	(member *action* '("-h" "-help" "--help" "help")))
    (begin
      (print help)
      (exit 1)))

;;======================================================================
;; pkts
;;======================================================================

(define (with-queue-db mtconf proc)
  (let* ((pktsdirs (configf:lookup mtconf "setup"  "pktsdirs"))
	 (pktsdir  (if pktsdirs (car (string-split pktsdirs " ")) #f))
	 (toppath  (configf:lookup mtconf "dyndat" "toppath"))
	 (pdbpath  (or (configf:lookup mtconf "setup"  "pdbpath") pktsdir)))
    (cond
     ((not (and  pktsdir toppath pdbpath))
      (debug:print 0 *default-log-port* "ERROR: settings are missing in your megatest.config for area management.")
      (debug:print  0 *default-log-port* "  you need to have pktsdir in the [setup] section."))
     ((not (common:file-exists? pktsdir))
      (debug:print 0 *default-log-port* "ERROR: pkts directory not found " pktsdir))
     ((not (equal? (file-owner pktsdir)(current-effective-user-id)))
      (debug:print 0 *default-log-port* "ERROR: directory " pktsdir " is not owned by " (current-effective-user-name)))
     (else
      (let* ((pdb  (open-queue-db pdbpath "pkts.db"
				  schema: '("CREATE TABLE groups (id INTEGER PRIMARY KEY,groupname TEXT, CONSTRAINT group_constraint UNIQUE (groupname));"))))
	(proc pktsdirs pktsdir pdb)
	(dbi:close pdb))))))

(define (load-pkts-to-db mtconf)
  (with-queue-db
   mtconf
   (lambda (pktsdirs pktsdir pdb)
     (for-each
      (lambda (pktsdir) ;; look at all

	(cond



	 ((not (common:file-exists? pktsdir))



	  (debug:print 0 *default-log-port* "ERROR: packets directory " pktsdir " does not exist."))


	 ((not (directory? pktsdir))
	  (debug:print 0 *default-log-port* "ERROR: packets directory path " pktsdir " is not a directory."))






	 ((not (file-read-access? pktsdir))
	  (debug:print 0 *default-log-port* "ERROR: packets directory path " pktsdir " is not readable."))
	 (else
	  (let ((pkts (glob (conc pktsdir "/*.pkt"))))
	    (for-each
	     (lambda (pkt)
	       (let* ((uuid    (cadr (string-match ".*/([0-9a-f]+).pkt" pkt)))





		      (exists  (lookup-by-uuid pdb uuid #f)))

		 (if (not exists)






		     (let* ((pktdat (string-intersperse
				     (with-input-from-file pkt read-lines)
				     "\n"))
			    (apkt   (pkt->alist pktdat))
			    (ptype  (alist-ref 'T apkt)))
		       (add-to-queue pdb pktdat uuid (or ptype 'cmd) #f 0)
		       (debug:print 4 *default-log-port* "Added " uuid " of type " ptype " to queue"))
		     (debug:print 4 *default-log-port* "pkt: " uuid " exists, skipping...")


		     )))
	     pkts)))))
      (string-split pktsdirs)))))

(define (get-pkt-alists pkts)
  (map (lambda (x)
	 (alist-ref 'apkt x)) ;; 'pkta pulls out the alist from the read pkt
       pkts))

;; given list of pkts (alist mode) return list of D cards as Unix epoch, sorted descending
;; also delete duplicates by target i.e. (car pkt)

(define (get-pkt-times pkts)
  (delete-duplicates
   (sort 
    (map (lambda (x)
	   `(,(alist-ref 't x) . ,(string->number (alist-ref 'D x))))


	 pkts)
    (lambda (a b)(> (cdr a)(cdr b))))      ;; sort descending
   (lambda (a b)(equal? (car a)(car b))))) ;; remove duplicates by target

;;======================================================================
;; Runs
;;======================================================================

;; make a runname
;;
(define (make-runname pre post)
 (time->string
  (seconds->local-time (current-seconds)) "%Yw%V.%w-%H%M"))

;; collect, translate, collate and assemble a pkt from the command-line
;;
;; sched => force the run start time to be recorded as sched Unix
;; epoch. This aligns times properly for triggers in some cases.
;;
;;  extra-dat format is ( 'x xval 'y yval .... )
;;
(define (command-line->pkt action args-alist sched-in #!key (extra-dat '())(area-path #f))
  (let* ((sched     (cond
		     ((vector? sched-in)(local-time->seconds sched-in)) ;; we recieved a time
		     ((number? sched-in) sched-in)
		     (else     (current-seconds))))
	 (args-data (if args-alist
			(if (hash-table? args-alist) ;; seriously?
			    (hash-table->alist args-alist)
			    args-alist)
			(hash-table->alist args:arg-hash))) ;; if no args-alist then we assume this is a call driven directly by commandline
	 (alldat    (apply append
			   (list 'T "cmd"
				 'a action
				 'U (current-user-name)
				 'D sched)
			   (if area-path
			       (list 'S area-path) ;; the area-path is mapped to the start-dir
			       '())
                           (if (list? extra-dat)
			       extra-dat







|
>










|


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

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


















|










<
|







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
;; Add args that use remargs here
;;
(if (and (not (null? remargs))
	 (not (or
	       (args:get-arg "-runstep")
	       (args:get-arg "-envcap")
	       (args:get-arg "-envdelta")
	       (member *action* '("db" "tsend" "tlisten"))   ;; very loose checks on db and tsend/listen
	       (equal? *action* "show")    ;; just keep going if list
	       )))
    (debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv))  " ")))

(if (or (args:any? "-h" "help" "-help" "--help")
	(member *action* '("-h" "-help" "--help" "help")))
    (begin
      (print help)
      (exit 1)))

;;======================================================================
;; Nanomsg transport
;;======================================================================

(define-inline (encode data)

  (with-output-to-string


    (lambda ()











      (write data))))

(define-inline (decode data)
  (with-input-from-string
      data
    (lambda ()
      (read))))

(define (is-port-in-use port-num)
 (let* ((ret #f))
     (let-values (((inp oup pid)
                (process "netstat" (list  "-tulpn" ))))
      (let loop ((inl (read-line inp)))
        (if (not (eof-object? inl))
            (begin 
                (if (string-search (regexp (conc ":" port-num)) inl)
                 (begin
                 ;(print "Output: "  inl)
                  (set! ret  #t))
                 (loop (read-line inp)))))))
ret))

;;start a server, returns the connection
;;
(define (start-nn-server portnum )
  (let ((rep (nn-socket 'rep)))
    (handle-exceptions
     exn
     (let ((emsg ((condition-property-accessor 'exn 'message) exn)))
       (print "ERROR: Failed to start server \"" emsg "\"")
       (exit 1))
      
     (nn-bind rep (conc "tcp://*:" portnum)))
    rep))

;; open connection to server, send message, close connection
;;
(define (open-send-close-nn host-port msg #!key (timeout 3)) ;; default timeout is 3 seconds
  (let ((req  (nn-socket 'req))
        (uri  (conc "tcp://" host-port))
        (res  #f)) 
    (handle-exceptions
     exn
     (let ((emsg ((condition-property-accessor 'exn 'message) exn)))
       (print "ERROR: Failed to connect/send to " uri " message was \"" emsg "\"")
       #f)
     (nn-connect req uri)
     (nn-send req msg)
     ;; NEED timer here!
     (let* ((th1  (make-thread (lambda ()

                                 (let ((resp (nn-recv req)))

                                   (nn-close req)



                                   (set! res (if (equal? resp "ok")
                                                 #t
                                                 #f))))


                               "recv thread"))

            (th2 (make-thread (lambda ()


                                (thread-sleep! timeout)


                                (thread-terminate! th1))
                             "timer thread")))

       (thread-start! th1)


       (thread-start! th2)
       (thread-join! th1)
       res))))



;;======================================================================
;; Runs
;;======================================================================

;; make a runname
;;
(define (make-runname pre post)
 (time->string
  (seconds->local-time (current-seconds)) "%Yw%V.%w-%H%M"))

;; collect, translate, collate and assemble a pkt from the command-line
;;
;; sched => force the run start time to be recorded as sched Unix
;; epoch. This aligns times properly for triggers in some cases.
;;
;;  extra-dat format is ( 'x xval 'y yval .... )
;;
(define (command-line->pkt action args-alist sched-in #!key (extra-dat '())(area-path #f)(new-ss #f))
  (let* ((sched     (cond
		     ((vector? sched-in)(local-time->seconds sched-in)) ;; we recieved a time
		     ((number? sched-in) sched-in)
		     (else     (current-seconds))))
	 (args-data (if args-alist
			(if (hash-table? args-alist) ;; seriously?
			    (hash-table->alist args-alist)
			    args-alist)
			(hash-table->alist args:arg-hash))) ;; if no args-alist then we assume this is a call driven directly by commandline
	 (alldat    (apply append

			   (list 'A action
				 'U (current-user-name)
				 'D sched)
			   (if area-path
			       (list 'S area-path) ;; the area-path is mapped to the start-dir
			       '())
                           (if (list? extra-dat)
			       extra-dat
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
					 (meta  (if (or pmeta smeta)
						    (cdr (or pmeta smeta))   ;; found it?
						    #f)))
				    (if (or pmeta smeta)                     ;; construct the switch/param pair.
					(list meta value)
					'())))
				(filter cdr args-data)))))
;; (print  "Alldat: " alldat
;;         " args-data: " args-data)
    (add-z-card
     (apply construct-sdat alldat))))

;; merge/consolidate with common:simple-setup
(define (simple-setup start-dir-in)
  (let* ((start-dir (or start-dir-in "."))
	 (mtconfig  (or (args:get-arg "-config") "megatest.config"))
	 (mtconfdat (find-and-read-config        ;; NB// sets MT_RUN_AREA_HOME as side effect -> NOPE! Not if pathenvvar is #f
		     mtconfig
		     ;; environ-patt: "env-override"
		     given-toppath: start-dir
		     ;; pathenvvar: "MT_RUN_AREA_HOME"
		     ))
	 (mtconf    (if mtconfdat (car mtconfdat) #f)))
    ;; we set some dynamic data in a section called "dyndata"
    (if mtconf
	(begin
	  (configf:section-var-set! mtconf "dyndat" "toppath" start-dir)))
    ;; (print "TOPPATH: " (configf:lookup mtconf "dyndat" "toppath"))
    mtconfdat))


;; NEED TIMESTAMP ON PKTS for efficient loading of packets into db.


;; make a run request pkt from basic data, this seriously needs to be refactored
;;   i. Take the code that builds the info to submit to create-run-pkt and have it
;;      generate the pkt keys directly.
;;  ii. Pass the pkt keys and values to this proc and go from there.
;; iii. Maybe have an abstraction alist with meaningful names for the pkt keys
;;
;; Override the run start time record with sched. Usually #f is fine.
;; 
(define (create-run-pkt mtconf action area runkey runname mode-patt tag-expr pktsdir reason contour sched dbdest append-conf runtrans)


  (let* ((good-val   (lambda (inval)(and inval (string? inval)(not (string-null? inval)))))
	 (area-dat   (val->alist (or (configf:lookup mtconf "areas" area) "")))
	 (area-path  (alist-ref 'path      area-dat))
	 (area-xlatr (alist-ref 'targtrans area-dat))

	 (new-runname (let* ((callname (if (string? runtrans)(string->symbol runtrans) #f))
			     (mapper   (if callname (hash-table-ref/default *runname-mappers* callname #f) #f)))
			;; (print "callname=" callname " runtrans=" runtrans " mapper=" mapper)
			(if (and callname
				 (not (equal? callname "auto"))
				 (not mapper))
			    (print "No mapper " callname " for area " area " using " callname " as the runname"))
			(if mapper
			    (handle-exceptions
				exn
				(begin
				  (print-call-chain)
				  (print "FAILED TO RUN RUNNAME MAPPER " callname " FOR AREA " area)
				  (print " message: " ((condition-property-accessor 'exn 'message) exn))
				  runname)
			      (print "(mapper " (string-intersperse (list runkey runname area area-path reason contour mode-patt) ", ") ")")
			      (mapper runkey runname area area-path reason contour mode-patt))
			    (case callname
			      ((auto) runname)
			      (else   runtrans)))))

	 (new-target (if area-xlatr 
			 (let ((xlatr-key (string->symbol area-xlatr)))
			   (if (hash-table-exists? *target-mappers* xlatr-key)
			       (begin
				 (print "Using target mapper: " area-xlatr)
				 (handle-exceptions
				     exn
				     (begin
				       (print "FAILED TO RUN TARGET MAPPER FOR " area ", called " area-xlatr)
				       (print "   function is: " (hash-table-ref/default *target-mappers* xlatr-key #f ) )
				       (print " message: " ((condition-property-accessor 'exn 'message) exn))
				       runkey)
				   ((hash-table-ref *target-mappers* xlatr-key)
				    runkey new-runname area area-path reason contour mode-patt)))
			       (begin
				 (print "ERROR: Failed to find named target translator " xlatr-key ", using original target.")
				 runkey)))
			 runkey)))
    ;; some hacks to remove switches not needed in certain cases
    (case (string->symbol (or action "run"))
      ((sync)
       (set! new-target #f)
       (set! runame     #f)))
    (print "area-path: " area-path " area-xlatr: " area-xlatr " orig-target: " runkey " new-target: " new-target)
    (let-values (((uuid pkt)
		  (command-line->pkt
		   (if action action "run")
		   (append 
		    `(("-start-dir"  . ,area-path)
		      ("-msg"        . ,reason)
		      ("-contour"    . ,contour))
		    (if (good-val new-runname) `(("-run-name"      . ,new-runname)) '())
		    (if (good-val new-target)  `(("-target"        . ,new-target))  '())
		    (if (good-val mode-patt)   `(("-mode-patt"     . ,mode-patt))   '())
		    (if (good-val tag-expr)    `(("-tag-expr"      . ,tag-expr))    '())
		    (if (good-val dbdest)      `(("-sync-to"       . ,dbdest))      '())
		    (if (good-val append-conf) `(("-append-config" . ,append-conf)) '())

		    (if (not (or mode-patt tag-expr))
			`(("-testpatt"  . "%"))
			'())
		    (if (or (not action)
			    (equal? action "run"))
			`(("-preclean"  . " ")
			  ("-rerun-all" . " "))      ;; if run we *always* want preclean set, use single space as placeholder
			'())
		    )
		   sched
                   extra-dat: `(y ,runkey)  ;; we need the run key for marking the run as launched
                   )))
      (with-output-to-file
	  (conc pktsdir "/" uuid ".pkt")
	(lambda ()
	  (print pkt))))))



(define (val-alist->areas val-alist)




  (string-split (or (alist-ref 'areas val-alist) "") ","))






(define (area-allowed? area areas)

  (or (not areas)
      (null? areas)




      (member area areas)))


;; (use trace)(trace create-run-pkt)

;; collect all needed data and create run pkts for contours with changed inputs
;;
(define (generate-run-pkts mtconf toppath)
  (let ((std-runname (conc "sched"  (time->string (seconds->local-time (current-seconds)) "%M%H%d"))))
    (with-queue-db
     mtconf
     (lambda (pktsdirs pktsdir pdb)
       (let* ((rgconfdat (find-and-read-config (conc toppath "/runconfigs.config")))
	      (rgconf    (car rgconfdat))
	      (all-areas (map car (configf:get-section mtconf "areas")))
	      (contours  (configf:get-section mtconf "contours"))
	      (torun     (make-hash-table)) ;; target => ( ... info ... )







|
|














|


|
|














|
>
>



|
>
|



















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


|


|


|










>










|






|
>

>
>
>
>
|

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







|







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
					 (meta  (if (or pmeta smeta)
						    (cdr (or pmeta smeta))   ;; found it?
						    #f)))
				    (if (or pmeta smeta)                     ;; construct the switch/param pair.
					(list meta value)
					'())))
				(filter cdr args-data)))))
    (print  "Alldat: " alldat
	    " args-data: " args-data)
    (add-z-card
     (apply construct-sdat alldat))))

;; merge/consolidate with common:simple-setup
(define (simple-setup start-dir-in)
  (let* ((start-dir (or start-dir-in "."))
	 (mtconfig  (or (args:get-arg "-config") "megatest.config"))
	 (mtconfdat (find-and-read-config        ;; NB// sets MT_RUN_AREA_HOME as side effect -> NOPE! Not if pathenvvar is #f
		     mtconfig
		     ;; environ-patt: "env-override"
		     given-toppath: start-dir
		     ;; pathenvvar: "MT_RUN_AREA_HOME"
		     ))
	 (mtconf    (if mtconfdat (car mtconfdat) #f)))
    ;; we set some dynamic data in a section called "scratchdata"
    (if mtconf
	(begin
	  (configf:section-var-set! mtconf "scratchdat" "toppath" start-dir)))
    ;; (print "TOPPATH: " (configf:lookup mtconf "scratchdat" "toppath"))
    mtconfdat))


;; NEED TIMESTAMP ON PKTS for efficient loading of packets into db.


;; make a run request pkt from basic data, this seriously needs to be refactored
;;   i. Take the code that builds the info to submit to create-run-pkt and have it
;;      generate the pkt keys directly.
;;  ii. Pass the pkt keys and values to this proc and go from there.
;; iii. Maybe have an abstraction alist with meaningful names for the pkt keys
;;
;; Override the run start time record with sched. Usually #f is fine.
;; 
(define (create-run-pkt mtconf action area runkey target runname mode-patt 
                        tag-expr pktsdir reason contour sched dbdest append-conf
                        runtrans)
  (let* ((good-val   (lambda (inval)(and inval (string? inval)(not (string-null? inval)))))
	 (area-dat   (val->alist (or (configf:lookup mtconf "areas" area) "")))
	 (area-path  (alist-ref 'path      area-dat))
	 ;; (area-xlatr (alist-ref 'targtrans area-dat))
         ;; (xlatr-key  (if area-xlatr (string->symbol area-xlatr) #f))
         (new-runname (let* ((callname (if (string? runtrans)(string->symbol runtrans) #f))
			     (mapper   (if callname (hash-table-ref/default *runname-mappers* callname #f) #f)))
			;; (print "callname=" callname " runtrans=" runtrans " mapper=" mapper)
			(if (and callname
				 (not (equal? callname "auto"))
				 (not mapper))
			    (print "No mapper " callname " for area " area " using " callname " as the runname"))
			(if mapper
			    (handle-exceptions
				exn
				(begin
				  (print-call-chain)
				  (print "FAILED TO RUN RUNNAME MAPPER " callname " FOR AREA " area)
				  (print " message: " ((condition-property-accessor 'exn 'message) exn))
				  runname)
			      (print "(mapper " (string-intersperse (list runkey runname area area-path reason contour mode-patt) ", ") ")")
			      (mapper runkey runname area area-path reason contour mode-patt))
			    (case callname
			      ((auto) runname)
			      (else   runtrans)))))
	 (new-target     target) ;; I believe we will want target manipulation here .. (map-targets xlatr-key runkey area contour))
	 (actual-action  (if action

			     (if (equal? action "sync-prepend")
				 "sync"

				 action)



			     "run"))) ;; this has gotten a bit ugly. Need a function to handle actions processing.








    ;; some hacks to remove switches not needed in certain cases
    (case (string->symbol (or action "run"))
      ((sync sync-prepend)
       (set! new-target #f)
       (set! runame     #f)))
    ;; (print "area-path: " area-path " orig-target: " runkey " new-target: " new-target)
    (let-values (((uuid pkt)
		  (command-line->pkt
		   actual-action
		   (append 
		    `(("-start-dir"  . ,area-path)
		      ("-msg"        . ,reason)
		      ("-contour"    . ,contour))
		    (if (good-val new-runname) `(("-run-name"      . ,new-runname)) '())
		    (if (good-val new-target)  `(("-target"        . ,new-target))  '())
		    (if (good-val mode-patt)   `(("-mode-patt"     . ,mode-patt))   '())
		    (if (good-val tag-expr)    `(("-tag-expr"      . ,tag-expr))    '())
		    (if (good-val dbdest)      `(("-sync-to"       . ,dbdest))      '())
		    (if (good-val append-conf) `(("-append-config" . ,append-conf)) '())
		    (if (equal? action "sync-prepend") '(("-prepend-contour" . " "))   '())
		    (if (not (or mode-patt tag-expr))
			`(("-testpatt"  . "%"))
			'())
		    (if (or (not action)
			    (equal? action "run"))
			`(("-preclean"  . " ")
			  ("-rerun-all" . " "))      ;; if run we *always* want preclean set, use single space as placeholder
			'())
		    )
		   sched
                   extra-dat: `(a ,runkey)  ;; we need the run key for marking the run as launched
                   )))
      (with-output-to-file
	  (conc pktsdir "/" uuid ".pkt")
	(lambda ()
	  (print pkt))))))

;; look for areas=a1,a2,a3 OR areafn=somefuncname
;;
(define (val-alist->areas val-alist)
  (let ((areas-string   (alist-ref 'areas  val-alist))
	(areas-procname (alist-ref 'areafn val-alist)))
    (if areas-procname ;; areas-procname take precedence
	areas-procname
	(string-split (or areas-string "") ","))))

;; area   - the current area under consideration
;; areas  - the list of allowed areas from the contour spec -OR-
;;          if it is a string then it is the function to use to
;;          lookup in *area-checkers*
;;
(define (area-allowed? area areas runkey contour mode-patt)
  (cond
   ((not areas) #t) ;; no spec
   ((string? areas) ;; 
    (let ((check-fn (hash-table-ref/default *area-checkers* (string->symbol areas) #f)))
      (if check-fn
	  (check-fn area runkey contour mode-patt)
	  #f)))
   ((list? areas)(member area areas))
   (else #f))) ;; shouldn't get here 

;; (use trace)(trace create-run-pkt)

;; collect all needed data and create run pkts for contours with changed inputs
;;
(define (generate-run-pkts mtconf toppath)
  (let ((std-runname (conc "sched"  (time->string (seconds->local-time (current-seconds)) "%M%H%d"))))
    (common:with-queue-db
     mtconf
     (lambda (pktsdirs pktsdir pdb)
       (let* ((rgconfdat (find-and-read-config (conc toppath "/runconfigs.config")))
	      (rgconf    (car rgconfdat))
	      (all-areas (map car (configf:get-section mtconf "areas")))
	      (contours  (configf:get-section mtconf "contours"))
	      (torun     (make-hash-table)) ;; target => ( ... info ... )
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
			(ruletype   (if (> len-key 1)(cadr keyparts) #f))
			(action     (if (> len-key 2)(caddr keyparts) #f))
			(optional   (if (> len-key 3)(cadddr keyparts) #f))
			;; (val-list   (string-split-fields ";\\s*" val #:infix)) ;; (string-split val)) ;; runname-rule params
			(val-alist  (val->alist val))
			(runname    (make-runname "" ""))
			(runtrans   (alist-ref 'runtrans val-alist))









			
			(runstarts  (find-pkts pdb '(runstart) `((o . ,contour)
								 (t . ,runkey))))
			(rspkts     (get-pkt-alists runstarts))
			;; starttimes is for run start times and is used to know when the last run was launched
			(starttimes (get-pkt-times rspkts)) ;; sort by age (youngest first) and delete duplicates by target
			(last-run (if (null? starttimes) ;; if '() then it has never been run, else get the max
				      0
				      (apply max (map cdr starttimes))))
			;; synctimes is for figuring out the last time a sync was done
			(syncstarts   (find-pkts pdb '(syncstart) '())) ;; no qualifiers, a sync does all tarets etc.
			(sspkts       (get-pkt-alists syncstarts))
			(synctimes    (get-pkt-times  sspkts))
			(last-sync (if (null? synctimes) ;; if '() then it has never been run, else get the max
				      0
				      (apply max (map cdr synctimes))))
			)

		   (let ((delta (lambda (x)
				  (round (/ (- (current-seconds) x) 60)))))
		     (print "runkey: " runkey ", ruletype: " ruletype ", action: " action ", last-run: " last-run " time since; last-run: " (delta last-run) ", last-sync: " (delta last-sync)))

		   (print "val-alist=" val-alist " runtrans=" runtrans)
		   
		   ;; look in runstarts for matching runs by target and contour
		   ;; get the timestamp for when that run started and pass it
		   ;; to the rule logic here where "ruletype" will be applied
		   ;; if it comes back "changed" then proceed to register the runs
		   
		   (case (string->symbol (or ruletype "no-such-rule"))

		     ((no-such-rule) (print "ERROR: no such rule for " sense))



		     ((scheduled)
		      (if (not (alist-ref 'cron val-alist)) ;; gotta have cron spec
			  (print "ERROR: bad sense spec \"" (string-intersperse sense " ") "\" params: " val-alist)
			  (let* ((run-name (alist-ref 'run-name val-alist))
				 (target   (alist-ref 'target   val-alist))
				 (crontab  (alist-ref 'cron     val-alist))
                                 (areas    (val-alist->areas val-alist))
				 ;; (action   (alist-ref 'action   val-alist))
				 (cron-safe-string (string-translate (string-intersperse (string-split (alist-ref 'cron val-alist)) "-") "*" "X"))
				 (runname  std-runname)) ;; (conc "sched" (time->string (seconds->local-time (current-seconds)) "%M%H%d")))))
			    ;; (print "last-run: " last-run " need-run: " need-run)
			    ;; (if need-run
			    (case (string->symbol action)
			      ((sync)
			       (if (common:extended-cron crontab #f last-sync)
				   (push-run-spec torun contour runkey
						  `((message . ,(conc ruletype ":sync-" cron-safe-string))
						    (action  . ,action)
						    (dbdest  . ,(alist-ref 'dbdest val-alist))
						    (append  . ,(alist-ref 'appendconf val-alist))))))

			      ((run)
			       (if (common:extended-cron crontab #f last-run)
				   (push-run-spec torun contour runkey
						  `((message . ,(conc ruletype ":" cron-safe-string))
						    (runname . ,runname)
						    (runtrans . ,runtrans)
						    (action  . ,action)

						    (target  . ,target)))))
                              ((remove)
                               (push-run-spec torun contour runkey
						  `((message . ,(conc ruletype ":" cron-safe-string))
						    (runname . ,runname)
						    (runtrans . ,runtrans)
						    (action  . ,action)

						    (target  . ,target))))
			      (else
			       (print "ERROR: action \"" action "\" has no scheduled handler")
			       )))))



		     ((script)
		      ;; syntax is a little different here. It is a list of commands to run, "scriptname = extra_parameters;scriptname = ..."
		      ;; where scriptname may be repeated multiple times. The script must return unix-epoch of last change, new-target-name and new-run-name
		      ;; the script is called like this:  scriptname contour runkey std-runname action extra_param1 extra_param2 ...
		      (for-each
		       (lambda (cmd)
			 (print "cmd: " cmd)







>
>
>
>
>
>
>
>
>



|

|
|
|
|

|
|
|
|
|
|

















>
>



|
<
<
<

|




|




|
|
>



|
|

|
>
|


|
|

|
>
|




>
>







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
			(ruletype   (if (> len-key 1)(cadr keyparts) #f))
			(action     (if (> len-key 2)(caddr keyparts) #f))
			(optional   (if (> len-key 3)(cadddr keyparts) #f))
			;; (val-list   (string-split-fields ";\\s*" val #:infix)) ;; (string-split val)) ;; runname-rule params
			(val-alist  (val->alist val))
			(runname    (make-runname "" ""))
			(runtrans   (alist-ref 'runtrans val-alist))

			;; these may or may not be defined and not all are used in each handler type in the case below
			(run-name   (alist-ref 'run-name val-alist))
			(target     (alist-ref 'target   val-alist))
			(crontab    (alist-ref 'cron     val-alist))
			(areas      (val-alist->areas    val-alist)) ;; areas can be a single string (a reference to call an areas function), or a list of area names.
			(dbdest     (alist-ref 'dbdest   val-alist))
			(appendconf (alist-ref 'appendconf val-alist))
			(file-globs (alist-ref 'glob val-alist))
			
			(runstarts  (find-pkts pdb '(runstart) `((o . ,contour)
								 (t . ,runkey))))
			(rspkts     (common:get-pkt-alists runstarts))
			;; starttimes is for run start times and is used to know when the last run was launched
			(starttimes (common:get-pkt-times rspkts)) ;; sort by age (youngest first) and delete duplicates by target
			(last-run   (if (null? starttimes) ;; if '() then it has never been run, else get the max
					0
					(apply max (map cdr starttimes))))
			;; synctimes is for figuring out the last time a sync was done
			(syncstarts (find-pkts pdb '(syncstart) '())) ;; no qualifiers, a sync does all tarets etc.
			(sspkts       (common:get-pkt-alists syncstarts))
			(synctimes    (common:get-pkt-times  sspkts))
			(last-sync  (if (null? synctimes) ;; if '() then it has never been run, else get the max
					0
					(apply max (map cdr synctimes))))
			)

		   (let ((delta (lambda (x)
				  (round (/ (- (current-seconds) x) 60)))))
		     (print "runkey: " runkey ", ruletype: " ruletype ", action: " action ", last-run: " last-run " time since; last-run: " (delta last-run) ", last-sync: " (delta last-sync)))

		   (print "val-alist=" val-alist " runtrans=" runtrans)
		   
		   ;; look in runstarts for matching runs by target and contour
		   ;; get the timestamp for when that run started and pass it
		   ;; to the rule logic here where "ruletype" will be applied
		   ;; if it comes back "changed" then proceed to register the runs
		   
		   (case (string->symbol (or ruletype "no-such-rule"))

		     ((no-such-rule) (print "ERROR: no such rule for " sense))

		     ;; Handle crontab like rules
		     ;;
		     ((scheduled)
		      (if (not (alist-ref 'cron val-alist)) ;; gotta have cron spec
			  (print "ERROR: bad sense spec \"" (string-intersperse sense " ") "\" params: " val-alist)
			  (let* (



				 ;; (action   (alist-ref 'action   val-alist))
				 (cron-safe-string (string-translate (string-intersperse (string-split crontab) "-") "*" "X"))
				 (runname  std-runname)) ;; (conc "sched" (time->string (seconds->local-time (current-seconds)) "%M%H%d")))))
			    ;; (print "last-run: " last-run " need-run: " need-run)
			    ;; (if need-run
			    (case (string->symbol action)
			      ((sync sync-prepend)
			       (if (common:extended-cron crontab #f last-sync)
				   (push-run-spec torun contour runkey
						  `((message . ,(conc ruletype ":sync-" cron-safe-string))
						    (action  . ,action)
						    (dbdest  . ,dbdest)
						    (append  . ,appendconf)
						    (areas   . ,areas)))))
			      ((run)
			       (if (common:extended-cron crontab #f last-run)
				   (push-run-spec torun contour runkey
						  `((message  . ,(conc ruletype ":" cron-safe-string))
						    (runname  . ,runname)
						    (runtrans . ,runtrans)
						    (action   . ,action)
						    (areas    . ,areas)
						    (target   . ,target)))))
                              ((remove)
                               (push-run-spec torun contour runkey
						  `((message  . ,(conc ruletype ":" cron-safe-string))
						    (runname  . ,runname)
						    (runtrans . ,runtrans)
						    (action   . ,action)
						    (areas    . ,areas)
						    (target   . ,target))))
			      (else
			       (print "ERROR: action \"" action "\" has no scheduled handler")
			       )))))

		     ;; script based sensors
		     ;;
		     ((script)
		      ;; syntax is a little different here. It is a list of commands to run, "scriptname = extra_parameters;scriptname = ..."
		      ;; where scriptname may be repeated multiple times. The script must return unix-epoch of last change, new-target-name and new-run-name
		      ;; the script is called like this:  scriptname contour runkey std-runname action extra_param1 extra_param2 ...
		      (for-each
		       (lambda (cmd)
			 (print "cmd: " cmd)
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
				      (need-run    (> last-change last-run)))
				 (print "last-run: " last-run " need-run: " need-run)
				 (if need-run
				     (let* ((key-msg    `((message  . ,(conc ruletype ":" message))
							  (runname  . ,runname)
							  (runtrans . ,runtrans)
							  (action   . ,action)

							  (target   . ,new-target))))

				       (print "key-msg: " key-msg)
				       (push-run-spec torun contour
						      (if optional  ;; we need to be able to differentiate same contour, different behavior. 
							  (conc runkey ":" optional)  ;; NOTE: NOT COMPLETELY IMPLEMENTED. DO NOT USE
							  runkey)
						      key-msg)))))))
		       val-alist)) ;; iterate over the param split by ;\s*



		     ((fossil)
		      (for-each
		       (lambda (fspec)
			 (print "fspec: " fspec)
			 (let* ((url         (symbol->string (car fspec))) ;; THIS COULD BE TROUBLE. Add option to reading line to return as string.
				(branch      (cdr fspec))
				(url-is-file (string-match "^(/|file:).*$" url))
				(fname       (conc (common:get-signature url) ".fossil"))
				(fdir        (conc "/tmp/" (current-user-name) "/mtutil_cache")))
			   ;; (if (not url-is-file) ;; need to sync first --- for now, clone 'em all.
			   (fossil:clone-or-sync url fname fdir) ;; )
			   (let-values (((datetime node)
					 (fossil:last-change-node-and-time fdir fname branch)))
			     (if (null? starttimes)
				 (push-run-spec torun contour runkey
						`((message . ,(conc "fossil:" branch "-neverrun"))
						  (runname . ,(conc runname "-" node))
						  (runtrans . ,runtrans)

						  (target  . ,runkey)))

				 (if (> datetime last-run) ;; change time is greater than last-run time
				     (push-run-spec torun contour runkey
						    `((message . ,(conc "fossil:" branch "-" node))
						      (runname . ,(conc runname "-" node))
						      (runtrans . ,runtrans)

						      (target  . ,runkey)))))

			     (print "Got datetime=" datetime " node=" node))))
		       val-alist))
		     


		     ((file file-or) ;; one or more files must be newer than the reference
		      (let* ((file-globs  (alist-ref 'glob val-alist))
                             (areas       (val-alist->areas val-alist))
			     (youngestdat (common:get-youngest (common:bash-glob file-globs)))
			     (youngestmod (car youngestdat)))
			;; (print "youngestmod: " youngestmod " starttimes: " starttimes)
			(if (null? starttimes) ;; this target has never been run
			    (push-run-spec torun contour runkey
					   `((message . "file:neverrun")
					     (action  . ,action)
					     (runtrans . ,runtrans)
					     (target  . ,runkey)

					     (runname . ,runname)))
			;; (for-each
			;;  (lambda (starttime) ;; look at the time the last run was kicked off for this contour
			;;    (if (> youngestmod (cdr starttime))
			;; 	   (begin
			;; 	     (print "starttime younger than youngestmod: " starttime " Youngestmod: " youngestmod)
			    (if (> youngestmod last-run)
				(push-run-spec torun contour runkey
					       `((message . ,(conc ruletype ":" (cadr youngestdat)))
						 (action  . ,action)
						 (target  . ,runkey)
						 (runtrans . ,runtrans)

						 (runname . ,runname)
						 ))))))
		      ;; starttimes))



		     ((file-and) ;; all files must be newer than the reference
		      (let* ((file-globs  (alist-ref 'glob val-alist))
			     (youngestdat (common:get-youngest file-globs))
			     (youngestmod (car youngestdat))
			     (success     #t)) ;; any cases of not true, set flag to #f for AND
			;; (print "youngestmod: " youngestmod " starttimes: " starttimes)
			(if (null? starttimes) ;; this target has never been run
			    (push-run-spec torun contour runkey
					   `((message . "file:neverrun")
					     (runname . ,runname)
					     (runtrans . ,runtrans)

					     (target  . ,runkey)
					     (action  . ,action)))
			    ;; NB// I think this is wrong. It should be looking at last-run only.
			    (if (> youngestmod last-run)
				
				;; 			    (for-each
				;; 			     (lambda (starttime) ;; look at the time the last run was kicked off for this contour
				;; 			       (if (< youngestmod (cdr starttime))
				;; 				   (set! success #f)))
				;; 			     starttimes))
				;; 			(if success
				;; 			    (begin
				;; 			      (print "starttime younger than youngestmod: " starttime " Youngestmod: " youngestmod)
				(push-run-spec torun contour runkey
					       `((message . ,(conc ruletype ":" (cadr youngestdat)))
						 (runname . ,runname)
						 (runtrans . ,runtrans)
						 (target  . ,runkey)

						 (action  . ,action)
						 ))))))
		     (else (print "ERROR: unrecognised rule \"" ruletype)))))
	       keydats))) ;; sense rules
	  (hash-table-keys rgconf))
	 
	 ;; now have to run populated
	 (for-each
	  (lambda (contour)
	    (print "contour: " contour)
	    (let* ((val       (or (configf:lookup mtconf "contours" contour) ""))
		   (val-alist (val->alist val))
		   (areas     (val-alist->areas val-alist))
		   (selector  (alist-ref 'selector val-alist))
		   (mode-tag  (and selector (string-split-fields "/" selector #:infix)))
		   (mode-patt (and mode-tag (if (eq? (length mode-tag) 2)(cadr mode-tag) #f)))
		   (tag-expr  (and mode-tag (if (null? mode-tag) #f (car mode-tag)))))

	      (for-each
	       (lambda (runkeydatset)
		 ;; (print "runkeydatset: ")(pp runkeydatset)
		 (let ((runkey     (car runkeydatset))
		       (runkeydats (cadr runkeydatset)))
		   (for-each
		    (lambda (runkeydat)
		      (for-each
		       (lambda (area)
                         (if (area-allowed? area areas) ;; is this area to be handled (from areas=a,b,c ...)


                             (let ((runname (alist-ref 'runname runkeydat))
                                   (runtrans (alist-ref 'runtrans runkeydat))

                                   (reason  (alist-ref 'message runkeydat))
                                   (sched   (alist-ref 'sched   runkeydat))
                                   (action  (alist-ref 'action  runkeydat))
                                   (dbdest  (alist-ref 'dbdest  runkeydat))
                                   (append  (alist-ref 'append  runkeydat))
                                   (target  (or (alist-ref 'target  runkeydat) runkey))) ;; override with target if forced




                               (print "Have: runkey=" runkey " contour=" contour " area=" area " action=" action " tag-expr=" tag-expr " mode-patt=" mode-patt " target=" target)
                               (if (case (or (and action (string->symbol action)) 'noaction)  ;; ensure we have the needed data to run this action
                                     ((noaction) #f)
                                     ((run)      (and runname reason))
                                     ((sync)     (and reason dbdest))
                                     (else       #f))
                                   ;; instead of unwrapping the runkeydat alist, pass it directly to create-run-pkt
                                   (create-run-pkt mtconf action area runkey runname mode-patt tag-expr pktsdir reason contour sched dbdest append runtrans) 


                                   (print "ERROR: Missing info to make a " action " call: runkey=" runkey " contour=" contour " area=" area  " tag-expr=" tag-expr " mode-patt=" mode-patt " dbdest=" dbdest)
                                   ))

                             (print "NOTE: skipping " runkeydat " for area, not in " areas)))
		       all-areas))
		    runkeydats)))
	       (let ((res (configf:get-section torun contour))) ;; each contour / target
		 ;; (print "res=" res)
		 res))))
	  (hash-table-keys torun)))))))

(define (pkt->cmdline pkta)
  (let ((action (or (lookup-action-by-key (alist-ref 'a pkta)) "noaction")))



    (fold (lambda (a res)
	    (let* ((key (car a)) ;; get the key name
		   (val (cdr a))
		   (par (or (lookup-param-by-key key)  ;; need to check also if it is a switch
			    (lookup-param-by-key key inlst: *switch-keys*))))
	      ;; (print "key: " key " val: " val " par: " par)
	      (if par
		  (conc res " " (param-translate par) " " val)
		  (if (member key '(a Z U D T)) ;; a is the action
		      res
		      (begin
			(print "ERROR: Unknown key in packet \"" key "\" with value \"" val "\"")
			res)))))
	  (conc "megatest " (if (not (member action '("sync")))
				(conc action " ")
				""))
	  pkta)))

;; (use trace)(trace pkt->cmdline)

(define (write-pkt pktsdir uuid pkt)
  (if pktsdir







>
|
>








>
>















|
|

>
|
>


|
|

>
|
>


|
>
>

<
<
|




|
|

|
>
|







|
|
|

>
|

<

>
>

<
|





|
|

>
|
|

|










|
|

|
>
|








<
|
|
|
|
|
|
|
>

|







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







|
>
>
>








|





|







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
				      (need-run    (> last-change last-run)))
				 (print "last-run: " last-run " need-run: " need-run)
				 (if need-run
				     (let* ((key-msg    `((message  . ,(conc ruletype ":" message))
							  (runname  . ,runname)
							  (runtrans . ,runtrans)
							  (action   . ,action)
							  (areas    . ,areas)
							  (target   . ,new-target) ;; overriding with result from runing the script
                                                          )))
				       (print "key-msg: " key-msg)
				       (push-run-spec torun contour
						      (if optional  ;; we need to be able to differentiate same contour, different behavior. 
							  (conc runkey ":" optional)  ;; NOTE: NOT COMPLETELY IMPLEMENTED. DO NOT USE
							  runkey)
						      key-msg)))))))
		       val-alist)) ;; iterate over the param split by ;\s*

		     ;; fossil scm based triggers
		     ;;
		     ((fossil)
		      (for-each
		       (lambda (fspec)
			 (print "fspec: " fspec)
			 (let* ((url         (symbol->string (car fspec))) ;; THIS COULD BE TROUBLE. Add option to reading line to return as string.
				(branch      (cdr fspec))
				(url-is-file (string-match "^(/|file:).*$" url))
				(fname       (conc (common:get-signature url) ".fossil"))
				(fdir        (conc "/tmp/" (current-user-name) "/mtutil_cache")))
			   ;; (if (not url-is-file) ;; need to sync first --- for now, clone 'em all.
			   (fossil:clone-or-sync url fname fdir) ;; )
			   (let-values (((datetime node)
					 (fossil:last-change-node-and-time fdir fname branch)))
			     (if (null? starttimes)
				 (push-run-spec torun contour runkey
						`((message  . ,(conc "fossil:" branch "-neverrun"))
						  (runname  . ,(conc runname "-" node))
						  (runtrans . ,runtrans)
						  (areas    . ,areas)
						  ;; (target   . ,runkey)
                                                  ))
				 (if (> datetime last-run) ;; change time is greater than last-run time
				     (push-run-spec torun contour runkey
						    `((message  . ,(conc "fossil:" branch "-" node))
						      (runname  . ,(conc runname "-" node))
						      (runtrans . ,runtrans)
						      (areas    . ,areas)
						      ;; (target   . ,runkey)
                                                      ))))
			     (print "Got datetime=" datetime " node=" node))))
		       val-alist))

		     ;; sensor looking for one or more files newer than reference
		     ;;
		     ((file file-or) ;; one or more files must be newer than the reference


		      (let* ((youngestdat (common:get-youngest (common:bash-glob file-globs)))
			     (youngestmod (car youngestdat)))
			;; (print "youngestmod: " youngestmod " starttimes: " starttimes)
			(if (null? starttimes) ;; this target has never been run
			    (push-run-spec torun contour runkey
					   `((message  . "file:neverrun")
					     (action   . ,action)
					     (runtrans . ,runtrans)
					     ;; (target   . ,runkey)
					     (areas    . ,areas)
					     (runname  . ,runname)))
			;; (for-each
			;;  (lambda (starttime) ;; look at the time the last run was kicked off for this contour
			;;    (if (> youngestmod (cdr starttime))
			;; 	   (begin
			;; 	     (print "starttime younger than youngestmod: " starttime " Youngestmod: " youngestmod)
			    (if (> youngestmod last-run)
				(push-run-spec torun contour runkey
					       `((message  . ,(conc ruletype ":" (cadr youngestdat)))
						 (action   . ,action)
						 ;; (target   . ,runkey)
						 (runtrans . ,runtrans)
						 (areas    . ,areas)
						 (runname  . ,runname)
						 ))))))


		     ;; all globbed files must be newer than the reference
		     ;;
		     ((file-and) ;; all files must be newer than the reference

		      (let* ((youngestdat (common:get-youngest file-globs))
			     (youngestmod (car youngestdat))
			     (success     #t)) ;; any cases of not true, set flag to #f for AND
			;; (print "youngestmod: " youngestmod " starttimes: " starttimes)
			(if (null? starttimes) ;; this target has never been run
			    (push-run-spec torun contour runkey
					   `((message  . "file:neverrun")
					     (runname  . ,runname)
					     (runtrans . ,runtrans)
					     (areas    . ,areas)
					     ;; (target   . ,runkey)
					     (action   . ,action)))
			    ;; NB// I think this is wrong. It should be looking at last-run only.
			    (if (> youngestmod last-run) ;; WAIT!! Shouldn't file-and be looking at the *oldest* file (thus all are younger than ...)
				
				;; 			    (for-each
				;; 			     (lambda (starttime) ;; look at the time the last run was kicked off for this contour
				;; 			       (if (< youngestmod (cdr starttime))
				;; 				   (set! success #f)))
				;; 			     starttimes))
				;; 			(if success
				;; 			    (begin
				;; 			      (print "starttime younger than youngestmod: " starttime " Youngestmod: " youngestmod)
				(push-run-spec torun contour runkey
					       `((message  . ,(conc ruletype ":" (cadr youngestdat)))
						 (runname  . ,runname)
						 (runtrans . ,runtrans)
						 ;; (target   . ,runkey)
						 (areas    . ,areas)
						 (action   . ,action)
						 ))))))
		     (else (print "ERROR: unrecognised rule \"" ruletype)))))
	       keydats))) ;; sense rules
	  (hash-table-keys rgconf))
	 
	 ;; now have to run populated
	 (for-each
	  (lambda (contour)

	    (let* ((cval       (or (configf:lookup mtconf "contours" contour) ""))
		   (cval-alist (val->alist cval))                     ;; BEWARE ... NOT the same val-alist as above!
		   (areas      (val-alist->areas cval-alist))
		   (selector   (alist-ref 'selector cval-alist))
		   (mode-tag   (and selector (string-split-fields "/" selector #:infix)))
		   (mode-patt  (and mode-tag (if (eq? (length mode-tag) 2)(cadr mode-tag) #f)))
		   (tag-expr   (and mode-tag (if (null? mode-tag) #f (car mode-tag)))))
	      (print "contour: " contour " areas=" areas " cval=" cval)
	      (for-each
	       (lambda (runkeydatset) 
		 ;; (print "runkeydatset: ")(pp runkeydatset)
		 (let ((runkey     (car runkeydatset))
		       (runkeydats (cadr runkeydatset)))
		   (for-each
		    (lambda (runkeydat)
		      (for-each
		       (lambda (area)
			 (if (area-allowed? area areas runkey contour mode-patt) ;; is this area to be handled (from areas=a,b,c OR using areafn=abcfn and *area-checks* ...)
                             (let* ((aval       (or (configf:lookup mtconf "areas" area) ""))
                                    (aval-alist (val->alist aval))
                                    (runname    (alist-ref 'runname runkeydat))
                                    (runtrans   (alist-ref 'runtrans runkeydat))
                                    
                                    (reason     (alist-ref 'message runkeydat))
                                    (sched      (alist-ref 'sched   runkeydat))
                                    (action     (alist-ref 'action  runkeydat))
                                    (dbdest     (alist-ref 'dbdest  runkeydat))
                                    (append     (alist-ref 'append  runkeydat))
                                    (targets    (or (alist-ref 'target  runkeydat)
                                                    (map-targets mtconf aval-alist runkey area contour)))) ;; override with target if forced
                               ;; NEED TO EXPAND RUNKEY => ALL TARGETS MAPPED AND THEN FOREACH .... 
                               (for-each
                                (lambda (target)
                                  (print "Creating pkt for runkey=" runkey " target=" target " contour=" contour " area=" area " action=" action " tag-expr=" tag-expr " mode-patt=" mode-patt)
                                  (if (case (or (and action (string->symbol action)) 'noaction)  ;; ensure we have the needed data to run this action
                                        ((noaction)           #f)
                                        ((run)                (and runname reason))
                                        ((sync sync-prepend)  (and reason dbdest))
                                        (else                 #f))
                                      ;; instead of unwrapping the runkeydat alist, pass it directly to create-run-pkt
                                      (create-run-pkt mtconf action area runkey target runname mode-patt
                                                      tag-expr pktsdir reason contour sched dbdest append 
                                                      runtrans) 
                                      (print "ERROR: Missing info to make a " action " call: runkey=" runkey " contour=" contour " area=" area  " tag-expr=" tag-expr " mode-patt=" mode-patt " dbdest=" dbdest)
                                      ))
                                targets))
                             (print "NOTE: skipping " runkeydat " for area \"" area "\", not in " areas)))
                       all-areas))
		    runkeydats)))
	       (let ((res (configf:get-section torun contour))) ;; each contour / target
		 ;; (print "res=" res)
		 res))))
	  (hash-table-keys torun)))))))

(define (pkt->cmdline pkta)
  (let* ((action (or (lookup-action-by-key (alist-ref 'A pkta)) "noaction"))
	 (action-param (case (string->symbol action)
			 ((-set-state-status) (conc (alist-ref 'l pkta) " "))
			 (else ""))))
    (fold (lambda (a res)
	    (let* ((key (car a)) ;; get the key name
		   (val (cdr a))
		   (par (or (lookup-param-by-key key)  ;; need to check also if it is a switch
			    (lookup-param-by-key key inlst: *switch-keys*))))
	      ;; (print "key: " key " val: " val " par: " par)
	      (if par
		  (conc res " " (param-translate par) " " val)
		  (if (alist-ref key *additional-cards*) ;; these cards do not translate to parameters or switches
		      res
		      (begin
			(print "ERROR: Unknown key in packet \"" key "\" with value \"" val "\"")
			res)))))
	  (conc "megatest " (if (not (member action '("sync")))
				(conc action " " action-param)
				""))
	  pkta)))

;; (use trace)(trace pkt->cmdline)

(define (write-pkt pktsdir uuid pkt)
  (if pktsdir
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
		 (handle-exceptions
		     exn
		     #f
		   (create-directory "logs")
		   #t)
		 #t)
	     "logs"
	     "/tmp")))




    (with-queue-db
     mtconf
     (lambda (pktsdirs pktsdir pdb)
       (let* ((rgconfdat (find-and-read-config (conc toppath "/runconfigs.config")))
	      (rgconf    (car rgconfdat))
	      (areas     (configf:get-section mtconf "areas"))
	      (contours  (configf:get-section mtconf "contours"))
	      (pkts      (find-pkts pdb '(cmd) '()))
	      (torun     (make-hash-table)) ;; target => ( ... info ... )
	      (rgentargs (hash-table-keys rgconf))) ;; these are the targets registered for automatically triggering
	 (for-each
	  (lambda (pktdat)
	    (let* ((pkta    (alist-ref 'apkt pktdat))
		   (action  (alist-ref 'a pkta))
		   (cmdline (pkt->cmdline pkta))
		   (uuid    (alist-ref 'Z pkta))


		   (logf    (conc logdir "/" uuid "-run.log"))
		   (fullcmd (conc "NBFAKE_LOG=" logf " nbfake " cmdline)))





	      (print "RUNNING: " fullcmd)
	      (system fullcmd)
	      (mark-processed pdb (list (alist-ref 'id pktdat)))
	      (let-values (((ack-uuid ack-pkt)
			    (add-z-card
			     (construct-sdat 'P uuid
					     'T (case (string->symbol action)
						  ((run) "runstart")
						  ((sync) "syncstart")    ;; example of translating run -> runstart
						  (else   action))
					     'c (alist-ref 'o pkta) ;; THIS IS WRONG! SHOULD BE 'c
					     't (alist-ref 't pkta)))))
		(write-pkt pktsdir ack-uuid ack-pkt))))









	  pkts))))))
  



























(define (get-pkts-dir mtconf)
  (let ((pktsdirs  (configf:lookup mtconf "setup" "pktsdirs"))
	(pktsdir   (if pktsdirs (car (string-split pktsdirs " ")) #f)))
    pktsdir))

(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.mtutilrc")))
  (if (common:file-exists? debugcontrolf)
      (load debugcontrolf)))

(if *action*
    (case (string->symbol *action*)
      ((run remove rerun set-ss archive kill)
       (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
	      (mtconf    (car mtconfdat))
	      (area      (args:get-arg "-area")) ;; look up the area to dispatch to from [areas] section
	      (areasec   (if area (configf:lookup mtconf "areas" area) #f))
	      (areadat   (if areasec (val->alist areasec) #f))
	      (area-path (if areadat (alist-ref 'path areadat) #f))
	      (pktsdirs  (configf:lookup mtconf "setup" "pktsdirs"))
	      (pktsdir   (if pktsdirs (car (string-split pktsdirs " ")) #f))
	      (adjargs   (hash-table-copy args:arg-hash)))

	 ;; check a few things

	 (if (and area


		  (not area-path))






	     (begin
	       (print "ERROR: the specified area was not found in the [areas] table. Area name=" area)
	       (exit 1)))

	 ;; (for-each
	 ;;  (lambda (key)
	 ;;    (if (not (member key *legal-params*))
	 ;; 	(hash-table-delete! adjargs key))) ;; we need to delete any params intended for mtutil
	 ;;  (hash-table-keys adjargs))
	 (let-values (((uuid pkt)
		       (command-line->pkt *action* adjargs #f area-path: area-path)))
	   (write-pkt pktsdir uuid pkt))))
      ((dispatch import rungen process)
       (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
	      (mtconf    (car mtconfdat))
	      (toppath   (configf:lookup mtconf "dyndat" "toppath")))
	 (case (string->symbol *action*)
	   ((process)  (begin
			 (load-pkts-to-db mtconf)
			 (generate-run-pkts mtconf toppath)
			 (load-pkts-to-db mtconf)
			 (dispatch-commands mtconf toppath)))
	   ((import)   (load-pkts-to-db mtconf)) ;; import pkts
	   ((rungen)   (generate-run-pkts mtconf toppath))
	   ((dispatch) (dispatch-commands mtconf toppath)))))































      ((db)
       (if (null? remargs)
	   (print "ERROR: missing sub command for db command")
	   (let ((subcmd (car remargs)))
	     (case (string->symbol subcmd)
	       ((pgschema)
		(let* ((install-home (common:get-install-area))
		       (schema-file  (conc install-home "/share/db/mt-pg.sql")))
		  (if (common:file-exists? schema-file)
		      (system (conc "/bin/cat " schema-file)))))
	       ((sqlite3schema)
		(let* ((install-home (common:get-install-area))
		       (schema-file  (conc install-home "/share/db/mt-sqlite3.sql")))
		  (if (common:file-exists? schema-file)
		      (system (conc "/bin/cat " schema-file)))))
	       ((junk)
		(rmt:get-keys))))))



















      ))



















;; If HTTP_HOST is defined then we must be in the cgi environment
;; so run stml and exit
;;
(if (get-environment-variable "HTTP_HOST")
    (begin
      (stml:main #f)







|
>
>
>
>
|












|


>
>


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

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











|








|
>

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






|




|


|

|

|


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

















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







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
		 (handle-exceptions
		     exn
		     #f
		   (create-directory "logs")
		   #t)
		 #t)
	     "logs"
	     "/tmp"))
	(cpuload (alist-ref 'adj-proc-load (common:get-normalized-cpu-load #f)))
	(maxload (string->number (or (configf:lookup mtconf "setup" "maxload")
				     (configf:lookup mtconf "jobtools" "maxload") ;; respect value used by Megatest calls
				     "1.1"))))
    (common:with-queue-db
     mtconf
     (lambda (pktsdirs pktsdir pdb)
       (let* ((rgconfdat (find-and-read-config (conc toppath "/runconfigs.config")))
	      (rgconf    (car rgconfdat))
	      (areas     (configf:get-section mtconf "areas"))
	      (contours  (configf:get-section mtconf "contours"))
	      (pkts      (find-pkts pdb '(cmd) '()))
	      (torun     (make-hash-table)) ;; target => ( ... info ... )
	      (rgentargs (hash-table-keys rgconf))) ;; these are the targets registered for automatically triggering
	 (for-each
	  (lambda (pktdat)
	    (let* ((pkta    (alist-ref 'apkt pktdat))
		   (action  (alist-ref 'A pkta))
		   (cmdline (pkt->cmdline pkta))
		   (uuid    (alist-ref 'Z pkta))
		   (user    (alist-ref 'U pkta))
		   (area    (alist-ref 'G pkta))
		   (logf    (conc logdir "/" uuid "-run.log"))
		   (fullcmd (conc "NBFAKE_LOG=" logf " nbfake " cmdline)))
	      (if (check-access user mtconf action area)
		  (if (and (> cpuload maxload)
			   (member action '("run" "archive"))) ;; do not run archive or run if load is over the specified limit
		      (print "WARNING: cpuload too high, skipping processing of " uuid)
		      (begin
			(print "RUNNING: " fullcmd)
			(system fullcmd) ;; replace with process ...
			(mark-processed pdb (list (alist-ref 'id pktdat)))
			(let-values (((ack-uuid ack-pkt)
				      (add-z-card
				       (construct-sdat 'P uuid
						       'T (case (string->symbol action)
							    ((run) "runstart")
							    ((sync) "syncstart")    ;; example of translating run -> runstart
							    (else   action))
						       'c (alist-ref 'o pkta) ;; THIS IS WRONG! SHOULD BE 'c
						       't (alist-ref 't pkta)))))
			  (write-pkt pktsdir ack-uuid ack-pkt))))
		  (begin ;; access denied! Mark as such
		    (mark-processed pdb (list (alist-ref 'id pktdat)))
		    (let-values (((ack-uuid ack-pkt)
				  (add-z-card
				   (construct-sdat 'P uuid
						   'T "access-denied"
						   'c (alist-ref 'o pkta) ;; THIS IS WRONG! SHOULD BE 'c
						   't (alist-ref 't pkta)))))
		      (write-pkt pktsdir ack-uuid ack-pkt))))))
	  pkts))))))

(define (check-access user mtconf action area)
  ;; NOTE: Need control over defaults. E.g. default might be no access
  (let* ((access-ctrl (hash-table-exists? mtconf "access"))  ;; if there is an access section the default is to REQUIRE enablement/access
	 (access-list (map (lambda (x)
			     (string-split x ":"))
			   (string-split (or (configf:lookup mtconf "access" area) ;; userid:rightstype userid2:rightstype2 ...
					     (if access-ctrl
						 "*:none"  ;; nobody has access by default
						 "*:all")))))
	 (access-types-dat (configf:get-section mtconf "accesstypes")))
    (debug:print 0 *default-log-port* "Checking access in " access-list " with access-ctrl " access-ctrl " for area " area)
    (if access-ctrl
	(let* ((user-access     (or (assoc user access-list)
				    (assoc "*"  access-list)))
	       (access-type     (cadr user-access))
	       (access-types    (let ((res (alist-ref access-type access-types-dat equal?)))
				  (if res (car res) res)))
	       (allowed-actions (string-split (or access-types ""))))
	  (print "Got " allowed-actions " for user " user " where access-types=" access-types " access-type=" access-type)
	  (cond
	   ((and access-types (member action allowed-actions))
	    ;; (print "Access granted for " user " for " action)
	    #t)
	   (else
	    ;; (print "Access denied for " user " for " action)
	    #f))))))

(define (get-pkts-dir mtconf)
  (let ((pktsdirs  (configf:lookup mtconf "setup" "pktsdirs"))
	(pktsdir   (if pktsdirs (car (string-split pktsdirs " ")) #f)))
    pktsdir))

(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.mtutilrc")))
  (if (common:file-exists? debugcontrolf)
      (load debugcontrolf)))

(if *action*
    (case (string->symbol *action*)
      ((run remove rerun set-ss archive kill list)
       (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
	      (mtconf    (car mtconfdat))
	      (area      (args:get-arg "-area")) ;; look up the area to dispatch to from [areas] section
	      (areasec   (if area (configf:lookup mtconf "areas" area) #f))
	      (areadat   (if areasec (val->alist areasec) #f))
	      (area-path (if areadat (alist-ref 'path areadat) #f))
	      (pktsdirs  (configf:lookup mtconf "setup" "pktsdirs"))
	      (pktsdir   (if pktsdirs (car (string-split pktsdirs " ")) #f))
	      (adjargs   (hash-table-copy args:arg-hash))
	      (new-ss    (args:get-arg "-new")))
	 ;; check a few things
	 (cond
	  ((and area (not area-path))
	   (print "ERROR: the specified area was not found in the [areas] table. Area name=" area)
	   (exit 1))
	  ((not area)
	   (print "ERROR: no area specified. Use -area <areaname>")
	   (exit 1))
	  (else
	   (let ((user (current-user-name)))
	     (if (check-access user mtconf *action* area);; check rights
		 (print "Access granted for " *action* " action by " user)
		 (begin
		   (print "Access denied for " *action* " action by " user)
		   (exit 1))))))
	 
	 ;; (for-each
	 ;;  (lambda (key)
	 ;;    (if (not (member key *legal-params*))
	 ;; 	(hash-table-delete! adjargs key))) ;; we need to delete any params intended for mtutil
	 ;;  (hash-table-keys adjargs))
	 (let-values (((uuid pkt)
		       (command-line->pkt *action* adjargs #f area-path: area-path new-ss: new-ss)))
	   (write-pkt pktsdir uuid pkt))))
      ((dispatch import rungen process)
       (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
	      (mtconf    (car mtconfdat))
	      (toppath   (configf:lookup mtconf "scratchdat" "toppath")))
	 (case (string->symbol *action*)
	   ((process)  (begin
			 (common:load-pkts-to-db mtconf)
			 (generate-run-pkts mtconf toppath)
			 (common:load-pkts-to-db mtconf)
			 (dispatch-commands mtconf toppath)))
	   ((import)   (common:load-pkts-to-db mtconf)) ;; import pkts
	   ((rungen)   (generate-run-pkts mtconf toppath))
	   ((dispatch) (dispatch-commands mtconf toppath)))))
      ;; misc
      ((show)
       (if (> (length remargs) 0)
	   (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
		  (mtconf    (car mtconfdat))
		  (sect-dat (configf:get-section mtconf (car remargs))))
	     (if sect-dat
		 (for-each
		  (lambda (entry)
		    (if (> (length entry) 1)
			(print (car entry) "   " (cadr entry))
			(print (car entry))))
		  sect-dat)
		 (print "No section \"" (car remargs) "\" found")))
	   (print "ERROR: list requires section parameter; areas, setup or contours")))
      ((gendot)
       (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
	      (mtconf    (car mtconfdat)))
	 (common:with-queue-db
	  mtconf
	  (lambda (pktsdirs pktsdir conn)
	    ;;                       pktspec display-fields 
	    (make-report "out.dot" conn
			 '((cmd      . ((parent . P)
					(user   . M)
					(target . t)))
			   (runstart . ((parent . P)
					(target . t)))
			   (runtype . ((parent . P)))) ;; pktspec
			 '(P U t)                                                     ;; 
			 )))))  ;; no ptypes listed (ptypes are strings of pkt types to read from db
      ((db)
       (if (null? remargs)
	   (print "ERROR: missing sub command for db command")
	   (let ((subcmd (car remargs)))
	     (case (string->symbol subcmd)
	       ((pgschema)
		(let* ((install-home (common:get-install-area))
		       (schema-file  (conc install-home "/share/db/mt-pg.sql")))
		  (if (common:file-exists? schema-file)
		      (system (conc "/bin/cat " schema-file)))))
	       ((sqlite3schema)
		(let* ((install-home (common:get-install-area))
		       (schema-file  (conc install-home "/share/db/mt-sqlite3.sql")))
		  (if (common:file-exists? schema-file)
		      (system (conc "/bin/cat " schema-file)))))
	       ((junk)
		(rmt:get-keys))))))
      ((tsend)
       (if (null? remargs)
	   (print "ERROR: missing data to send to trigger listeners")
	   (let* ((msg       (car remargs))
                  (mtconfdat (simple-setup (args:get-arg "-start-dir")))
                  (mtconf    (car mtconfdat))
                  (listeners (configf:get-section mtconf "listeners"))
                  (prev-seen (make-hash-table))) ;; catch duplicates
             (for-each
              (lambda (listener)
                (let ((host-port (car listener))
                      (remdat    (cdr listener)))
                  (print "sending " msg " to " host-port)
                  (open-send-close-nn host-port msg timeout: 2)))
              listeners))))
      ((tlisten)
       (if (null? remargs)
           (print "ERROR: useage for tlisten is \"mtutil tlisten portnum\"")
           (let ((portnum (string->number (car remargs))))
              
             (if (not portnum)
                 (print "ERROR: the portnumber parameter must be a number, you gave: " (car remargs))
                 (begin
                   (if (not (is-port-in-use portnum))  
                       (let* ((rep       (start-nn-server portnum))
                           (mtconfdat (simple-setup (args:get-arg "-start-dir")))
                           (mtconf    (car mtconfdat))
                           (script    (configf:lookup mtconf "listener" "script")))
                           (print "Listening on port " portnum " for messages")
                           (let loop ((instr (nn-recv rep)))
                               (print "received " instr ", running \"" script " " instr "\"")
                               (system (conc script " '" instr "'"))
                               (nn-send rep "ok")
                               (loop (nn-recv rep))))
                     (print "ERROR: Port " portnum " already in use. Try another port")))))))
      
      )) ;; the end
             

;; If HTTP_HOST is defined then we must be in the cgi environment
;; so run stml and exit
;;
(if (get-environment-variable "HTTP_HOST")
    (begin
      (stml:main #f)
1011
1012
1013
1014
1015
1016
1017






      ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
      
      (install-history-file (get-environment-variable "HOME") ".mtutil_history") ;;  [homedir] [filename] [nlines])
      (current-input-port (make-readline-port "mtutil> "))
      (if (args:get-arg "-repl")
	  (repl)
	  (load (args:get-arg "-load")))))













>
>
>
>
>
>
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
      ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
      
      (install-history-file (get-environment-variable "HOME") ".mtutil_history") ;;  [homedir] [filename] [nlines])
      (current-input-port (make-readline-port "mtutil> "))
      (if (args:get-arg "-repl")
	  (repl)
	  (load (args:get-arg "-load")))))

#|
(define mtconf (car (simple-setup #f)))
(define dat (with-queue-db mtconf (lambda (conn)(get-pkts conn '()))))
(pp (pkts#flatten-all dat '((cmd . ((parent . P)(url . M)))(runtype . ((parent . P)))) 'id 'group-id 'uuid 'parent 'pkt-type 'pkt 'processed))
|#

Modified process.scm from [98aa9e5247] to [e9d50c66de].

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

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

(use regex)
(declare (unit process))
;;(declare (uses common))

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








<







11
12
13
14
15
16
17

18
19
20
21
22
23
24

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

(use regex)
(declare (unit process))


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

Modified rmt.scm from [8ae137f573] to [01d76df641].

9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
;;  PURPOSE.
;;======================================================================

(use format typed-records) ;; RADT => purpose of json format??

(declare (unit rmt))
(declare (uses api))
;; (declare (uses tdb))
(declare (uses http-transport))
;;(declare (uses nmsg-transport))
(include "common_records.scm")

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

;; generate entries for ~/.megatestrc with the following







<

<







9
10
11
12
13
14
15

16

17
18
19
20
21
22
23
;;  PURPOSE.
;;======================================================================

(use format typed-records) ;; RADT => purpose of json format??

(declare (unit rmt))
(declare (uses api))

(declare (uses http-transport))

(include "common_records.scm")

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

;; generate entries for ~/.megatestrc with the following
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
	(debug:print 3 *default-log-port* "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)) 
  (rmt:send-receive 'read-test-data run-id (list run-id test-id categorypatt)))
(define (rmt:read-test-data* run-id test-id categorypatt varpatt #!key (work-area #f)) 
  (rmt:send-receive 'read-test-data* run-id (list run-id test-id categorypatt varpatt)))

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








>
>
>









<
<
|
<
>







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
	(debug:print 3 *default-log-port* "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)))

(define (rmt:get-steps-info-by-id test-step-id)
  (rmt:send-receive 'get-steps-info-by-id #f (list test-step-id)))

;;======================================================================
;;  T E S T   D A T A 
;;======================================================================

(define (rmt:read-test-data run-id test-id categorypatt #!key (work-area #f)) 
  (rmt:send-receive 'read-test-data run-id (list run-id test-id categorypatt)))
(define (rmt:read-test-data* run-id test-id categorypatt varpatt #!key (work-area #f)) 
  (rmt:send-receive 'read-test-data* run-id (list run-id test-id categorypatt varpatt)))



(define (rmt:get-data-info-by-id test-data-id)

   (rmt:send-receive 'get-data-info-by-id #f (list test-data-id)))

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

Modified rpctest/rpctest-continuous-client.scm from [ea7c1d49cf] to [bb9e39b0dd].

15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
(define operation (string->symbol (car (command-line-arguments))))
(define param (cadr (command-line-arguments)))
(print "Operation: " operation ", param: " param)

;; have a pool of db's to pick from
(define *dbpool* '())
(define *pool-mutex* (make-mutex))
1
(define (get-db)
  (mutex-lock! *pool-mutex*)
  (if (null? *dbpool*)
      (begin
	(mutex-unlock! *pool-mutex*)
	(let ((db (open-database param)))
	  (set-busy-handler! db (busy-timeout 10000))







|







15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
(define operation (string->symbol (car (command-line-arguments))))
(define param (cadr (command-line-arguments)))
(print "Operation: " operation ", param: " param)

;; have a pool of db's to pick from
(define *dbpool* '())
(define *pool-mutex* (make-mutex))

(define (get-db)
  (mutex-lock! *pool-mutex*)
  (if (null? *dbpool*)
      (begin
	(mutex-unlock! *pool-mutex*)
	(let ((db (open-database param)))
	  (set-busy-handler! db (busy-timeout 10000))

Modified runconfigs.config from [bf5ecdf3ee] to [e2b75d4c3c].

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
# To get emacs font highlighing in the various megatest configs do this:
#
# Install emacs-goodies-el:
#    sudo apt install emacs-goodies-el
# Add to your ~/.emacs file:
#    (add-to-list 'auto-mode-alist '("config\\'" . conf-space-mode))
#

# example of a cron entry to run sync using db spec pgdb, with pgdb setting in file local.config
#
[a/b/c]
all:scheduled:sync     cron=  0/5 * * * *;dbdest=pgdb;appendconf=/nfs/phoebe/disk1/home/mfs/matt/.sysmaint/local.config
quick:scheduled:sync   cron=  0/5 * * * *;dbdest=pgdb;appendconf=/nfs/phoebe/disk1/home/mfs/matt/.sysmaint/local.config


[scriptinc ./gentargets.sh #{getenv USER}]
# [v1.23/45/67]

# tip will be replaced with hashkey?

# [%/%/%] doesn't work

[/.*/]

# [v1.63/tip/dev]
# file:   files changes since last run trigger new run
# script: script is called with unix seconds as last parameter (other parameters are preserved)
#
# contour:sensetype:action params            data

quick:file:run             runtrans=auto;         glob=/home/matt/data/megatest/*.scm
# snazy:file:run             runtrans=corporate-ww; glob=/home/matt/data/megatest/*.scm
# short:file:run             runtrans=short;        glob=/home/matt/data/megatest/*.scm

# script returns change-time (unix epoch), new-target-name, run-name
#
# quick:script:run           checkfossil = http://www.kiatoa.com/fossils/megatest v1.63;\
#                            checkfossil = http://www.kiatoa.com/fossils/megatest_qa trunk

# fossil based trigger
#
#quick:fossil:run           http://www.kiatoa.com/fossils/megatest=v1.63;\
#                           http://www.kiatoa.com/fossils/megatest_qa=trunk;\
#		           http://www.kiatoa.com/fossils/megatest=v1.64

# field          allowed values
# -----          --------------
# minute         0-59
# hour           0-23
# day of month   1-31
# month          1-12 (or names, future development)












|
>















>
|

|






|
|
|
|
|







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
# To get emacs font highlighing in the various megatest configs do this:
#
# Install emacs-goodies-el:
#    sudo apt install emacs-goodies-el
# Add to your ~/.emacs file:
#    (add-to-list 'auto-mode-alist '("config\\'" . conf-space-mode))
#

# example of a cron entry to run sync using db spec pgdb, with pgdb setting in file local.config
#
[a/b/c]
all:scheduled:sync     cron=  0/5 * * * *;dbdest=pgdb;appendconf=/nfs/phoebe/disk1/home/mfs/matt/.sysmaint/local.config
# quick:scheduled:sync   cron=  0/5 * * * *;dbdest=pgdb;appendconf=/nfs/phoebe/disk1/home/mfs/matt/.sysmaint/local.config
# fast:scheduled:sync-prepend cron=  0/1 * * * *;dbdest=pgdb;appendconf=/mfs/matt/.sysmaint/local.config

[scriptinc ./gentargets.sh #{getenv USER}]
# [v1.23/45/67]

# tip will be replaced with hashkey?

# [%/%/%] doesn't work

[/.*/]

# [v1.63/tip/dev]
# file:   files changes since last run trigger new run
# script: script is called with unix seconds as last parameter (other parameters are preserved)
#
# contour:sensetype:action params            data
# commented out for debug
quick:file:run             runtrans=auto;         glob=/home/matt/data/megatest/*.scm foo.touchme
# snazy:file:run             runtrans=corporate-ww; glob=/home/matt/data/megatest/*.scm
# short:file:run       runtrans=short;        glob=/home/matt/data/megatest/*.scm

# script returns change-time (unix epoch), new-target-name, run-name
#
# quick:script:run           checkfossil = http://www.kiatoa.com/fossils/megatest v1.63;\
#                            checkfossil = http://www.kiatoa.com/fossils/megatest_qa trunk

# # fossil based trigger
# #
# quick:fossil:run           http://www.kiatoa.com/fossils/megatest=v1.63;\
#                            http://www.kiatoa.com/fossils/megatest_qa=trunk;\
# 		           http://www.kiatoa.com/fossils/megatest=v1.64

# field          allowed values
# -----          --------------
# minute         0-59
# hour           0-23
# day of month   1-31
# month          1-12 (or names, future development)

Modified runs.scm from [df9cc9bbed] to [80c295fb6f].

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22

;; Copyright 2006-2016, 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 (srfi 18) 
     posix-extras directory-utils pathname-expand typed-records format)
(import (prefix sqlite3 sqlite3:))

(declare (unit runs))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))












|

<







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

15
16
17
18
19
20
21

;; Copyright 2006-2016, 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 (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) 
     posix-extras directory-utils pathname-expand typed-records format)


(declare (unit runs))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
264
265
266
267
268
269
270







































271
272
273
274
275
276
277
                   (debug:print 0 *default-log-port* "Message: " ((condition-property-accessor 'exn 'message) exn))
                   (debug:print 0 *default-log-port* "ERROR: failed to run pre-hook " run-pre-hook ", check the log " log-file))
                 (debug:print-info 0 *default-log-port* "running run-pre-hook: \"" run-pre-hook "\", log is " actual-logf)
                 (system (conc run-pre-hook " >> " actual-logf " 2>&1"))
                 (debug:print-info 0 *default-log-port* "pre-hook \"" run-pre-hook "\" took " (- (current-seconds) start-time) " seconds to run.")))
              (debug:print 0 *default-log-port* "Skipping pre-hook call \"" run-pre-hook "\" as there are existing tests for this run.")))))
    







































;;  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 1)) ;; test-names
  (let* ((keys               (keys:config-get-fields *configdat*))
	 (keyvals            (keys:target->keyval keys target))







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







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
                   (debug:print 0 *default-log-port* "Message: " ((condition-property-accessor 'exn 'message) exn))
                   (debug:print 0 *default-log-port* "ERROR: failed to run pre-hook " run-pre-hook ", check the log " log-file))
                 (debug:print-info 0 *default-log-port* "running run-pre-hook: \"" run-pre-hook "\", log is " actual-logf)
                 (system (conc run-pre-hook " >> " actual-logf " 2>&1"))
                 (debug:print-info 0 *default-log-port* "pre-hook \"" run-pre-hook "\" took " (- (current-seconds) start-time) " seconds to run.")))
              (debug:print 0 *default-log-port* "Skipping pre-hook call \"" run-pre-hook "\" as there are existing tests for this run.")))))
    
(define (runs:run-post-hook run-id)
    (let* ((run-post-hook   (configf:lookup *configdat* "runs" "post-hook"))
           (existing-tests (if run-post-hook
                               (rmt:get-tests-for-run run-id "%" '() '() ;; run-id testpatt states statuses
                                                      #f #f ;; offset limit
                                                      #f ;; not-in
                                                      #f ;; sort-by
                                                      #f ;; sort-order
                                                      #f ;; get full data (not 'shortlist)
                                                      0 ;; (runs:gendat-inc-results-last-update *runs:general-data*) ;; last update time
                                                      'dashboard)
                               '()))
           (log-dir         (conc *toppath* "/logs"))
           (log-file        (conc "post-hook-" (string-translate (getenv "MT_TARGET") "/" "-") "-" (getenv "MT_RUNNAME") ".log"))
           (full-log-fname  (conc log-dir "/" log-file)))
      (if run-post-hook
          ;; (if (null? existing-tests)
          ;;    (debug:print 0 *default-log-port* "Skipping post-hook call \"" run-post-hook "\" as there are existing tests for this run.")))))
	  (let* ((use-log-dir (if (not (directory-exists? log-dir))
				  (handle-exceptions
				      exn
				      (begin
					(debug:print 0 *default-log-port* "WARNING: Failed to create " log-dir)
					#f)
				    (create-directory log-dir #t)
				    #t)
				  #t))
		 (start-time   (current-seconds))
		 (actual-logf  (if use-log-dir full-log-fname log-file)))
	    (handle-exceptions
		exn
		(begin
		  (print-call-chain *default-log-port*)
		  (debug:print 0 *default-log-port* "Message: " ((condition-property-accessor 'exn 'message) exn))
		  (debug:print 0 *default-log-port* "ERROR: failed to run post-hook " run-post-hook ", check the log " log-file))
	      (debug:print-info 0 *default-log-port* "running run-post-hook: \"" run-post-hook "\", log is " actual-logf)
	      (system (conc run-post-hook " >> " actual-logf " 2>&1"))
	      (debug:print-info 0 *default-log-port* "post-hook \"" run-post-hook "\" took " (- (current-seconds) start-time) " seconds to run."))))))

;;  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 1)) ;; test-names
  (let* ((keys               (keys:config-get-fields *configdat*))
	 (keyvals            (keys:target->keyval keys target))
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
					    (handle-exceptions
						exn
						(begin
						  (print-call-chain)
						  (print " message: " ((condition-property-accessor 'exn 'message) exn)))
					      (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests
								    (any->number reglen) all-tests-registry)))
					    ;; (handle-exceptions
					    ;;  exn
					    ;;  (begin
					    ;;    (print-call-chain (current-error-port))
					    ;;    (debug:print-error 0 *default-log-port* "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







<
<
<
<
<
<
<
<
<
<







557
558
559
560
561
562
563










564
565
566
567
568
569
570
					    (handle-exceptions
						exn
						(begin
						  (print-call-chain)
						  (print " message: " ((condition-property-accessor 'exn 'message) exn)))
					      (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
592
593
594
595
596
597
598








599
600
601
602
603
604
605
(define (runs:queue-next-reg tal reg n regfull)
  (if regfull
      (cdr reg)
      (if (null? tal) ;; if tal is null and reg not full then '() as reg contents moved to tal
	  '()
	  reg)))









(define runs:nothing-left-in-queue-count 0)

;; BB: for future reference - suspect target vars are not expanded to env vars at this point (item expansion using [items]\nwhatever [system echo $TARGETVAR] doesnt work right whereas [system echo #{targetvar}] does.. Tal and Randy have tix on this.  on first pass, var not set, on second pass, ok.  
(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 itemmaps)
  (let* ((loop-list       (list hed tal reg reruns))
	 (prereqs-not-met (let ((res (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps)))
			    (if (list? res)







>
>
>
>
>
>
>
>







620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
(define (runs:queue-next-reg tal reg n regfull)
  (if regfull
      (cdr reg)
      (if (null? tal) ;; if tal is null and reg not full then '() as reg contents moved to tal
	  '()
	  reg)))

;; this is the list of parameters to the named loop "loop" near the top of runs:run-tests-queue, look around line 1216
;;
(define (runs:loop-values tal reg reglen regfull reruns)
  (list (runs:queue-next-hed tal reg reglen regfull)      ;; hed
        (runs:queue-next-tal tal reg reglen regfull)      ;; tal
        (runs:queue-next-reg tal reg reglen regfull)      ;; reg
        reruns))                                          ;; reruns

(define runs:nothing-left-in-queue-count 0)

;; BB: for future reference - suspect target vars are not expanded to env vars at this point (item expansion using [items]\nwhatever [system echo $TARGETVAR] doesnt work right whereas [system echo #{targetvar}] does.. Tal and Randy have tix on this.  on first pass, var not set, on second pass, ok.  
(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 itemmaps)
  (let* ((loop-list       (list hed tal reg reruns))
	 (prereqs-not-met (let ((res (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps)))
			    (if (list? res)
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651

     ((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 *default-log-port* "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
	    (debug:print-info 0 *default-log-port* "Nothing left in the queue!")
	    ;; If get here twice then we know we've tried to expand all items
	    ;; since there must be a logic issue with the handling of loops in the 
	    ;; items expand phase we will brute force an exit here.
	    (if (> runs:nothing-left-in-queue-count 2)
		(begin







<
|
<
<







670
671
672
673
674
675
676

677


678
679
680
681
682
683
684

     ((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 *default-log-port* "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)))

          (runs:loop-values tal reg reglen regfull reruns)


	  (begin
	    (debug:print-info 0 *default-log-port* "Nothing left in the queue!")
	    ;; If get here twice then we know we've tried to expand all items
	    ;; since there must be a logic issue with the handling of loops in the 
	    ;; items expand phase we will brute force an exit here.
	    (if (> runs:nothing-left-in-queue-count 2)
		(begin
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

	      (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 *default-log-port* "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 *default-log-port* "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 *default-log-port* "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)))

	  #f)) ;; #f flags do not loop

     ((and (not (null? fails))(member 'toplevel testmode))
      (if (or (not (null? reg))(not (null? tal)))
	   (list (car newtal)(append (cdr newtal) reg) '() reruns)
	  #f)) 
     ((null? runnables) #f) ;; if we get here and non-completed is null then it is all over.
     (else
      (debug:print 0 *default-log-port* "WARNING: FAILS or incomplete tests maybe preventing completion of this run. Watch for issues with test " hed ", continuing for now")
      ;; (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)
      (list (car newtal)(cdr newtal) reg reruns)))))

(define (runs:mixed-list-testname-and-testrec->list-of-strings inlst)
  (if (null? inlst)
      '()
      (map (lambda (t)
	     (cond







<
|
<
|


















<
|
<
|
















<
<
<
|
>









<
<
<
<







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

	      (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

                  (runs:loop-values 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 *default-log-port* "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 *default-log-port* "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.")))

            (runs:loop-values tal reg reglen regfull reruns)

            )))

     ((and 
       (or (not (null? fails))
	   (not (null? prereq-fails)))
       (member 'normal testmode))
      (debug:print-info 1 *default-log-port* "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)



            (runs:loop-values tal reg reglen regfull (cons hed reruns))
            )
	  #f)) ;; #f flags do not loop

     ((and (not (null? fails))(member 'toplevel testmode))
      (if (or (not (null? reg))(not (null? tal)))
	   (list (car newtal)(append (cdr newtal) reg) '() reruns)
	  #f)) 
     ((null? runnables) #f) ;; if we get here and non-completed is null then it is all over.
     (else
      (debug:print 0 *default-log-port* "WARNING: FAILS or incomplete tests maybe preventing completion of this run. Watch for issues with test " hed ", continuing for now")




      (list (car newtal)(cdr newtal) reg reruns)))))

(define (runs:mixed-list-testname-and-testrec->list-of-strings inlst)
  (if (null? inlst)
      '()
      (map (lambda (t)
	     (cond
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
     ;; Check item path against item-patts, 
     ;;
     ((not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests)) ;; This test/itempath is not to be run
      ;; else the run is stuck, temporarily or permanently
      ;; but should check if it is due to lack of resources vs. prerequisites
      (debug:print-info 1 *default-log-port* "Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " test-patts)
      (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)
	  #f))
     
     ;; Register tests 
     ;;
     ((not (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f))
      (debug:print-info 4 *default-log-port* "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







<
|
<
<







895
896
897
898
899
900
901

902


903
904
905
906
907
908
909
     ;; Check item path against item-patts, 
     ;;
     ((not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests)) ;; This test/itempath is not to be run
      ;; else the run is stuck, temporarily or permanently
      ;; but should check if it is due to lack of resources vs. prerequisites
      (debug:print-info 1 *default-log-port* "Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " test-patts)
      (if (or (not (null? tal))(not (null? reg)))

	  (runs:loop-values 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 *default-log-port* "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
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
	  (begin
	    (rmt:register-test 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 runsdat)   ;; 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)))







|







920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
	  (begin
	    (rmt:register-test 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 runsdat)   ;; 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) ;; cannot replace with a call to runs:loop-values as the logic is different for reg
		(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)))
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
      
      (run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry)
      (runs:incremental-print-results run-id)
      (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'running)
      (runs:shrink-can-run-more-tests-count runsdat)  ;; 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)
	  #f))
     
     ;; must be we have unmet prerequisites
     ;;
     (else
      (debug:print 4 *default-log-port* "FAILS: " fails)
      ;; If one or more of the prereqs-not-met are FAIL then we can issue







<
|
<
<







977
978
979
980
981
982
983

984


985
986
987
988
989
990
991
      
      (run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry)
      (runs:incremental-print-results run-id)
      (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'running)
      (runs:shrink-can-run-more-tests-count runsdat)  ;; DELAY TWEAKER (still needed?)
      ;; (thread-sleep! *global-delta*)
      (if (or (not (null? tal))(not (null? reg)))

	  (runs:loop-values tal reg reglen regfull reruns)


	  #f))
     
     ;; must be we have unmet prerequisites
     ;;
     (else
      (debug:print 4 *default-log-port* "FAILS: " fails)
      ;; If one or more of the prereqs-not-met are FAIL then we can issue
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
		    (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 runsdat) ;; 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
		     ((member "RUNNING" (map db:test-get-state prereqs-not-met))
		      (if (runs:lownoise (conc "possible RUNNING prerequistes " hed) 60)
			  (debug:print 0 *default-log-port* "WARNING: test " hed " has possible RUNNING prerequisites, don't give up on it yet."))
		      (thread-sleep! 4)
		      (list (runs:queue-next-hed newtal reg reglen regfull)
			    (runs:queue-next-tal newtal reg reglen regfull)
			    (runs:queue-next-reg newtal reg reglen regfull)
			    reruns))
		     ((or (not nth-try)
			  (and (number? nth-try)
			       (< nth-try 10)))
		      (hash-table-set! test-registry hed (if (number? nth-try)
							     (+ nth-try 1)
							     0))
		      (if (runs:lownoise (conc "not removing test " hed) 60)
			  (debug:print 1 *default-log-port* "WARNING: not removing test " hed " from queue although it may not be runnable due to FAILED prerequisites"))
		      ;; may not have processed correctly. Could be a race condition in your test implementation? Dropping test " hed) ;;  " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)")
		      (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?)
		      ;; (list hed tal reg reruns)
		      ;; (list (car newtal)(cdr newtal) reg reruns)
		      ;; (hash-table-set! test-registry hed 'removed)
		      (list (runs:queue-next-hed newtal reg reglen regfull)
			    (runs:queue-next-tal newtal reg reglen regfull)
			    (runs:queue-next-reg newtal reg reglen regfull)
			    reruns))
		     ((symbol? nth-try)
		      (if (eq? nth-try 'removed) ;; removed is removed - drop it NOW
			  (if (null? tal)
			      #f ;; yes, really
			      (list (car tal)(cdr tal) reg reruns))
			  (begin
			    (if (runs:lownoise (conc "FAILED prerequisites or other issue" hed) 60)
				(debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequisites or other issue. Internal state " nth-try " will be overridden and we'll retry."))
			    (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "KEEP_TRYING" #f)
			    (hash-table-set! test-registry hed 0)
			    (list (runs:queue-next-hed newtal reg reglen regfull)
				  (runs:queue-next-tal newtal reg reglen regfull)
				  (runs:queue-next-reg newtal reg reglen regfull)
				  reruns))))
		     (else
		      (if (runs:lownoise (conc "FAILED prerequitests and we tried" hed) 60)
			  (debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequitests and we've tried at least 10 times to run it. Giving up now."))
		      ;; (debug:print 0 *default-log-port* "         prereqs: " prereqs-not-met)
		      (hash-table-set! test-registry hed 'removed)
		      (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "TEN_STRIKES" #f)
		      ;; I'm unclear on if this roll up is needed - it may be the root cause of the "all set to FAIL" bug.
		      (rmt:set-state-status-and-roll-up-items run-id test-name item-path #f "FAIL" #f) ;; treat as FAIL
		      (list (if (null? tal)(car newtal)(car tal))
			    tal
			    reg
			    reruns)))))
	      ;; can't drop this - maybe running? Just keep trying
	      (let ((runable-tests (runs:runable-tests prereqs-not-met)))
		(if (null? runable-tests)
		    #f   ;; I think we are truly done here
		    (list (runs:queue-next-hed newtal reg reglen regfull)
			    (runs:queue-next-tal newtal reg reglen regfull)
			    (runs:queue-next-reg newtal reg reglen regfull)
			    reruns)))))))))

;; scan a list of tests looking to see if any are potentially runnable
;;
(define (runs:runable-tests tests)
  (filter (lambda (t)
	    (if (not (vector? t))
		t







<
|
<
<
<






<
|
<
<










<
<
<
<
|
<
<










<
|
<
<













|


<
|
<
<







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

		    (runs:loop-values tal reg reglen regfull reruns))



		  (let ((nth-try (hash-table-ref/default test-registry hed 0)))
		    (cond
		     ((member "RUNNING" (map db:test-get-state prereqs-not-met))
		      (if (runs:lownoise (conc "possible RUNNING prerequistes " hed) 60)
			  (debug:print 0 *default-log-port* "WARNING: test " hed " has possible RUNNING prerequisites, don't give up on it yet."))
		      (thread-sleep! 4)

		      (runs:loop-values tal reg reglen regfull reruns))


		     ((or (not nth-try)
			  (and (number? nth-try)
			       (< nth-try 10)))
		      (hash-table-set! test-registry hed (if (number? nth-try)
							     (+ nth-try 1)
							     0))
		      (if (runs:lownoise (conc "not removing test " hed) 60)
			  (debug:print 1 *default-log-port* "WARNING: not removing test " hed " from queue although it may not be runnable due to FAILED prerequisites"))
		      ;; may not have processed correctly. Could be a race condition in your test implementation? Dropping test " hed) ;;  " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)")
		      (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?)




		      (runs:loop-values newtal reg reglen regfull reruns))


		     ((symbol? nth-try)
		      (if (eq? nth-try 'removed) ;; removed is removed - drop it NOW
			  (if (null? tal)
			      #f ;; yes, really
			      (list (car tal)(cdr tal) reg reruns))
			  (begin
			    (if (runs:lownoise (conc "FAILED prerequisites or other issue" hed) 60)
				(debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequisites or other issue. Internal state " nth-try " will be overridden and we'll retry."))
			    (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "KEEP_TRYING" #f)
			    (hash-table-set! test-registry hed 0)

			    (runs:loop-values newtal reg reglen regfull))))


		     (else
		      (if (runs:lownoise (conc "FAILED prerequitests and we tried" hed) 60)
			  (debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequitests and we've tried at least 10 times to run it. Giving up now."))
		      ;; (debug:print 0 *default-log-port* "         prereqs: " prereqs-not-met)
		      (hash-table-set! test-registry hed 'removed)
		      (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "TEN_STRIKES" #f)
		      ;; I'm unclear on if this roll up is needed - it may be the root cause of the "all set to FAIL" bug.
		      (rmt:set-state-status-and-roll-up-items run-id test-name item-path #f "FAIL" #f) ;; treat as FAIL
		      (list (if (null? tal)(car newtal)(car tal))
			    tal
			    reg
			    reruns)))))
	      ;; can't drop this - maybe running? Just keep trying
	      (let ((runable-tests (runs:runable-tests prereqs-not-met))) ;; SUSPICIOUS: Should look at more than just prereqs-not-met?
		(if (null? runable-tests)
		    #f   ;; I think we are truly done here

		    (runs:loop-values newtal reg reglen regfull reruns)))))))))



;; scan a list of tests looking to see if any are potentially runnable
;;
(define (runs:runable-tests tests)
  (filter (lambda (t)
	    (if (not (vector? t))
		t
1466
1467
1468
1469
1470
1471
1472

1473
1474
1475
1476
1477
1478
1479
	    (if (not (eq? num-running prev-num-running))
		(debug:print-info 0 *default-log-port* "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 *default-log-port* "All tests launched")))

(define (runs:calc-fails prereqs-not-met)
  (filter (lambda (test)
	    (and (vector? test) ;; not (string? test))
		 (member (db:test-get-state test) '("INCOMPLETE" "COMPLETED"))
		 (not (member (db:test-get-status test)







>







1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
	    (if (not (eq? num-running prev-num-running))
		(debug:print-info 0 *default-log-port* "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!
    (runs:run-post-hook run-id)
    (debug:print-info 1 *default-log-port* "All tests launched")))

(define (runs:calc-fails prereqs-not-met)
  (filter (lambda (test)
	    (and (vector? test) ;; not (string? test))
		 (member (db:test-get-state test) '("INCOMPLETE" "COMPLETED"))
		 (not (member (db:test-get-status test)

Modified server.scm from [45bfab59ba] to [33617f45ac].

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

;; 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 posix-extras matchable)
;; (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)
      #f
      (conc "http://" (car hostport) ":" (cadr hostport))))

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







;;======================================================================
;; S E R V E R
;;======================================================================

;; Call this to start the actual server
;;

|










|
<
>










<
<












>
>
>
>
>
>







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

;; Copyright 2006-2017, 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 posix-extras matchable

     )

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

(declare (unit server))

(declare (uses common))
(declare (uses db))
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
;; (declare (uses synchash))
(declare (uses http-transport))


(declare (uses launch))
(declare (uses daemon))

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

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

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

;;======================================================================
;; P K T S   S T U F F 
;;======================================================================

;; ???

;;======================================================================
;; S E R V E R
;;======================================================================

;; Call this to start the actual server
;;
446
447
448
449
450
451
452













453
454
455
456
457
458
459
(define (server:expiration-timeout)
  (let ((tmo (configf:lookup *configdat* "server" "timeout")))
    (if (and (string? tmo)
	     (common:hms-string->seconds tmo)) ;; BUG: hms-string->seconds is broken, if given "10" returns 0. Also, it doesn't belong in this logic unless the string->number is changed below
        (* 3600 (string->number tmo))
	60)))














;; moving this here as it needs access to db and cannot be in common.
;;
(define (server:writable-watchdog dbstruct)
  (thread-sleep! 0.05) ;; delay for startup
  (let ((legacy-sync  (common:run-sync?))
        (sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300))
	(debug-mode   (debug:debug-mode 1))







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







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
(define (server:expiration-timeout)
  (let ((tmo (configf:lookup *configdat* "server" "timeout")))
    (if (and (string? tmo)
	     (common:hms-string->seconds tmo)) ;; BUG: hms-string->seconds is broken, if given "10" returns 0. Also, it doesn't belong in this logic unless the string->number is changed below
        (* 3600 (string->number tmo))
	60)))

(define (server:get-best-guess-address hostname)
  (let ((res #f))
    (for-each 
     (lambda (adr)
       (if (not (eq? (u8vector-ref adr 0) 127))
	   (set! res adr)))
     ;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME
     (vector->list (hostinfo-addresses (hostname->hostinfo hostname))))
    (string-intersperse 
     (map number->string
	  (u8vector->list
	   (if res res (hostname->ip hostname)))) ".")))

;; moving this here as it needs access to db and cannot be in common.
;;
(define (server:writable-watchdog dbstruct)
  (thread-sleep! 0.05) ;; delay for startup
  (let ((legacy-sync  (common:run-sync?))
        (sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300))
	(debug-mode   (debug:debug-mode 1))

Added show-uncalled-procedures.scm version [27f7128851].



























>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
(include "codescanlib.scm")

(define (show-danglers)
  (let* ((all-scm-files (glob "*.scm"))
         (xref (get-xref all-scm-files))
         (dangling-procs
          (map car (filter (lambda (x) (equal? 1 (length x))) xref))))
    (for-each print dangling-procs) ;; our product.
    ))

(show-danglers)

    

Modified tasks.scm from [7cc529f0c6] to [4926b0b4a0].

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
	    ((none)(loop (conc (current-user-name) "_" area-name) 'user))
	    ((user)(loop (conc (substring (common:get-area-path-signature) 0 4)
			       area-name) 'areasig))
	    (else #f)))))) ;; give up

;; gets mtpg-run-id and syncs the record if different
;;
(define (tasks:run-id->mtpg-run-id dbh cached-info run-id)
  (let* ((runs-ht (hash-table-ref cached-info 'runs))
	 (runinf  (hash-table-ref/default runs-ht run-id #f)))

    (if runinf
	runinf ;; already cached
	(let* ((run-dat    (rmt:get-run-info run-id))               ;; NOTE: get-run-info returns a vector < row header >
	       (run-name   (rmt:get-run-name-from-id run-id))
	       (row        (db:get-rows run-dat))                   ;; yes, this returns a single row
	       (header     (db:get-header run-dat))
	       (state      (db:get-value-by-header row header "state "))
	       (status     (db:get-value-by-header row header "status"))
	       (owner      (db:get-value-by-header row header "owner"))
	       (event-time (db:get-value-by-header row header "event_time"))
	       (comment    (db:get-value-by-header row header "comment"))
	       (fail-count (db:get-value-by-header row header "fail_count"))
	       (pass-count (db:get-value-by-header row header "pass_count"))

	       (contour    (if (args:get-arg "-prepend-contour") (db:get-value-by-header row header "contour")))



	       (keytarg    (if (or (args:get-arg "-prepend-contour") (args:get-arg "-prefix-target"))
	       			(conc "MT_CONTOUR/MT_AREA/" (string-intersperse (rmt:get-keys) "/")) (string-intersperse (rmt:get-keys) "/"))) ;; e.g. version/iteration/platform
	       (target     (if (or (args:get-arg "-prepend-contour") (args:get-arg "-prefix-target")) 
	       			(conc (or (args:get-arg "-prefix-target") (conc contour "/" (common:get-area-name) "/")) (rmt:get-target run-id)) (rmt:get-target run-id)))                 ;; e.g. v1.63/a3e1/ubuntu
	       (spec-id    (pgdb:get-ttype dbh keytarg))
	       (new-run-id (pgdb:get-run-id dbh spec-id target run-name))



	       ;; (area-id    (db:get-value-by-header row header "area_id)"))
	       )
	  (if new-run-id
	      (begin ;; let ((run-record (pgdb:get-run-info dbh new-run-id))
		(hash-table-set! runs-ht run-id new-run-id)
		;; ensure key fields are up to date
		(pgdb:refresh-run-info
		 dbh
		 new-run-id
		 state status owner event-time comment fail-count pass-count)
		new-run-id)
	      (if (handle-exceptions
		      exn
		      (begin (print-call-chain) #f)


		    (pgdb:insert-run
		     dbh
		     spec-id target run-name state status owner event-time comment fail-count pass-count)) ;; area-id))
		  (tasks:run-id->mtpg-run-id dbh cached-info run-id)
		  #f))))))















































































(define (tasks:sync-tests-data dbh cached-info test-ids)
  (let ((test-ht (hash-table-ref cached-info 'tests)))
    (for-each
     (lambda (test-id)
       (let* ((test-info    (rmt:get-test-info-by-id #f test-id))
	      (run-id       (db:test-get-run_id    test-info)) ;; look these up in db_records.scm
	      (test-id      (db:test-get-id        test-info))
	      (test-name    (db:test-get-testname  test-info))
	      (item-path    (db:test-get-item-path test-info))
	      (state        (db:test-get-state     test-info))
	      (status       (db:test-get-status    test-info))
	      (host         (db:test-get-host      test-info))
	      (cpuload      (db:test-get-cpuload   test-info))
	      (diskfree     (db:test-get-diskfree  test-info))
	      (uname        (db:test-get-uname     test-info))
	      (run-dir      (db:test-get-rundir    test-info))
	      (log-file     (db:test-get-final_logf test-info))
	      (run-duration (db:test-get-run_duration test-info))
	      (comment      (db:test-get-comment   test-info))
	      (event-time   (db:test-get-event_time test-info))
	      (archived     (db:test-get-archived  test-info))
	      (pgdb-run-id  (tasks:run-id->mtpg-run-id dbh cached-info run-id))




	      (pgdb-test-id (pgdb:get-test-id dbh pgdb-run-id test-name item-path)))

	 ;; "id"           "run_id"        "testname"  "state"      "status"      "event_time"
	 ;; "host"         "cpuload"       "diskfree"  "uname"      "rundir"      "item_path"
	 ;; "run_duration" "final_logf"    "comment"   "shortdir"   "attemptnum"  "archived"


	 (if pgdb-test-id ;; have a record
	     (begin ;; let ((key-name (conc run-id "/" test-name "/" item-path)))
	       (hash-table-set! test-ht test-id pgdb-test-id)
	       (print "Updating existing test with run-id: " run-id " and test-id: " test-id)
	       (pgdb:update-test dbh pgdb-test-id pgdb-run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived))


	     (pgdb:insert-test dbh pgdb-run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived))
	 ))



     test-ids)))

;; get runs changed since last sync
;; (define (tasks:sync-test-data dbh cached-info area-info)
;;   (let* ((

(define (tasks:sync-to-postgres configdat dest)
  (let* ((dbh         (pgdb:open configdat dbname: dest))
	 (area-info   (pgdb:get-area-by-path dbh *toppath*))
	 (cached-info (make-hash-table))
	 (start       (current-seconds)))
    (for-each (lambda (dtype)
		(hash-table-set! cached-info dtype (make-hash-table)))
	      '(runs targets tests))
    (hash-table-set! cached-info 'start start) ;; when done we'll set sync times to this
    (if area-info
	(let* ((last-sync-time (vector-ref area-info 3))
	       (changed        (rmt:get-changed-record-ids last-sync-time))
	       (run-ids        (alist-ref 'runs       changed))
	       (test-ids       (alist-ref 'tests      changed))
	       (test-step-ids  (alist-ref 'test_steps changed))
	       (test-data-ids  (alist-ref 'test_data  changed))
	       (run-stat-ids   (alist-ref 'run_stats  changed)))
	  (print "area-info: " area-info)

	  (if (not (null? test-ids))
	      (begin
		(print "Syncing " (length test-ids) " changed tests")


		(tasks:sync-tests-data dbh cached-info test-ids)))



	  (pgdb:write-sync-time dbh area-info start))
	(if (tasks:set-area dbh configdat)
	    (tasks:sync-to-postgres configdat dest)
	    (begin
	      (debug:print 0 *default-log-port* "ERROR: unable to create an area record")
	      #f)))))








|

|
>













>
|
>
>
>





|
<
<
<


|






|



|
>
>


|
|


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




















|
>
>
>
>
|
>



>
>
|

<


>
>
|
<
>
>
>













|










>


|
>
>
|
>
>
>







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
	    ((none)(loop (conc (current-user-name) "_" area-name) 'user))
	    ((user)(loop (conc (substring (common:get-area-path-signature) 0 4)
			       area-name) 'areasig))
	    (else #f)))))) ;; give up

;; gets mtpg-run-id and syncs the record if different
;;
(define (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info)
  (let* ((runs-ht (hash-table-ref cached-info 'runs))
	 (runinf  (hash-table-ref/default runs-ht run-id #f))
         (area-id (vector-ref area-info 0)))
    (if runinf
	runinf ;; already cached
	(let* ((run-dat    (rmt:get-run-info run-id))               ;; NOTE: get-run-info returns a vector < row header >
	       (run-name   (rmt:get-run-name-from-id run-id))
	       (row        (db:get-rows run-dat))                   ;; yes, this returns a single row
	       (header     (db:get-header run-dat))
	       (state      (db:get-value-by-header row header "state "))
	       (status     (db:get-value-by-header row header "status"))
	       (owner      (db:get-value-by-header row header "owner"))
	       (event-time (db:get-value-by-header row header "event_time"))
	       (comment    (db:get-value-by-header row header "comment"))
	       (fail-count (db:get-value-by-header row header "fail_count"))
	       (pass-count (db:get-value-by-header row header "pass_count"))
               (db-contour (db:get-value-by-header row header "contour"))
	       (contour    (if (args:get-arg "-prepend-contour") 
                                 (if (> (string-length  db-contour) 0) 
                                            db-contour
					    (args:get-arg "-contour"))))
	       (keytarg    (if (or (args:get-arg "-prepend-contour") (args:get-arg "-prefix-target"))
	       			(conc "MT_CONTOUR/MT_AREA/" (string-intersperse (rmt:get-keys) "/")) (string-intersperse (rmt:get-keys) "/"))) ;; e.g. version/iteration/platform
	       (target     (if (or (args:get-arg "-prepend-contour") (args:get-arg "-prefix-target")) 
	       			(conc (or (args:get-arg "-prefix-target") (conc contour "/" (common:get-area-name) "/")) (rmt:get-target run-id)) (rmt:get-target run-id)))                 ;; e.g. v1.63/a3e1/ubuntu
	       (spec-id    (pgdb:get-ttype dbh keytarg))
	       (new-run-id (pgdb:get-run-id dbh spec-id target run-name area-id))



	       ;; (area-id    (db:get-value-by-header row header "area_id)"))
	       )
          (if new-run-id
	      (begin ;; let ((run-record (pgdb:get-run-info dbh new-run-id))
		(hash-table-set! runs-ht run-id new-run-id)
		;; ensure key fields are up to date
		(pgdb:refresh-run-info
		 dbh
		 new-run-id
		 state status owner event-time comment fail-count pass-count area-id)
		new-run-id)
	      (if (handle-exceptions
		      exn
		      (begin (print-call-chain)
                              (print ((condition-property-accessor 'exn 'message) exn))     
			#f)
		    (pgdb:insert-run
		     dbh
		     spec-id target run-name state status owner event-time comment fail-count pass-count  area-id))
		       (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info)
		  #f))))))


(define (tasks:sync-test-steps dbh cached-info test-step-ids)
  (let ((test-ht (hash-table-ref cached-info 'tests))
        (step-ht (hash-table-ref cached-info 'steps)))
    (for-each
     (lambda (test-step-id)
        (let* ((test-step-info  (rmt:get-steps-info-by-id test-step-id))
               (step-id (tdb:step-get-id test-step-info))
               (test-id  (tdb:step-get-test_id    test-step-info))   
	       (stepname (tdb:step-get-stepname  test-step-info))
	       (state (tdb:step-get-state test-step-info))	
	       (status (tdb:step-get-status test-step-info))	
	       (event_time (tdb:step-get-event_time  test-step-info))	
	       (comment  (tdb:step-get-comment test-step-info))	
	       (logfile (tdb:step-get-logfile test-step-info))	
	       (pgdb-test-id  (hash-table-ref/default test-ht test-id #f))
               (pgdb-step-id (if pgdb-test-id 
                                 (pgdb:get-test-step-id dbh pgdb-test-id stepname state)
                                  #f)))
    (if step-id
      (begin  
        (if pgdb-test-id
           (begin 
                (if  pgdb-step-id
                   (begin
                    (print "Updating existing test-step with test-id: " test-id " and step-id " step-id)
                    (pgdb:update-test-step dbh pgdb-step-id pgdb-test-id stepname state status event_time comment logfile))
                    (begin
 		      (print "Inserting test-step with test-id: " test-id " and step-id " step-id)
                      (pgdb:insert-test-step dbh pgdb-test-id stepname state status event_time comment logfile )
                      (set! pgdb-step-id  (pgdb:get-test-step-id dbh pgdb-test-id stepname state))))
                (hash-table-set! step-ht step-id pgdb-step-id ))
           (print "Error: Test not cashed")))
      (print "Error: Could not get test step info for step id " test-step-id ))))	;; this is a wierd senario need to debug      	
   test-step-ids)))

(define (tasks:sync-test-gen-data dbh cached-info test-data-ids)
  (let ((test-ht (hash-table-ref cached-info 'tests))
        (data-ht (hash-table-ref cached-info 'data)))
    (for-each
     (lambda (test-data-id)
        (let* ((test-data-info  (rmt:get-data-info-by-id test-data-id))
               (data-id (db:test-data-get-id  test-data-info))
               (test-id  (db:test-data-get-test_id   test-data-info))   
	       (category  (db:test-data-get-category  test-data-info))
	       (variable  (db:test-data-get-variable test-data-info))	
	       (value (db:test-data-get-value  test-data-info))	
               (expected (db:test-data-get-expected  test-data-info))
               (tol (db:test-data-get-tol  test-data-info))
               (units (db:test-data-get-units  test-data-info))     
	       (comment  (db:test-data-get-comment test-data-info))	
               (status (db:test-data-get-status test-data-info))	
	       (type (db:test-data-get-type test-data-info))	
	       (pgdb-test-id  (hash-table-ref/default test-ht test-id #f))
               (pgdb-data-id (if pgdb-test-id 
                                 (pgdb:get-test-data-id dbh pgdb-test-id category variable)
                                  #f)))
    (if data-id
      (begin
        (if pgdb-test-id
           (begin 
                (if  pgdb-data-id
                   (begin
                    (print "Updating existing test-data with test-id: " test-id " and data-id " data-id)
                    (pgdb:update-test-data dbh pgdb-data-id pgdb-test-id  category variable value expected tol units comment status type))
                    (begin
 		      (print "Inserting test-data with test-id: " test-id " and data-id " data-id)
                      (pgdb:insert-test-data dbh pgdb-test-id category variable value expected tol units comment status type )
                      (set! pgdb-data-id  (pgdb:get-test-data-id dbh pgdb-test-id  category variable))))
                (hash-table-set! data-ht data-id pgdb-data-id ))
             (begin
                 (print "Error: Test not in pgdb"))))

      (print "Error: Could not get test data info for data id " test-data-id ))))	;; this is a wierd senario need to debug      	
   test-data-ids)))



(define (tasks:sync-tests-data dbh cached-info test-ids area-info)
  (let ((test-ht (hash-table-ref cached-info 'tests)))
    (for-each
     (lambda (test-id)
       (let* ((test-info    (rmt:get-test-info-by-id #f test-id))
	      (run-id       (db:test-get-run_id    test-info)) ;; look these up in db_records.scm
	      (test-id      (db:test-get-id        test-info))
	      (test-name    (db:test-get-testname  test-info))
	      (item-path    (db:test-get-item-path test-info))
	      (state        (db:test-get-state     test-info))
	      (status       (db:test-get-status    test-info))
	      (host         (db:test-get-host      test-info))
	      (cpuload      (db:test-get-cpuload   test-info))
	      (diskfree     (db:test-get-diskfree  test-info))
	      (uname        (db:test-get-uname     test-info))
	      (run-dir      (db:test-get-rundir    test-info))
	      (log-file     (db:test-get-final_logf test-info))
	      (run-duration (db:test-get-run_duration test-info))
	      (comment      (db:test-get-comment   test-info))
	      (event-time   (db:test-get-event_time test-info))
	      (archived     (db:test-get-archived  test-info))
	      (pgdb-run-id  (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info))
                
	      (pgdb-test-id (if pgdb-run-id 
				(begin
                                  ;(print pgdb-run-id)    
                                 (pgdb:get-test-id dbh pgdb-run-id test-name item-path))
                                 #f)))
	 ;; "id"           "run_id"        "testname"  "state"      "status"      "event_time"
	 ;; "host"         "cpuload"       "diskfree"  "uname"      "rundir"      "item_path"
	 ;; "run_duration" "final_logf"    "comment"   "shortdir"   "attemptnum"  "archived"
         (if pgdb-run-id
           (begin
	   (if pgdb-test-id ;; have a record
	     (begin ;; let ((key-name (conc run-id "/" test-name "/" item-path)))

	       (print "Updating existing test with run-id: " run-id " and test-id: " test-id)
	       (pgdb:update-test dbh pgdb-test-id pgdb-run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived))
	     (begin 
                 (print "Inserting test with run-id: " run-id " and test-id: " test-id)
                (pgdb:insert-test dbh pgdb-run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived)

                (set! pgdb-test-id (pgdb:get-test-id dbh pgdb-run-id test-name item-path))))
               (hash-table-set! test-ht test-id pgdb-test-id))
              (print "WARNING: Skipping run with run-id:" run-id ". This run was created after privious sync and removed before this sync."))))
     test-ids)))

;; get runs changed since last sync
;; (define (tasks:sync-test-data dbh cached-info area-info)
;;   (let* ((

(define (tasks:sync-to-postgres configdat dest)
  (let* ((dbh         (pgdb:open configdat dbname: dest))
	 (area-info   (pgdb:get-area-by-path dbh *toppath*))
	 (cached-info (make-hash-table))
	 (start       (current-seconds)))
    (for-each (lambda (dtype)
		(hash-table-set! cached-info dtype (make-hash-table)))
	      '(runs targets tests steps data))
    (hash-table-set! cached-info 'start start) ;; when done we'll set sync times to this
    (if area-info
	(let* ((last-sync-time (vector-ref area-info 3))
	       (changed        (rmt:get-changed-record-ids last-sync-time))
	       (run-ids        (alist-ref 'runs       changed))
	       (test-ids       (alist-ref 'tests      changed))
	       (test-step-ids  (alist-ref 'test_steps changed))
	       (test-data-ids  (alist-ref 'test_data  changed))
	       (run-stat-ids   (alist-ref 'run_stats  changed)))
	  (print "area-info: " area-info)
            
	  (if (not (null? test-ids))
	      (begin
		(print "Syncing " (length test-step-ids) " changed tests")
                ;;Assumption here is that if test-step or test data is changed then the test last update time is changed 
                ;; not syncing run stats at this time as they can be derived from tests table.
		(tasks:sync-tests-data dbh cached-info test-ids area-info)
                ;(exit)   
                (tasks:sync-test-steps dbh cached-info test-step-ids)
                (tasks:sync-test-gen-data dbh cached-info test-data-ids)))
	  (pgdb:write-sync-time dbh area-info start))
	(if (tasks:set-area dbh configdat)
	    (tasks:sync-to-postgres configdat dest)
	    (begin
	      (debug:print 0 *default-log-port* "ERROR: unable to create an area record")
	      #f)))))

Modified tcmt.scm from [5f5e90a486] to [75ab8b7c92].

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
      ((COMPLETED)
       (if (not startp) ;; start stanza never printed
	   (begin
	     (print "##teamcity[testStarted " tcname flowid tstmp "]")
	     (testdat-start-printed-set! tdat #t)))
       (if (not endp)
	   (begin
	     (if (member status '(PASS WARN SKIP WAIVED))
		 (print "##teamcity[testFinished" tcname flowid comment details duration "]")
		 (print "##teamcity[testFailed  " tcname flowid comment details "]"))

	     (testdat-end-printed-set! tdat #t))))
      (else
       (if flush-mode
	   (begin
	     (if (not startp)
		 (begin
		   (print "##teamcity[testStarted " tcname flowid tstmp "]")
		   (testdat-start-printed-set! tdat #t)))
	     (if (not endp)
		 (begin
		   (print "##teamcity[testFailed  " tcname flowid comment details "]")

		   (testdat-end-printed-set! tdat #t)))))))
    ;; (print "ERROR: tc-type \"" (testdat-tc-type tdat) "\" not recognised for " tcname)))
    (flush-output)))

;; ;; returns values: flag newlst
;; (define (remove-duplicate-completed  tdats)
;;   (let* ((flag       #f)







|
<

>











>







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
      ((COMPLETED)
       (if (not startp) ;; start stanza never printed
	   (begin
	     (print "##teamcity[testStarted " tcname flowid tstmp "]")
	     (testdat-start-printed-set! tdat #t)))
       (if (not endp)
	   (begin
	     (if (not (member status '(PASS WARN SKIP WAIVED)))

		 (print "##teamcity[testFailed  " tcname flowid comment details "]"))
             (print "##teamcity[testFinished" tcname flowid comment details duration "]")
	     (testdat-end-printed-set! tdat #t))))
      (else
       (if flush-mode
	   (begin
	     (if (not startp)
		 (begin
		   (print "##teamcity[testStarted " tcname flowid tstmp "]")
		   (testdat-start-printed-set! tdat #t)))
	     (if (not endp)
		 (begin
		   (print "##teamcity[testFailed  " tcname flowid comment details "]")
                   (print "##teamcity[testFinished" tcname flowid comment details duration "]")
		   (testdat-end-printed-set! tdat #t)))))))
    ;; (print "ERROR: tc-type \"" (testdat-tc-type tdat) "\" not recognised for " tcname)))
    (flush-output)))

;; ;; returns values: flag newlst
;; (define (remove-duplicate-completed  tdats)
;;   (let* ((flag       #f)

Modified testnanomsg/req-rep.scm from [d17a548c7a] to [4b0d8cd65b].

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)



>

<
<
<
|





>
>
>
>









>





|
|

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
;; watch nanomsg's pipeline load-balancer in action.
(use nanomsg)

;; client
(define req   (nn-socket 'req))



(nn-connect req  "inproc://test") 

(define (client-send-receive soc msg)
  (nn-send soc msg)
  (nn-recv soc))

;; server
(define rep   (nn-socket 'rep))
(nn-bind    rep  "inproc://test")

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

;; client 
(print (client-send-receive req "Matt"))
(print (client-send-receive req "Tom"))

;; (client-send-receive req "quit")

(nn-close req) ;; client
(nn-close rep) ;; server
(exit)

Modified tests/Makefile from [3cbc059672] to [ea14a7a617].

171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
	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 build
	mkdir -p fullrun/tmp/mt_runs fullrun/tmp/mt_links /tmp/$(USER)/adisk1
	rm -f */logging.db
	touch cleanprep

fullprep : cleanprep
	cd fullrun;$(MEGATEST) -remove-runs :runname $(RUNNAME)% -target %/%/% -testpatt %/%
	cd fullrun;$(BINPATH)/dashboard -rows 15 &








|







171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
	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 build
	mkdir -p fullrun/tmp/mt_runs fullrun/tmp/mt_links /tmp/$(USER)/adisk1 fullrun/logs
	rm -f */logging.db
	touch cleanprep

fullprep : cleanprep
	cd fullrun;$(MEGATEST) -remove-runs :runname $(RUNNAME)% -target %/%/% -testpatt %/%
	cd fullrun;$(BINPATH)/dashboard -rows 15 &

Modified tests/fullrun/megatest.config from [73c3d86962] to [9422e2422a].

45
46
47
48
49
50
51
52


53
54
55
56
57
58
59
# this may save a few milliseconds on launching tests
# launchwait no
waivercommentpatt ^WW\d+ [a-z].*
incomplete-timeout 1

# wait 0.5 seconds between launching every process
#
launch-delay 0.5



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







|
>
>







45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
# this may save a few milliseconds on launching tests
# launchwait no
waivercommentpatt ^WW\d+ [a-z].*
incomplete-timeout 1

# wait 0.5 seconds between launching every process
#
# launch-delay 0.5
launch-delay 0


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

Modified tests/fullrun/runconfigs.config from [cf88798291] to [298d45b09b].

1
2
3
4
5
6
7
8
9
10
11
12
[default]
SOMEVAR This should show up in SOMEVAR3
VARNOVAL
VARNOVAL_WITHSPACE
QUICK %

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




|







1
2
3
4
5
6
7
8
9
10
11
12
[default]
SOMEVAR This should show up in SOMEVAR3
VARNOVAL
VARNOVAL_WITHSPACE
QUICKPATT test_mt_vars,test2,priority_9

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

Added trackback.scm version [4011884617].









































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
(include "codescanlib.scm")

;; show call paths for named procedure
(define (traceback-proc in-procname)
  (letrec* ((all-scm-files (glob "*.scm"))
            (xref (get-xref all-scm-files))
            (have (alist-ref (string->symbol in-procname) xref eq? #f))
            (lookup (lambda (path procname depth)
                      (let* ((upcone-temp (filter (lambda (x)
                                                    (eq? procname (car x)))
                                                  xref))
                             (upcone-temp2 (cond
                                            ((null? upcone-temp) '())
                                            (else (cdar upcone-temp))))
                             (upcone (filter
                                      (lambda (x) (not (eq? x procname)))
                                      upcone-temp2))
                             (uppath (cons procname path))
                             (updepth (add1 depth)))
                        (if (null? upcone)
                            (print  uppath)
                            (for-each (lambda (x)
                                        (if (not (member procname path))
                                            (lookup uppath x updepth) ))
                                      upcone))))))
           (if have
               (lookup '() (string->symbol in-procname) 0)
               (print "no such func - "in-procname))))


(if (eq? 1 (length (command-line-arguments)))
    (traceback-proc (car (command-line-arguments)))
    (print "Usage: trackback <procedure name>"))

(exit 0)
    

Modified utils/installall.sh from [5cb897ce36] to [c5681b62d5].

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
echo You are using PREFIX=$PREFIX
echo You are using proxy="$proxy"
echo 
echo "Set additional_libpath to help find gtk or other libraries, don't forget a leading :"

SYSTEM_TYPE=$(lsb_release -irs |tr ' ' '_' |tr '\n' '-')$(uname -i)-$OPTION

CHICKEN_VERSION=4.11.0
CHICKEN_BASEVER=4.11.0

# Set up variables
#
case $SYSTEM_TYPE in
Ubuntu-17.04-x86_64-std)
	KTYPE=32
	CDVER=5.10
	IUPVER=3.17
	IMVER=3.11
	CHICKEN_VERSION=4.12.0
	CHICKEN_BASEVER=4.12.0
	;;
Ubuntu-16.04-x86_64-std)
	KTYPE=32
	CDVER=5.10
	IUPVER=3.17
	IMVER=3.11
	CHICKEN_VERSION=4.12.0
	CHICKEN_BASEVER=4.12.0
	;;
Ubuntu-16.04-i686-std)
	KTYPE=32
	CDVER=5.10
	IUPVER=3.17
	IMVER=3.11
        CHICKEN_VERSION=4.12.0
        CHICKEN_BASEVER=4.12.0
	;;
SUSE_LINUX_11-x86_64-std)
  KTYPE=26g4 
	CDVER=5.10
	IUPVER=3.17
	IMVER=3.11
  ;;
CentOS_5.11-x86_64-std)
  KTYPE=24g3 
  CDVER=5.4.1
  IUPVER=3.5
  IMVER=3.6.3
  ;; 







|
|






|
|
|





|
|
|





|
|
|





|
|
|







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
echo You are using PREFIX=$PREFIX
echo You are using proxy="$proxy"
echo 
echo "Set additional_libpath to help find gtk or other libraries, don't forget a leading :"

SYSTEM_TYPE=$(lsb_release -irs |tr ' ' '_' |tr '\n' '-')$(uname -i)-$OPTION

CHICKEN_VERSION=4.12.0
CHICKEN_BASEVER=4.12.0

# Set up variables
#
case $SYSTEM_TYPE in
Ubuntu-17.04-x86_64-std)
	KTYPE=32
	CDVER=5.11.1
	IUPVER=3.22
	IMVER=3.12
	CHICKEN_VERSION=4.12.0
	CHICKEN_BASEVER=4.12.0
	;;
Ubuntu-16.04-x86_64-std)
	KTYPE=32
	CDVER=5.11.1
	IUPVER=3.22
	IMVER=3.12
	CHICKEN_VERSION=4.12.0
	CHICKEN_BASEVER=4.12.0
	;;
Ubuntu-16.04-i686-std)
	KTYPE=32
	CDVER=5.11.1
	IUPVER=3.22
	IMVER=3.12
        CHICKEN_VERSION=4.12.0
        CHICKEN_BASEVER=4.12.0
	;;
SUSE_LINUX_11-x86_64-std)
  KTYPE=26g4 
	CDVER=5.11.1
	IUPVER=3.22
	IMVER=3.12
  ;;
CentOS_5.11-x86_64-std)
  KTYPE=24g3 
  CDVER=5.4.1
  IUPVER=3.5
  IMVER=3.6.3
  ;; 
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
cd $BUILDHOME
#if [[ ! -e 1.0.0.tar.gz ]];then
#  wget --no-check-certificate https://github.com/nanomsg/nanomsg/archive/1.0.0.tar.gz 
#  mv 1.0.0 1.0.0.tar.gz
#fi
if ! [[ -e $PREFIX/lib64/libnanomsg.so.1.0.0 ]]; then
        wget --no-check-certificate https://github.com/nanomsg/nanomsg/archive/1.0.0.tar.gz 
        #mv 1.0.0 1.0.0.tar.gz
	tar xf 1.0.0.tar.gz 
	cd nanomsg-1.0.0
	./configure --prefix=$PREFIX
	make
	make install
	CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" $CHICKEN_INSTALL $PROX nanomsg
fi







|







174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
cd $BUILDHOME
#if [[ ! -e 1.0.0.tar.gz ]];then
#  wget --no-check-certificate https://github.com/nanomsg/nanomsg/archive/1.0.0.tar.gz 
#  mv 1.0.0 1.0.0.tar.gz
#fi
if ! [[ -e $PREFIX/lib64/libnanomsg.so.1.0.0 ]]; then
        wget --no-check-certificate https://github.com/nanomsg/nanomsg/archive/1.0.0.tar.gz 
        mv 1.0.0 1.0.0.tar.gz
	tar xf 1.0.0.tar.gz 
	cd nanomsg-1.0.0
	./configure --prefix=$PREFIX
	make
	make install
	CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" $CHICKEN_INSTALL $PROX nanomsg
fi
200
201
202
203
204
205
206
207













208
209
210
211
212
213
214
215
216
217
218
	if ! [[ -e $PREFIX/bin/sqlite3 ]] ; then
	    if [[ -e tgz/sqlite-autoconf-$SQLITE3_VERSION.tar.gz ]]; then
		tar xfz tgz/sqlite-autoconf-$SQLITE3_VERSION.tar.gz 
		(cd sqlite-autoconf-$SQLITE3_VERSION;./configure --prefix=$PREFIX;make;make install)
	    fi
	fi
fi
















cd $BUILDHOME
for egg in "sqlite3" sql-de-lite # nanomsg
do
	echo "Installing $egg"
	CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib -L$PREFIX/lib64"  $CHICKEN_INSTALL $PROX -keep-installed $egg
	#CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib -L$PREFIX/lib64"  $CHICKEN_INSTALL $PROX $egg
	if [ $? -ne 0 ]; then
		echo "$egg failed to install"
		exit 1







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



|







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
	if ! [[ -e $PREFIX/bin/sqlite3 ]] ; then
	    if [[ -e tgz/sqlite-autoconf-$SQLITE3_VERSION.tar.gz ]]; then
		tar xfz tgz/sqlite-autoconf-$SQLITE3_VERSION.tar.gz 
		(cd sqlite-autoconf-$SQLITE3_VERSION;./configure --prefix=$PREFIX;make;make install)
	    fi
	fi
fi
if ! [[ -e $PREFIX/bin/pg_config ]]; then
	echo Install Postgresql
	pgsql_tgz=postgresql-9.6.4.tar.gz
	if ! [[ -e tgz/$pgsql_tgz ]]; then
	  wget -c https://ftp.postgresql.org/pub/source/v9.6.4/$pgsql_tgz
	  mv $pgsql_tgz tgz
	fi
	if ! [[ -e $PREFIX/bin/pg_config ]]; then
	  if [[ -e tgz/$pgsql_tgz ]]; then
	    tar xfz tgz/$pgsql_tgz
	    (cd postgresql-9.6.4; ./configure --prefix=$PREFIX --with-openssl; make; make install)
	  fi
	fi
fi


cd $BUILDHOME
for egg in "sqlite3" sql-de-lite nanomsg
do
	echo "Installing $egg"
	CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib -L$PREFIX/lib64"  $CHICKEN_INSTALL $PROX -keep-installed $egg
	#CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib -L$PREFIX/lib64"  $CHICKEN_INSTALL $PROX $egg
	if [ $? -ne 0 ]; then
		echo "$egg failed to install"
		exit 1
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
	alist-lib ansi-escape-sequences args basic-sequences bindings chicken-doc chicken-doc-cmd \
	cock condition-utils debug define-record-and-printer easyffi easyffi-base \
	expand-full ezxdisp filepath foof-loop ini-file irc lalr lazy-seq \
	locale locale-builtin locale-categories locale-components locale-current locale-posix \
	locale-timezone loops low-level-macros procedural-macros refdb rfc3339 scsh-process \
	sexp-diff sha1 shell slice srfi-101 srfi-19 srfi-19-core srfi-19-date srfi-19-io \
	srfi-19-period srfi-19-support srfi-19-time srfi-19-timezone srfi-29 srfi-37 srfi-78 syslog \
	udp uuid uuid-lib zlib

do
	echo "Installing $egg"
	$CHICKEN_INSTALL $PROX -keep-installed $egg
	#$CHICKEN_INSTALL $PROX $egg
	if [ $? -ne 0 ]; then
		echo "$egg failed to install"
		exit 1
	fi
done

if [[ -e `which mysql_config` ]]; then
  $CHICKEN_INSTALL $PROX -keep-installed mysql-client
fi

cd $BUILDHOME
cd `$PREFIX/bin/csi -p '(chicken-home)'`
curl http://3e8.org/pub/chicken-doc/chicken-doc-repo.tgz | tar zx
cd $BUILDHOME



# $CHICKEN_INSTALL $PROX sqlite3
cd $BUILDHOME
# # IUP versions
# if [[ x$USEOLDIUP == "x" ]];then
#   CDVER=5.10
#   IUPVER=3.17
#   IMVER=3.11
# else
#   CDVER=5.10
#   IUPVER=3.17
#   IMVER=3.11
# fi
# if [[ x$KTYPE == "x24g3" ]];then
#   CDVER=5.4.1
#   IUPVER=3.5
#   IMVER=3.6.3
# fi

if [[ `uname -a | grep x86_64` == "" ]]; then 
    export ARCHSIZE=''
else
    export ARCHSIZE=64_
fi
    # export files="cd-5.4.1_Linux${KTYPE}_lib.tar.gz im-3.6.3_Linux${KTYPE}_lib.tar.gz iup-3.5_Linux${KTYPE}_lib.tar.gz"







|










<

|







<
<


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







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
	alist-lib ansi-escape-sequences args basic-sequences bindings chicken-doc chicken-doc-cmd \
	cock condition-utils debug define-record-and-printer easyffi easyffi-base \
	expand-full ezxdisp filepath foof-loop ini-file irc lalr lazy-seq \
	locale locale-builtin locale-categories locale-components locale-current locale-posix \
	locale-timezone loops low-level-macros procedural-macros refdb rfc3339 scsh-process \
	sexp-diff sha1 shell slice srfi-101 srfi-19 srfi-19-core srfi-19-date srfi-19-io \
	srfi-19-period srfi-19-support srfi-19-time srfi-19-timezone srfi-29 srfi-37 srfi-78 syslog \
	udp uuid uuid-lib zlib postgresql

do
	echo "Installing $egg"
	$CHICKEN_INSTALL $PROX -keep-installed $egg
	#$CHICKEN_INSTALL $PROX $egg
	if [ $? -ne 0 ]; then
		echo "$egg failed to install"
		exit 1
	fi
done

if [[ -e `which mysql_config` ]]; then
  $CHICKEN_INSTALL $PROX mysql-client
fi

cd $BUILDHOME
cd `$PREFIX/bin/csi -p '(chicken-home)'`
curl http://3e8.org/pub/chicken-doc/chicken-doc-repo.tgz | tar zx
cd $BUILDHOME



# $CHICKEN_INSTALL $PROX sqlite3
cd $BUILDHOME
















if [[ `uname -a | grep x86_64` == "" ]]; then 
    export ARCHSIZE=''
else
    export ARCHSIZE=64_
fi
    # export files="cd-5.4.1_Linux${KTYPE}_lib.tar.gz im-3.6.3_Linux${KTYPE}_lib.tar.gz iup-3.5_Linux${KTYPE}_lib.tar.gz"
337
338
339
340
341
342
343


344
345
346
347
348
349
350
	cp -f hs $PREFIX/bin/hs 
	cd ../mutils
	$PREFIX/bin/chicken-install
	cd ../dbi 
	$PREFIX/bin/chicken-install
	cd ../margs
	$PREFIX/bin/chicken-install


fi
cd $BUILDHOME

if ! [[ -e $PREFIX/bin/stmlrun ]] ; then
	#fossil clone http://www.kiatoa.com/fossils/stml stml.fossil
	wget -c -O stml.tar.gz 'http://www.kiatoa.com/fossils/stml/tarball?name=stml&uuid=trunk'
	tar -xzf stml.tar.gz







>
>







332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
	cp -f hs $PREFIX/bin/hs 
	cd ../mutils
	$PREFIX/bin/chicken-install
	cd ../dbi 
	$PREFIX/bin/chicken-install
	cd ../margs
	$PREFIX/bin/chicken-install
	cd ../pkts
	$PREFIX/bin/chicken-install
fi
cd $BUILDHOME

if ! [[ -e $PREFIX/bin/stmlrun ]] ; then
	#fossil clone http://www.kiatoa.com/fossils/stml stml.fossil
	wget -c -O stml.tar.gz 'http://www.kiatoa.com/fossils/stml/tarball?name=stml&uuid=trunk'
	tar -xzf stml.tar.gz
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
export CSCLIBS=`echo $LD_LIBRARY_PATH | sed 's/:/ -L/g'`
IUPEGGVER='iup'
if [[ $IUPVER == "3.5" ]]; then
  IUPEGGVER='iup:1.2.1'
fi

#CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -feature disable-iup-web iup
CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" $CHICKEN_INSTALL $PROX -D no-library-checks -feature disable-iup-web $IUPEGGVER

# CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -feature disable-iup-web -deploy -prefix $DEPLOYTARG iup
# iup:1.0.2 
CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" $CHICKEN_INSTALL $PROX -D no-library-checks canvas-draw
# CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -deploy -prefix $DEPLOYTARG canvas-draw

cd $BUILDHOME  







|







361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
export CSCLIBS=`echo $LD_LIBRARY_PATH | sed 's/:/ -L/g'`
IUPEGGVER='iup'
if [[ $IUPVER == "3.5" ]]; then
  IUPEGGVER='iup:1.2.1'
fi

#CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -feature disable-iup-web iup
CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" $CHICKEN_INSTALL $PROX -D no-library-checks -feature disable-iup-web -feature disable-iup-pplot $IUPEGGVER

# CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -feature disable-iup-web -deploy -prefix $DEPLOYTARG iup
# iup:1.0.2 
CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" $CHICKEN_INSTALL $PROX -D no-library-checks canvas-draw
# CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -deploy -prefix $DEPLOYTARG canvas-draw

cd $BUILDHOME  

Modified utils/plot-code.scm from [2b66df6bfd] to [6d50d1bd96].

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
#!/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 (cdr (cddddr (argv))))

(let ((targdat (cadddr (argv))))
  (if (equal? targdat "-")
      (set! targs files)
      (set! targs (string-split targdat ","))))

(define function-patt (car (cdr (cdddr (argv)))))
(define function-rx   (regexp function-patt))
(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))










|

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

|




|







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
#!/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 srfi-1 data-structures posix)

;;                 1                   2        remainder
;; plot-code file1.scm,file2.scm... fn-regex file1.scm file2.scm ...

(define targs #f)

(define args (argv))
(if (< (length args) 2) ;; no args provided
    (begin
       (print "Usage: plot-code file1.scm,file2.scm... 'your.*regex' file3.scm file4.scm file5.scm  ...")
       (exit)))

(define files (cdddr args))

(let ((targdat (cadr args)))
  (if (equal? targdat "-")
      (set! targs files)
      (set! targs (string-split targdat ","))))

(define function-patt (caddr args))
(define function-rx   (regexp function-patt))
(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))

Added utils/whodunit.scm version [862906085a].

































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
(use posix srfi-69)

(define *numsamples* (or (and (> (length (argv)) 1)
                              (string->number (cadr (argv))))
                         3))

(define (topdata)
  (with-input-from-pipe
   (conc "top -b -n " *numsamples* " -d 0.1")
   read-lines))

(define (cleanup-data topdat)list
  (let loop ((hed (car topdat))
              (tal (cdr topdat))
              (res '()))
    (let* ((line-list (string-split hed))
           (nums      (map (lambda (indat)(or (string->number indat) indat)) line-list))
           (not-data  (or (null? nums)
                          (not (number? (car nums)))))
           (new-res   (if not-data res (cons nums res))))
      (if (null? tal)
          new-res
          (loop (car tal)(cdr tal) new-res)))))

(print "Getting " *numsamples* " samples of cpu usage data.")
(define data (cleanup-data (topdata)))
(define pidhash  (make-hash-table))
(define userhash (make-hash-table))

;; sum up and normalize the 
(for-each
 (lambda (indat)
   (let ((pid (car indat))
         (usr (cadr indat))
         (cpu (list-ref indat 8)))
     (hash-table-set! userhash usr (+ cpu (hash-table-ref/default userhash usr 0)))))
 data)

(for-each
 (lambda (usr)
   (print usr
          (if (< (string-length usr) 8) "\t\t" "\t")
          (inexact->exact (round (/ (hash-table-ref userhash usr) *numsamples*)))))
 (sort (hash-table-keys userhash)
       (lambda (a b)
         (> (hash-table-ref userhash a)
            (hash-table-ref userhash b)))))