Changes In Branch development
Through [99ca17a0cc]
Excluding Merge-Ins
This is equivalent to a diff from
dfd75df083
to 99ca17a0cc
Modified Makefile
from [738965e200]
to [22f5ddf088].
| ︙ | | |
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
|
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
|
-
+
-
-
+
+
|
HELPERS=$(addprefix $(PREFIX)/bin/,$(ADTLSCR))
DEPLOYHELPERS=$(addprefix deploytarg/,$(ADTLSCR))
MTESTHASH=$(shell fossil info|grep checkout:| awk '{print $$2}')
CSIPATH=$(shell which csi)
CKPATH=$(shell dirname $(shell dirname $(CSIPATH)))
all : mtest dboard newdashboard
all : mtest dboard newdboard
mtest: $(OFILES) megatest.o
csc $(CSCOPTS) $(OFILES) megatest.o -o mtest
dboard : $(OFILES) $(GOFILES) dashboard.scm
csc $(OFILES) dashboard.scm $(GOFILES) -o dboard
newdashboard : newdashboard.scm $(OFILES)
csc $(OFILES) newdashboard.scm -o newdashboard
newdboard : newdashboard.scm $(OFILES) $(GOFILES)
csc $(OFILES) $(GOFILES) newdashboard.scm -o newdboard
deploytarg/libiupcd.so : $(CKPATH)/lib/libiupcd.so
for i in iup im cd av call sqlite; do \
cp $(CKPATH)/lib/lib$$i* deploytarg/ ; \
done
cp $(CKPATH)/include/*.h deploytarg
|
| ︙ | | |
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
|
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
|
-
-
+
+
+
+
|
$(PREFIX)/bin/mtest : mtest
@echo Installing to PREFIX=$(PREFIX)
$(INSTALL) mtest $(PREFIX)/bin/mtest
utils/mk_wrapper $(PREFIX) mtest > $(PREFIX)/bin/megatest
chmod a+x $(PREFIX)/bin/megatest
$(PREFIX)/bin/newdashboard : newdashboard
$(INSTALL) newdashboard $(PREFIX)/bin/newdashboard
$(PREFIX)/bin/newdboard : newdboard
$(INSTALL) newdboard $(PREFIX)/bin/newdboard
utils/mk_wrapper $(PREFIX) newdboard > $(PREFIX)/bin/newdashboard
chmod a+x $(PREFIX)/bin/newdashboard
$(HELPERS) : utils/mt_*
$(INSTALL) $< $@
chmod a+x $@
$(DEPLOYHELPERS) : utils/mt_*
$(INSTALL) $< $@
|
| ︙ | | |
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
|
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
|
-
+
|
# install dashboard as dboard so wrapper script can be called dashboard
$(PREFIX)/bin/dboard : dboard $(FILES)
$(INSTALL) dboard $(PREFIX)/bin/dboard
utils/mk_wrapper $(PREFIX) dboard > $(PREFIX)/bin/dashboard
chmod a+x $(PREFIX)/bin/dashboard
install : bin $(PREFIX)/bin/mtest $(PREFIX)/bin/megatest $(PREFIX)/bin/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake $(PREFIX)/bin/nbfind $(PREFIX)/bin/newdashboard
install : bin $(PREFIX)/bin/mtest $(PREFIX)/bin/megatest $(PREFIX)/bin/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake $(PREFIX)/bin/nbfind $(PREFIX)/bin/newdboard
deploytarg/apropos.so : Makefile
for i in apropos base64 canvas-draw csv-xml directory-utils dot-locking extras fmt format hostinfo http-client intarweb json md5 message-digest posix posix-extras readline regex regex-case s11n spiffy spiffy-request-vars sqlite3 srfi-1 srfi-18 srfi-69 tcp test uri-common zmq check-errors synch matchable sql-null tcp-server rpc blob-utils string-utils variable-item defstruct uri-generic sendfile opensll openssl lookup-table list-utils stack; do \
chicken-install -prefix deploytarg -deploy $$i;done
deploytarg/libsqlite3.so :
CSC_OPTIONS="-Ideploytarg -Ldeploytarg" $CHICKEN_INSTALL -prefix deploytarg -deploy sqlite3
|
| ︙ | | |
Modified common.scm
from [fc2e76989a]
to [3109b21887].
| ︙ | | |
145
146
147
148
149
150
151
152
153
154
155
156
157
158
|
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
|
+
+
+
+
+
+
|
(read-config "megatest.config" #f #t)
"disks" '("none" "")))
;;======================================================================
;; System stuff
;;======================================================================
;; return a nice clean pathname made absolute
(define (nice-path dir)
(normalize-pathname (if (absolute-pathname? dir)
dir
(conc (current-directory) "/" dir))))
(define (get-df path)
(let* ((df-results (cmd-run->list (conc "df " path)))
(space-rx (regexp "([0-9]+)\\s+([0-9]+)%"))
(freespc #f))
;; (write df-results)
(for-each (lambda (l)
(let ((match (string-search space-rx l)))
|
| ︙ | | |
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
|
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
|
-
+
-
-
+
+
-
-
-
-
+
+
+
-
-
-
+
+
+
|
(define (common:name->iup-color name)
(case (string->symbol (string-downcase name))
((red) "223 33 49")
((grey) "192 192 192")
((orange) "255 172 13")
((purple) "This is unfinished ...")))
(define (common:get-color-for-state-status state status type)
(define (common:get-color-for-state-status state status)
(case (string->symbol state)
((COMPLETED)
(if (equal? status "PASS")
"70 249 73"
(case (string->symbol status)
((PASS) "70 249 73")
(if (or (equal? status "WARN")
(equal? status "WAIVED"))
"255 172 13"
"223 33 49"))) ;; greenish orangeish redish
((REMOTEHOSTSTART) "50 130 195")
((RUNNING) "9 131 232")
((KILLREQ) "39 82 206")
((REMOTEHOSTSTART) "50 130 195")
((RUNNING) "9 131 232")
((KILLREQ) "39 82 206")
((KILLED) "234 101 17")
((NOT_STARTED) "240 240 240")
(else "192 192 192")))
(define (common:get-color-from-status status)
(cond
((equal? status "PASS") "green")
((equal? status "FAIL") "red")
((equal? status "WARN") "orange")
((equal? status "KILLED") "orange")
((equal? status "KILLREQ") "purple")
((equal? status "RUNNING") "blue")
(else "black")))
|
Modified configf.scm
from [c9fe6d3ae6]
to [24769c8a78].
| ︙ | | |
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
|
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
|
-
+
|
;; PURPOSE.
;;======================================================================
;;======================================================================
;; Config file handling
;;======================================================================
(use regex regex-case)
(use regex regex-case directory-utils)
(declare (unit configf))
(declare (uses common))
(declare (uses process))
(include "common_records.scm")
;; return list (path fullpath configname)
|
| ︙ | | |
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
|
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
|
-
+
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;; envion-patt is a regex spec that identifies sections that will be eval'd
;; in the environment on the fly
;; sections: #f => get all, else list of sections to gather
(define (read-config path ht allow-system #!key (environ-patt #f)(curr-section #f)(sections #f))
(debug:print-info 5 "read-config " path " allow-system " allow-system " environ-patt " environ-patt " curr-section: " curr-section " sections: " sections " pwd: " (current-directory))
(if (not (file-exists? path))
(begin
(debug:print-info 4 "read-config - file not found " path " current path: " (current-directory))
(debug:print-info 1 "read-config - file not found " path " current path: " (current-directory))
(if (not ht)(make-hash-table) ht))
(let ((inp (open-input-file path))
(res (if (not ht)(make-hash-table) ht)))
(let loop ((inl (configf:read-line inp res allow-system)) ;; (read-line inp))
(curr-section-name (if curr-section curr-section "default"))
(var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere
(lead #f))
(debug:print-info 8 "curr-section-name: " curr-section-name " var-flag: " var-flag "\n inl: \"" inl "\"")
(if (eof-object? inl)
(begin
(close-input-port inp)
(hash-table-delete! res "") ;; we are using "" as a dumping ground and must remove it before returning the ht
res)
(regex-case
inl
(configf:comment-rx _ (loop (configf:read-line inp res allow-system) curr-section-name #f #f))
(configf:blank-l-rx _ (loop (configf:read-line inp res allow-system) curr-section-name #f #f))
(configf:include-rx ( x include-file ) (let ((curr-dir (current-directory))
(conf-dir (pathname-directory path)))
(if conf-dir (change-directory conf-dir))
(read-config include-file res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections)
(change-directory curr-dir)
(loop (configf:read-line inp res allow-system) curr-section-name #f #f)))
(configf:include-rx ( x include-file ) (let* ((curr-conf-dir (pathname-directory path))
(full-conf (if (absolute-pathname? include-file)
include-file
(nice-path
(conc (if curr-conf-dir
curr-conf-dir
".")
"/" include-file)))))
(if (file-exists? full-conf)
(begin
;; (push-directory conf-dir)
(read-config full-conf res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections)
;; (pop-directory)
(loop (configf:read-line inp res allow-system) curr-section-name #f #f))
(begin
(debug:print 2 "INFO: include file " include-file " not found (called from " path ")")
(debug:print 2 " " full-conf)
(loop (configf:read-line inp res allow-system) curr-section-name #f #f)))))
(configf:section-rx ( x section-name ) (loop (configf:read-line inp res allow-system)
;; if we have the sections list then force all settings into "" and delete it later?
(if (or (not sections)
(member section-name sections))
section-name "") ;; stick everything into ""
#f #f))
(configf:key-sys-pr ( x key cmd ) (if allow-system
|
| ︙ | | |
Modified dashboard-tests.scm
from [0bfb3e05a8]
to [b247a10977].
| ︙ | | |
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
|
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
|
-
+
|
(let ((lbl (iup:label (db:test-get-status testdat) #:expand "HORIZONTAL")))
(hash-table-set! widgets "teststatus"
(lambda (testdat)
(let ((newstatus (db:test-get-status testdat))
(oldstatus (iup:attribute lbl "TITLE")))
(if (not (equal? oldstatus newstatus))
(begin
(iup:attribute-set! lbl "FGCOLOR" (get-color-for-state-status (db:test-get-state testdat)
(iup:attribute-set! lbl "FGCOLOR" (common:get-color-for-state-status (db:test-get-state testdat)
(db:test-get-status testdat)))
(iup:attribute-set! lbl "TITLE" (db:test-get-status testdat)))))))
lbl)
(store-label "testcomment"
(iup:label "TestComment "
#:expand "HORIZONTAL")
(lambda (testdat)
|
| ︙ | | |
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
|
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
|
-
+
|
;; use a global for setting the buttons colors
;; state status teststeps
(define *state-status* (vector #f #f #f))
(define (update-state-status-buttons testdat)
(let* ((state (db:test-get-state testdat))
(status (db:test-get-status testdat))
(color (get-color-for-state-status state status)))
(color (common:get-color-for-state-status state status)))
((vector-ref *state-status* 0) state color)
((vector-ref *state-status* 1) status color)))
;;======================================================================
;; Set fields
;;======================================================================
(define (set-fields-panel test-id testdat)
|
| ︙ | | |
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
|
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
|
-
+
|
(let* ((btns (map (lambda (status)
(let ((btn (iup:button status
#:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10"
#:action (lambda (x)
(open-run-close db:test-set-state-status-by-id #f test-id #f status #f)
(db:test-set-status! testdat status)))))
btn))
(list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED"))))
(list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP"))))
(vector-set! *state-status* 1
(lambda (status color)
(for-each
(lambda (btn)
(let* ((name (iup:attribute btn "TITLE"))
(newcolor (if (equal? name status) color "192 192 192")))
(if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR")))
|
| ︙ | | |
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
|
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
|
-
+
|
(exit 1))
(let* ((run-id (if testdat (db:test-get-run_id testdat) #f))
(keydat (if testdat (open-run-close db:get-key-val-pairs #f run-id) #f))
(rundat (if testdat (open-run-close db:get-run-info #f run-id) #f))
(runname (if testdat (db:get-value-by-header (db:get-row rundat)
(db:get-header rundat)
"runname") #f))
;(teststeps (if testdat (db:get-steps-for-test db test-id) #f))
(teststeps (if testdat (db:get-compressed-steps test-id) '()))
(logfile "/this/dir/better/not/exist")
(rundir logfile)
(testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ..."))
(testname (if testdat (db:test-get-testname testdat) "n/a"))
(testmeta (if testdat
(let ((tm (open-run-close db:testmeta-get-record #f testname)))
(if tm tm (make-db:testmeta)))
|
| ︙ | | |
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
|
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
|
-
+
-
+
+
+
|
(need-update (or (and (> curr-mod-time db-mod-time)
(> (current-seconds) (+ last-update 2))) ;; every two seconds if db touched
request-update))
(newtestdat (if need-update (open-run-close db:get-test-info-by-id #f test-id))))
(cond
((and need-update newtestdat)
(set! testdat newtestdat)
(set! teststeps (open-run-close db:get-steps-for-test db test-id))
(set! teststeps (db:get-compressed-steps test-id))
(set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat)))
(set! rundir (db:test-get-rundir testdat))
(set! testfullname (db:test-get-fullname testdat)))
(set! testfullname (db:test-get-fullname testdat))
;; (debug:print 0 "INFO: teststeps=" (intersperse teststeps "\n "))
)
(need-update ;; if this was true and yet there is no data ....
(db:test-set-testname! testdat "DEAD OR DELETED TEST"))))))
(widgets (make-hash-table))
(meta-widgets (make-hash-table))
(self #f)
(store-label (lambda (name lbl cmd)
(hash-table-set! widgets name
|
| ︙ | | |
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
|
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
|
-
-
-
-
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
-
-
+
+
-
-
-
-
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(iup:button "Run Test" #:action run-test #:size "80x")
(iup:button "Clean Test" #:action remove-test #:size "80x")
(iup:button "Close" #:action (lambda (x)(exit)) #:size "80x"))
(apply
iup:hbox
(list command-text-box command-launch-button))))
(set-fields-panel test-id testdat)
(iup:hbox
(iup:frame
#:title "Test Steps"
(let ((stepsdat ;;(iup:label "Test steps ........................................."
(let ((tabs
(iup:tabs
;; Replace here with matrix
(let ((steps-matrix (iup:matrix
;; #:expand "YES"
;; #:size "200x150"
;; #:alignment "ALEFT:ATOP")))
(iup:textbox ;; #:action (lambda (obj char val)
;; #f)
#:expand "YES"
#:multiline "YES"
#:font "Courier New, -10"
#:size "60x100")))
(hash-table-set! widgets "Test Steps"
(lambda (testdat)
(let* ((currval (iup:attribute stepsdat "VALUE")) ;; "TITLE"))
(fmtstr "~20a~10a~10a~12a~15a~20a")
(comprsteps (open-run-close db:get-steps-table db test-id))
(newval (string-intersperse
(append
(list
(format #f fmtstr "Stepname" "Start" "End" "Status" "Time" "Logfile")
(format #f fmtstr "========" "=====" "===" "======" "====" "======="))
(map (lambda (x)
;; take advantage of the \n on time->string
(format #f fmtstr
(vector-ref x 0)
(let ((s (vector-ref x 1)))
(if (number? s)(seconds->time-string s) s))
(let ((s (vector-ref x 2)))
(if (number? s)(seconds->time-string s) s))
(vector-ref x 3) ;; status
(vector-ref x 4)
(vector-ref x 5))) ;; time delta
(sort (hash-table-values comprsteps)
(lambda (a b)
(let ((time-a (vector-ref a 1))
(time-b (vector-ref b 1)))
(if (and (number? time-a)(number? time-b))
(if (< time-a time-b)
#t
(if (eq? time-a time-b)
(string<? (conc (vector-ref a 2))
(conc (vector-ref b 2)))
#f))
(string<? (conc time-a)(conc time-b))))))))
"\n")))
(if (not (equal? currval newval))
(iup:attribute-set! stepsdat "VALUE" newval ))))) ;; "TITLE" newval)))))
stepsdat))
;; populate the Test Data panel
(iup:frame
#:title "Test Data"
(let ((test-data
(iup:textbox ;; #:action (lambda (obj char val)
;; #f)
#:expand "YES"
#:multiline "YES"
#:font "Courier New, -10"
#:size "100x100")))
(hash-table-set! widgets "Test Data"
(lambda (testdat) ;;
(let* ((currval (iup:attribute test-data "VALUE")) ;; "TITLE"))
(fmtstr "~10a~10a~10a~10a~7a~7a~6a~6a~a") ;; category,variable,value,expected,tol,units,type,comment
(newval (string-intersperse
(append
(list
(format #f fmtstr "Category" "Variable" "Value" "Expected" "Tol" "Status" "Units" "Type" "Comment")
(format #f fmtstr "========" "========" "=====" "========" "===" "======" "=====" "====" "======="))
(map (lambda (x)
(format #f fmtstr
(db:test-data-get-category x)
(db:test-data-get-variable x)
(db:test-data-get-value x)
(db:test-data-get-expected x)
(db:test-data-get-tol x)
(db:test-data-get-status x)
(db:test-data-get-units x)
(db:test-data-get-type x)
(db:test-data-get-comment x)))
(open-run-close db:read-test-data #f test-id "%")))
"\n")))
(if (not (equal? currval newval))
(iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval)))))
test-data)))
)))
|
| ︙ | | |
Modified dashboard.scm
from [7c18e62e8f]
to [f8c5b58774].
| ︙ | | |
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
|
316
317
318
319
320
321
322
323
324
325
326
327
328
329
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
(if (> (length parts) 1)(conc " " (car (string-split (cadr parts) ")"))) newval))))
(vector-set! keycol i newval)
(iup:attribute-set! lbl "TITLE" munged-val)))
(iup:attribute-set! lbl "FGCOLOR" (if (hash-table-ref/default *collapsed* newval #f) "0 112 112" "0 0 0"))
(if (< i maxn)
(loop (+ i 1)))))))
(define (get-color-for-state-status state status)
(case (string->symbol state)
((COMPLETED)
(if (equal? status "PASS")
"70 249 73"
(if (or (equal? status "WARN")
(equal? status "WAIVED"))
"255 172 13"
"223 33 49"))) ;; greenish orangeish redish
((LAUNCHED) "101 123 142")
((CHECK) "255 100 50")
((REMOTEHOSTSTART) "50 130 195")
((RUNNING) "9 131 232")
((KILLREQ) "39 82 206")
((KILLED) "234 101 17")
((NOT_STARTED) "240 240 240")
(else "192 192 192")))
|
| ︙ | | |
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
|
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
|
-
+
|
(testfullname (test:test-get-fullname test))
(teststatus (db:test-get-status test))
(teststate (db:test-get-state test))
(teststart (db:test-get-event_time test))
(runtime (db:test-get-run_duration test))
(buttontxt (if (equal? teststate "COMPLETED") teststatus teststate))
(button (vector-ref columndat rown))
(color (get-color-for-state-status teststate teststatus))
(color (common:get-color-for-state-status teststate teststatus))
(curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR"))
(curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE")))
(if (not (equal? curr-color color))
(iup:attribute-set! button "BGCOLOR" color))
(if (not (equal? curr-title buttontxt))
(iup:attribute-set! button "TITLE" buttontxt))
(vector-set! buttondat 0 run-id)
|
| ︙ | | |
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
|
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
|
-
+
|
iup:hbox
(map (lambda (status)
(iup:toggle status #:action (lambda (obj val)
(mark-for-update)
(if (eq? val 1)
(hash-table-set! *status-ignore-hash* status #t)
(hash-table-delete! *status-ignore-hash* status)))))
'("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a")))
'("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP")))
(apply
iup:hbox
(map (lambda (state)
(iup:toggle state #:action (lambda (obj val)
(mark-for-update)
(if (eq? val 1)
(hash-table-set! *state-ignore-hash* state #t)
|
| ︙ | | |
Modified db.scm
from [0623ab4501]
to [cc06b656a5].
| ︙ | | |
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
|
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
|
-
+
+
+
+
+
+
+
|
(define (open-test-db testpath)
(debug:print-info 11 "open-test-db " testpath)
(if (and testpath
(directory? testpath)
(file-read-access? testpath))
(let* ((dbpath (conc testpath "/testdat.db"))
(dbexists (file-exists? dbpath))
(db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath))
|
| ︙ | | |
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
|
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
|
-
+
|
(list item-path ""))))
(cdb:client-call serverdat 'register-test #t *default-numtries* run-id test-name item-path)))
(define (cdb:flush-queue serverdat)
(cdb:client-call serverdat 'flush #f *default-numtries*))
(define (cdb:kill-server serverdat)
(cdb:client-call serverdat 'killserver #f *default-numtries*))
(cdb:client-call serverdat 'killserver #t *default-numtries*))
(define (cdb:roll-up-pass-fail-counts serverdat run-id test-name item-path status)
(cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:roll-up-pass-fail-counts #f run-id test-name item-path status))
(define (cdb:get-test-info serverdat run-id test-name item-path)
(cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:get-test-info #f run-id test-name item-path))
|
| ︙ | | |
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
|
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
|
-
+
+
|
(define db:special-queries '(rollup-tests-pass-fail
db:roll-up-pass-fail-counts
login
immediate
flush
sync
set-verbosity
killserver))
killserver
))
;; not used, intended to indicate to run in calling process
(define db:run-local-queries '()) ;; rollup-tests-pass-fail))
(define (db:process-cached-writes db)
(let ((queries (make-hash-table))
(data #f))
|
| ︙ | | |
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
|
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
|
-
+
+
+
-
+
|
(debug:print-info 7 "Current write queue length is " queue-len)
;; poll for the write to complete, timeout after 10 seconds
;; periodic flushing of the queue is taken care of by
;; db:flush-queue
(let loop ()
(thread-sleep! 0.1)
(thread-sleep! 0.001)
(mutex-lock! *completed-mutex*)
(if (hash-table-ref/default *completed-writes* qry-sig #f)
(begin
(hash-table-delete! *completed-writes* qry-sig)
(set! got-it #t)))
(mutex-unlock! *completed-mutex*)
(if (and (not got-it)
(< (current-seconds) timeout))
(begin
(thread-sleep! 0.01)
(loop)))
(loop))))
(set! *number-of-writes* (+ *number-of-writes* 1))
(set! *writes-total-delay* (+ *writes-total-delay* 1))
got-it))
(define (db:process-queue-item db item)
(let* ((stmt-key (cdb:packet-get-qtype item))
(qry-sig (cdb:packet-get-query-sig item))
|
| ︙ | | |
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
|
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
|
-
+
|
(debug:print-info 7 "Received " response " from wrapped write")
(server:reply return-address qry-sig response response))
;; otherwise if appropriate flush the queue (this is a read or complex query)
(begin
(cond
((member stmt-key db:special-queries)
(let ((starttime (current-milliseconds)))
(debug:print-info 11 "Handling special statement " stmt-key)
(debug:print-info 9 "Handling special statement " stmt-key)
(case stmt-key
((immediate)
;; This is a read or mixed read-write query, must clear the cache
(case *transport-type*
((http)
(mutex-lock! *db:process-queue-mutex*)
(db:process-cached-writes db)
|
| ︙ | | |
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
|
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
|
-
+
-
+
|
run-id test-name)
res))
;; Rollup the pass/fail counts from itemized tests into fail_count and pass_count
(define (db:roll-up-pass-fail-counts db run-id test-name item-path status)
;; (cdb:flush-queue *runremote*)
(if (and (not (equal? item-path ""))
(member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK")))
(member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK" "SKIP")))
(begin
(sqlite3:execute
db
"UPDATE tests
SET fail_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status='FAIL'),
pass_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND (status='PASS' OR status='WARN' OR status='WAIVED'))
pass_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED'))
WHERE run_id=? AND testname=? AND item_path='';"
run-id test-name run-id test-name run-id test-name)
;; (thread-sleep! 0.1) ;; give other processes a chance here, no, better to be done ASAP?
(if (equal? status "RUNNING") ;; running takes priority over all other states, force the test state to RUNNING
(sqlite3:execute db "UPDATE tests SET state=? WHERE run_id=? AND testname=? AND item_path='';" "RUNNING" run-id test-name)
(sqlite3:execute
db
|
| ︙ | | |
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
|
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;; organise the steps for better readability
(let ((res (make-hash-table)))
(for-each
(lambda (step)
(debug:print 6 "step=" step)
(let ((record (hash-table-ref/default
res
(db:step-get-stepname step)
;; stepname start end status Duration Logfile
(vector (db:step-get-stepname step) "" "" "" "" ""))))
(debug:print 6 "record(before) = " record
"\nid: " (db:step-get-id step)
"\nstepname: " (db:step-get-stepname step)
"\nstate: " (db:step-get-state step)
"\nstatus: " (db:step-get-status step)
"\ntime: " (db:step-get-event_time step))
(case (string->symbol (db:step-get-state step))
((start)(vector-set! record 1 (db:step-get-event_time step))
(vector-set! record 3 (if (equal? (vector-ref record 3) "")
(db:step-get-status step)))
(if (> (string-length (db:step-get-logfile step))
0)
(vector-set! record 5 (db:step-get-logfile step))))
((end)
(vector-set! record 2 (any->number (db:step-get-event_time step)))
(vector-set! record 3 (db:step-get-status step))
(vector-set! record 4 (let ((startt (any->number (vector-ref record 1)))
(endt (any->number (vector-ref record 2))))
(debug:print 4 "record[1]=" (vector-ref record 1)
", startt=" startt ", endt=" endt
", get-status: " (db:step-get-status step))
(if (and (number? startt)(number? endt))
(seconds->hr-min-sec (- endt startt)) "-1")))
(if (> (string-length (db:step-get-logfile step))
0)
(vector-set! record 5 (db:step-get-logfile step))))
(else
(vector-set! record 2 (db:step-get-state step))
(vector-set! record 3 (db:step-get-status step))
(vector-set! record 4 (db:step-get-event_time step))))
(hash-table-set! res (db:step-get-stepname step) record)
(debug:print 6 "record(after) = " record
"\nid: " (db:step-get-id step)
"\nstepname: " (db:step-get-stepname step)
"\nstate: " (db:step-get-state step)
"\nstatus: " (db:step-get-status step)
"\ntime: " (db:step-get-event_time step))))
;; (else (vector-set! record 1 (db:step-get-event_time step)))
(sort steps (lambda (a b)
(cond
((< (db:step-get-event_time a)(db:step-get-event_time b)) #t)
((eq? (db:step-get-event_time a)(db:step-get-event_time b))
(< (db:step-get-id a) (db:step-get-id b)))
(else #f)))))
res)))
;; get a pretty table to summarize steps
;;
(define (db:get-steps-table-list db test-id)
(let ((steps (db:get-steps-for-test db test-id)))
;; organise the steps for better readability
(let ((res (make-hash-table)))
(for-each
(lambda (step)
(debug:print 6 "step=" step)
(let ((record (hash-table-ref/default
res
(db:step-get-stepname step)
;; stepname start end status
(vector (db:step-get-stepname step) "" "" "" "" ""))))
(debug:print 6 "record(before) = " record
"\nid: " (db:step-get-id step)
"\nstepname: " (db:step-get-stepname step)
"\nstate: " (db:step-get-state step)
|
| ︙ | | |
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
|
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
|
(cond
((< (db:step-get-event_time a)(db:step-get-event_time b)) #t)
((eq? (db:step-get-event_time a)(db:step-get-event_time b))
(< (db:step-get-id a) (db:step-get-id b)))
(else #f)))))
res)))
(define (db:get-compressed-steps test-id)
(let* ((comprsteps (open-run-close db:get-steps-table #f test-id)))
(map (lambda (x)
;; take advantage of the \n on time->string
(vector
(vector-ref x 0)
(let ((s (vector-ref x 1)))
(if (number? s)(seconds->time-string s) s))
(let ((s (vector-ref x 2)))
(if (number? s)(seconds->time-string s) s))
(vector-ref x 3) ;; status
(vector-ref x 4)
(vector-ref x 5))) ;; time delta
(sort (hash-table-values comprsteps)
(lambda (a b)
(let ((time-a (vector-ref a 1))
(time-b (vector-ref b 1)))
(if (and (number? time-a)(number? time-b))
(if (< time-a time-b)
#t
(if (eq? time-a time-b)
(string<? (conc (vector-ref a 2))
(conc (vector-ref b 2)))
#f))
(string<? (conc time-a)(conc time-b)))))))))
;;======================================================================
;; M I S C M A N A G E M E N T I T E M S
;;======================================================================
;; the new prereqs calculation, looks also at itempath if specified
;; all prereqs must be met:
;; if prereq test with itempath='' is COMPLETED and PASS, WARN, CHECK, or WAIVED then prereq is met
;; if prereq test with itempath=ref-item-path and COMPLETED with PASS, WARN, CHECK, or WAIVED then prereq is met
;;
;; Note: do not convert to remote as it calls remote under the hood
;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK or WAIVED)
;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK, SKIP or WAIVED)
;; mode 'toplevel means that tests must be COMPLETED only
;; mode 'itemmatch means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]]
;;
(define (db:get-prereqs-not-met db run-id waitons ref-item-path #!key (mode 'normal))
(if (or (not waitons)
(null? waitons))
'()
|
| ︙ | | |
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
|
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
|
-
+
|
(for-each
(lambda (test)
;; (if (equal? waitontest-name (db:test-get-testname test)) ;; by defintion this had better be true ...
(let* ((state (db:test-get-state test))
(status (db:test-get-status test))
(item-path (db:test-get-item-path test))
(is-completed (equal? state "COMPLETED"))
(is-ok (member status '("PASS" "WARN" "CHECK" "WAIVED")))
(is-ok (member status '("PASS" "WARN" "CHECK" "WAIVED" "SKIP")))
(same-itempath (equal? ref-item-path item-path)))
(set! ever-seen #t)
(cond
;; case 1, non-item (parent test) is
((and (equal? item-path "") ;; this is the parent test
is-completed
(or is-ok (eq? mode 'toplevel)))
|
| ︙ | | |
Modified docs/manual/megatest_manual.txt
from [5c6fd3ea7c]
to [db93d807cc].
| ︙ | | |
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
|
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
|
+
-
-
+
+
+
+
+
+
+
+
+
-
+
|
megatest uses the network filesystem to call home to your master
sqlite3 database.
include::getting_started.txt[] include::writing_tests.txt[]
include::reference.txt[]
Controlled waiver propagation
=========================================================
# logpro_file input_glob
=============================
If test is FAIL and previous test in run with same MT_TARGET is WAIVED then apply the following rules from the testconfig:
If a waiver check is specified in the testconfig apply the check and if it passes then set this FAIL to WAIVED
Waiver check has two parts, 1) a list of waiver, rulename, filepatterns and 2) the rulename script spec (note that "diff" and "logpro" are predefined)
=========================================================
###### EXAMPLE FROM testconfig #########
# matching file(s) will be diff'd with previous run and logpro applied
# if PASS or WARN result from logpro then WAIVER state is set
#
[waivers]
# logpro_file rulename input_glob
waiver_1 logpro lookittmp.log
waiver_1 logpro lookittmp.log
[waiver_rules]
# This builtin rule is the default if there is no <waivername>.logpro file
# diff diff %file1% %file2%
# This builtin rule is applied if a <waivername>.logpro file exists
|
| ︙ | | |
Modified docs/megatest-training.odp
from [093164d585]
to [0be35cde95].
cannot compute difference between binary files
Modified http-transport.scm
from [3ad4c59590]
to [c1f69a9798].
| ︙ | | |
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
|
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
|
+
+
+
|
(begin
(print-error-message exn)
(if (< portnum 9000)
(begin
(print "WARNING: failed to start on portnum: " portnum ", trying next port")
(thread-sleep! 0.1)
;; (open-run-close tasks:remove-server-records tasks:open-db)
(open-run-close tasks:server-delete tasks:open-db ipaddrstr portnum)
(http-transport:try-start-server ipaddrstr (+ portnum 1)))
(print "ERROR: Tried and tried but could not start the server")))
;; any error in following steps will result in a retry
(set! *runremote* (list ipaddrstr portnum))
;; (open-run-close tasks:remove-server-records tasks:open-db)
(open-run-close tasks:server-register
tasks:open-db
(current-process-id)
ipaddrstr portnum 0 'live 'http)
(print "INFO: Trying to start server on " ipaddrstr ":" portnum)
;; This starts the spiffy server
(start-server port: portnum)
(open-run-close tasks:server-delete tasks:open-db ipaddrstr portnum)
(print "INFO: server has been stopped")))
;;======================================================================
;; S E R V E R U T I L I T I E S
;;======================================================================
;;======================================================================
|
| ︙ | | |
227
228
229
230
231
232
233
234
235
236
237
238
239
240
|
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
|
+
+
+
+
+
+
+
+
+
+
+
+
|
(thread-sleep! 4) ;; no need to do this very often
;; NB// sync currently does NOT return queue-length
(let () ;; (queue-len (cdb:client-call server-info 'sync #t 1)))
;; (print "Server running, count is " count)
(if (< count 1) ;; 3x3 = 9 secs aprox
(loop (+ count 1)))
;; Check that iface and port have not changed (can happen if server port collides)
(mutex-lock! *heartbeat-mutex*)
(set! sdat *runremote*)
(mutex-unlock! *heartbeat-mutex*)
(if (not (equal? sdat (list iface port)))
(begin
(debug:print-info 1 "interface changed, refreshing iface and port info")
(set! iface (car sdat))
(set! port (cadr sdat))
(set! spid (tasks:server-get-server-id tdb #f iface port #f))))
;; NOTE: Get rid of this mechanism! It really is not needed...
(tasks:server-update-heartbeat tdb spid)
;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access
(mutex-lock! *heartbeat-mutex*)
(set! last-access *last-db-access*)
(mutex-unlock! *heartbeat-mutex*)
|
| ︙ | | |
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
|
+
-
+
|
(define (http-transport:launch)
(if (not *toppath*)
(if (not (setup-for-run))
(begin
(debug:print 0 "ERROR: cannot find megatest.config, exiting")
(exit))))
(debug:print-info 2 "Starting the standalone server")
(if (args:get-arg "-daemonize")
(daemon:ize)
(daemon:ize))
(let ((hostinfo (open-run-close tasks:get-best-server tasks:open-db)))
(debug:print 11 "http-transport:launch hostinfo=" hostinfo)
;; #(1 "143.182.207.24" 5736 -1 "http" 22771 "hostname")
(if hostinfo
(debug:print-info 2 "NOT starting new server, one is already running on " (vector-ref hostinfo 1) ":" (vector-ref hostinfo 2))
(if *toppath*
(let* ((th2 (make-thread (lambda ()
|
| ︙ | | |
Modified launch.scm
from [4243d5cf59]
to [72a27c3b60].
| ︙ | | |
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
|
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
|
-
+
|
(define (steprun-good? logpro exitcode)
(or (eq? exitcode 0)
(and logpro (eq? exitcode 2))))
;; if handed a string, process it, else look for MT_CMDINFO
(define (launch:get-cmdinfo-assoc-list #!key (encoded-cmd #f))
(let ((enccmd (if encoded-cmd encoded-cmd (getenv "MT_CMDINFO"))))
(if enccdm
(if enccmd
(read (open-input-string (base64:base64-decode enccmd)))
'())))
(define (launch:execute encoded-cmd)
(let* ((cmdinfo (read (open-input-string (base64:base64-decode encoded-cmd)))))
(setenv "MT_CMDINFO" encoded-cmd)
(if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed)
|
| ︙ | | |
Modified megatest-version.scm
from [e814801c27]
to [24437845eb].
1
2
3
4
5
6
7
|
1
2
3
4
5
6
7
|
-
+
|
;; Always use two digit decimal
;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00..
(declare (unit megatest-version))
(define megatest-version 1.5405)
(define megatest-version 1.5415)
|
Modified megatest.scm
from [99c3c82dba]
to [2419ab740a].
| ︙ | | |
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
|
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
|
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
|
(define *db* #f) ;; this is only for the repl, do not use in general!!!!
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "megatest-fossil-hash.scm")
;; (use trace)
;; (trace db:teststep-set-status!
;; tests:test-set-status!
;; cdb:test-set-status-state
;; cdb:client-call
;; tests:check-waiver-eligibility)
;; (use trace dot-locking)
;; (trace
;; cdb:client-call
;; cdb:remote-run
;; cdb:test-set-status-state
;; change-directory
;; db:process-queue-item
;; db:test-get-logfile-info
;; db:teststep-set-status!
;; nice-path
;; obtain-dot-lock
;; open-run-close
;; read-config
;; runs:can-run-more-tests
;; sqlite3:execute
;; sqlite3:for-each-row
;; tests:check-waiver-eligibility
;; tests:summarize-items
;; tests:test-set-status!
;; thread-sleep!
;;)
(define help (conc "
Megatest, documentation at http://chiselapp.com/user/kiatoa/repository/megatest
Megatest, documentation at http://www.kiatoa.com/fossils/megatest
version " megatest-version "
license GPL, Copyright Matt Welland 2006-2012
Usage: megatest [options]
-h : this help
-version : print megatest version (currently " megatest-version ")
|
| ︙ | | |
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
|
+
+
|
-update-meta : update the tests metadata for all tests
-env2file fname : write the environment to fname.csh and fname.sh
-setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are
overwritten by values set in config files.
-server -|hostname : start the server (reduces contention on megatest.db), use
- to automatically figure out hostname
-transport http|zmq : use http or zmq for transport (default is http)
-daemonize : fork into background and disconnect from stdin/out
-list-servers : list the servers
-stop-server id : stop server specified by id (see output of -list-servers)
-repl : start a repl (useful for extending megatest)
-load file.scm : load and run file.scm
Spreadsheet generation
-extract-ods fname.ods : extract an open document spreadsheet from the database
-pathmod path : insert path, i.e. path/runame/itempath/logfile.html
will clear the field if no rundir/testname/itempath/logfile
|
| ︙ | | |
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
|
152
153
154
155
156
157
158
159
160
161
162
163
164
165
|
-
|
megatest -test-files 'logs/*.log' -target ubuntu/n%/no% :runname w49% -testpatt test_mt%
Called as " (string-intersperse (argv) " ") "
Version " megatest-version ", built from " megatest-fossil-hash ))
;; -gui : start a gui interface
;; -config fname : override the runconfig file with fname
;; -kill-server host:port|pid : kill server specified by host:port or pid
|
| ︙ | | |
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
|
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
|
-
+
|
":value"
":expected"
":tol"
":units"
;; misc
"-server"
"-transport"
"-kill-server"
"-stop-server"
"-port"
"-extract-ods"
"-pathmod"
"-env2file"
"-setvars"
"-set-state-status"
"-debug" ;; for *verbosity* > 2
|
| ︙ | | |
199
200
201
202
203
204
205
206
207
208
209
210
211
212
|
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
|
+
|
"-xterm"
"-showkeys"
"-test-status"
"-set-values"
"-load-test-data"
"-summarize-items"
"-gui"
"-daemonize"
;; misc
"-archive"
"-repl"
"-lock"
"-unlock"
"-list-servers"
;; mist queries
|
| ︙ | | |
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
|
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
|
-
+
-
-
+
+
-
-
-
+
+
+
+
+
+
-
-
-
-
+
|
(if (setup-for-run)
(let ((servers (open-run-close tasks:get-best-server tasks:open-db)))
(if (or (not servers)
(null? servers))
(begin
(debug:print 0 "INFO: Starting server as none running ...")
;; (server:launch (string->symbol (args:get-arg "-transport" "http"))))
(system (conc (car (argv)) " -server - -transport " (args:get-arg "-transport" "http")))
(system (conc (car (argv)) " -server - -daemonize -transport " (args:get-arg "-transport" "http")))
(thread-sleep! 3)) ;; give the server a few seconds to start
(debug:print 0 "INFO: Servers already running " servers)
)))))
(if (args:get-arg "-list-servers")
;; (args:get-arg "-kill-server"))
(if (or (args:get-arg "-list-servers")
(args:get-arg "-stop-server"))
(let ((tl (setup-for-run)))
(if tl
(let ((servers (open-run-close tasks:get-all-servers tasks:open-db))
(fmtstr "~5a~8a~8a~20a~20a~10a~10a~10a~10a~10a\n")
(servers-to-kill '()))
(let* ((servers (open-run-close tasks:get-all-servers tasks:open-db))
(fmtstr "~5a~8a~8a~20a~20a~10a~10a~10a~10a~10a\n")
(servers-to-kill '())
(killinfo (args:get-arg "-stop-server"))
(khost-port (if killinfo (if (substring-index ":" killinfo)(string-split ":") #f) #f))
(sid (if killinfo (if (substring-index ":" killinfo) #f (string->number killinfo)) #f)))
(format #t fmtstr "Id" "MTver" "Pid" "Host" "Interface" "OutPort" "InPort" "LastBeat" "State" "Transport")
(format #t fmtstr "==" "=====" "===" "====" "=========" "=======" "======" "========" "=====" "=========")
(for-each
(lambda (server)
(let* (;; (killinfo (args:get-arg "-kill-server"))
;; (khost-port (if killinfo (if (substring-index ":" killinfo)(string-split ":") #f) #f))
;; (kpid (if killinfo (if (substring-index ":" killinfo) #f (string->number killinfo)) #f))
(id (vector-ref server 0))
|
| ︙ | | |
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
|
-
-
+
+
+
+
+
|
;; no need to login as status of #t indicates we are connecting to correct
;; server
(if (equal? state "dead")
(if (> last-update (* 25 60 60)) ;; keep records around for slighly over a day.
(open-run-close tasks:server-deregister tasks:open-db hostname pullport: pullport pid: pid action: 'delete))
(if (> last-update 20) ;; Mark as dead if not updated in last 20 seconds
(open-run-close tasks:server-deregister tasks:open-db hostname pullport: pullport pid: pid)))
(if status "alive" "dead") transport)))
(if status "alive" "dead") transport)
(if (equal? id sid)
(begin
(debug:print-info 0 "Attempting to stop server with pid " pid)
(tasks:kill-server status hostname pullport pid transport)))))
servers)
(debug:print-info 1 "Done with listservers")
(set! *didsomething* #t)
(exit) ;; must do, would have to add checks to many/all calls below
)
(exit)))
;; if not list or kill then start a client (if appropriate)
|
| ︙ | | |
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
|
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
|
-
+
|
((string=? (args:get-arg "-dumpmode") "json")
(json-write data))
(else
(debug:print 0 "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised")))
(set! *didsomething* #t)))
(if (args:get-arg "-show-config")
(let ((data (read-config "megatest.config" #f #t)))
(let ((data *configdat*)) ;; (read-config "megatest.config" #f #t)))
;; keep this one local
(cond
((not (args:get-arg "-dumpmode"))
(pp (hash-table->alist data)))
((string=? (args:get-arg "-dumpmode") "json")
(json-write data))
(else
|
| ︙ | | |
Modified runconfig.scm
from [09fb252607]
to [d27b298e19].
1
2
3
4
5
6
7
8
9
10
11
12
13
|
1
2
3
4
5
6
7
8
9
10
11
12
13
|
-
+
|
;;======================================================================
;; read a config file, loading only the section pertinent
;; to this run field1val/field2val/field3val ...
;;======================================================================
(use format)
(use format directory-utils)
(declare (unit runconfig))
(declare (uses common))
(include "common_records.scm")
|
| ︙ | | |
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
|
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
|
+
+
|
(debug:print 2 (format #f "~20a ~a\n" fullkey (hash-table-ref/default whatfound fullkey 0))))
sections)
(debug:print 2 "---")
(set! *already-seen-runconfig-info* #t)))
finaldat))
(define (set-run-config-vars db run-id keys keyvals)
(push-directory *toppath*)
(let ((runconfigf (conc *toppath* "/runconfigs.config"))
(targ (or (args:get-arg "-target")
(args:get-arg "-reqtarg")
(db:get-target db run-id))))
(pop-directory)
(if (file-exists? runconfigf)
(setup-env-defaults runconfigf run-id #t keys keyvals
environ-patt: (conc "(default"
(if targ
(conc "|" targ ")")
")")))
(debug:print 0 "WARNING: You do not have a run config file: " runconfigf))))
|
Modified runs.scm
from [7187084d9f]
to [f136285a97].
| ︙ | | |
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
|
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
|
-
+
-
+
|
(num-running-in-jobgroup (cdb:remote-run db:get-count-tests-running-in-jobgroup #f jobgroup))
(max-concurrent-jobs (let ((mcj (config-lookup *configdat* "setup" "max_concurrent_jobs")))
(if (and mcj (string->number mcj))
(string->number mcj)
1)))
(job-group-limit (config-lookup *configdat* "jobgroups" jobgroup)))
(if (and (> (+ num-running num-running-in-jobgroup) 0)
(< *runs:can-run-more-tests-delay* 10))
(< *runs:can-run-more-tests-delay* 1))
(begin
(set! *runs:can-run-more-tests-delay* (+ *runs:can-run-more-tests-delay* 1)) ;; 0.1))
(set! *runs:can-run-more-tests-delay* (+ *runs:can-run-more-tests-delay* 0.009))
(debug:print-info 14 "can-run-more-tests-delay: " *runs:can-run-more-tests-delay*)))
(if (not (eq? *last-num-running-tests* num-running))
(begin
(debug:print 2 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running)
(set! *last-num-running-tests* num-running)))
(if (not (eq? 0 *globalexitstatus*))
(list #f num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit)
|
| ︙ | | |
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
|
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
|
-
+
|
(debug:print-info 4 "All done by here")))
(define (runs:calc-fails prereqs-not-met)
(filter (lambda (test)
(and (vector? test) ;; not (string? test))
(equal? (db:test-get-state test) "COMPLETED")
(not (member (db:test-get-status test)
'("PASS" "WARN" "CHECK" "WAIVED")))))
'("PASS" "WARN" "CHECK" "WAIVED" "SKIP")))))
prereqs-not-met))
(define (runs:calc-not-completed prereqs-not-met)
(filter
(lambda (t)
(or (not (vector? t))
(not (equal? "COMPLETED" (db:test-get-state t)))))
|
| ︙ | | |
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
|
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
|
-
+
-
+
-
+
-
+
-
+
-
+
-
+
|
(debug:print-info 4 "run-limits-info = " run-limits-info)
(cond ;; INNER COND #1 for a launchable test
;; Check item path against item-patts
((not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path)) ;; 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 "Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " test-patts)
(thread-sleep! *global-delta*)
;; (thread-sleep! *global-delta*)
(if (not (null? tal))
(loop (car tal)(cdr tal) reruns)))
( ;; (and
(not (hash-table-ref/default test-registery (runs:make-full-test-name test-name item-path) #f))
;; (and max-concurrent-jobs (> (- max-concurrent-jobs num-running) 5)))
(debug:print-info 4 "Pre-registering test " test-name "/" item-path " to create placeholder" )
(open-run-close db:tests-register-test #f run-id test-name item-path)
(hash-table-set! test-registery (runs:make-full-test-name test-name item-path) #t)
(thread-sleep! *global-delta*)
;; (thread-sleep! *global-delta*)
(runs:shrink-can-run-more-tests-delay)
(loop (car newtal)(cdr newtal) reruns))
((not have-resources) ;; simply try again after waiting a second
(debug:print-info 1 "no resources to run new tests, waiting ...")
(thread-sleep! (+ 2 *global-delta*))
;; (thread-sleep! (+ 2 *global-delta*))
;; could have done hed tal here but doing car/cdr of newtal to rotate tests
(loop (car newtal)(cdr newtal) reruns))
((and have-resources
(or (null? prereqs-not-met)
(and (eq? testmode 'toplevel)
(null? non-completed))))
(run:test run-id runname keyvallst test-record flags #f)
(runs:shrink-can-run-more-tests-delay)
(thread-sleep! *global-delta*)
;; (thread-sleep! *global-delta*)
(if (not (null? tal))
(loop (car tal)(cdr tal) reruns)))
(else ;; must be we have unmet prerequisites
(debug:print 4 "FAILS: " fails)
;; If one or more of the prereqs-not-met are FAIL then we can issue
;; a message and drop hed from the items to be processed.
(if (null? fails)
(begin
;; couldn't run, take a breather
(debug:print-info 4 "Shouldn't really get here, race condition? Unable to launch more tests at this moment, killing time ...")
(thread-sleep! (+ 0.01 *global-delta*)) ;; long sleep here - no resources, may as well be patient
;; (thread-sleep! (+ 0.01 *global-delta*)) ;; long sleep here - no resources, may as well be patient
;; we made new tal by sticking hed at the back of the list
(loop (car newtal)(cdr newtal) reruns))
;; the waiton is FAIL so no point in trying to run hed ever again
(if (not (null? tal))
(if (vector? hed)
(begin (debug:print 1 "WARN: Dropping test " (db:test-get-testname hed) "/" (db:test-get-item-path hed)
" from the launch list as it has prerequistes that are FAIL")
(runs:shrink-can-run-more-tests-delay)
(thread-sleep! *global-delta*)
;; (thread-sleep! *global-delta*)
(loop (car tal)(cdr tal) (cons hed reruns)))
(begin
(debug:print 1 "WARN: Test not processed correctly. Could be a race condition in your test implementation? " hed) ;; " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)")
(runs:shrink-can-run-more-tests-delay)
(thread-sleep! (+ 0.01 *global-delta*))
;; (thread-sleep! (+ 0.01 *global-delta*))
(loop hed tal reruns))))))))) ;; END OF INNER COND
;; case where an items came in as a list been processed
((and (list? items) ;; thus we know our items are already calculated
(not itemdat)) ;; and not yet expanded into the list of things to be done
(if (and (debug:debug-mode 1) ;; (>= *verbosity* 1)
(> (length items) 0)
|
| ︙ | | |
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
|
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
|
-
+
|
(tests:testqueue-set-item_path! new-test-record my-item-path)
(hash-table-set! test-records newtestname new-test-record)
(set! tal (cons newtestname tal)))))) ;; since these are itemized create new test names testname/itempath
items)
(if (not (null? tal))
(begin
(debug:print-info 4 "End of items list, looping with next after short delay")
(thread-sleep! (+ 0.01 *global-delta*))
|
| ︙ | | |
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
|
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
|
-
+
|
(setenv "MT_TEST_NAME" test-name) ;;
(setenv "MT_RUNNAME" runname)
(set-megatest-env-vars run-id) ;; these may be needed by the launching process
(let ((items-list (items:get-items-from-config tconfig)))
(if (list? items-list)
(begin
(tests:testqueue-set-items! test-record items-list)
(thread-sleep! *global-delta*)
;; (thread-sleep! *global-delta*)
(loop hed tal reruns))
(begin
(debug:print 0 "ERROR: The proc from reading the setup did not yield a list - please report this")
(exit 1))))))
((null? fails)
(debug:print-info 4 "fails is null, moving on in the queue but keeping " hed " for now")
;; only increment num-retries when there are no tests runing
|
| ︙ | | |
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
|
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
|
-
+
-
+
-
+
|
(loop (car newtal)(cdr newtal) reruns))) ;; an issue with prereqs not yet met?
((and (not (null? fails))(eq? testmode 'normal))
(debug:print-info 1 "test " hed " (mode=" testmode ") has failed prerequisite(s); "
(string-intersperse (map (lambda (t)(conc (db:test-get-testname t) ":" (db:test-get-state t)"/"(db:test-get-status t))) fails) ", ")
", removing it from to-do list")
(if (not (null? tal))
(begin
(thread-sleep! *global-delta*)
(thread-sleep! (+ 2 *global-delta*))
;; (thread-sleep! (+ 2 *global-delta*))
(loop (car newtal)(cdr newtal) reruns))))) ;; END OF (or (procedure? items)(eq? items 'have-procedure))
;; this case should not happen, added to help catch any bugs
((and (list? items) itemdat)
(debug:print 0 "ERROR: Should not have a list of items in a test and the itemspath set - please report this")
(exit 1))
((not (null? reruns))
(let* ((newlst (tests:filter-non-runnable run-id tal test-records)) ;; i.e. not FAIL, WAIVED, INCOMPLETE, PASS, KILLED,
(junked (lset-difference equal? tal newlst)))
(debug:print-info 4 "full drop through, if reruns is less than 100 we will force retry them, reruns=" reruns ", tal=" tal)
(if (< num-retries max-retries)
(set! newlst (append reruns newlst)))
(set! num-retries (+ num-retries 1))
(thread-sleep! (+ 1 *global-delta*))
;; (thread-sleep! (+ 1 *global-delta*))
(if (not (null? newlst))
;; since reruns have been tacked on to newlst create new reruns from junked
(loop (car newlst)(cdr newlst)(delete-duplicates junked)))))
((not (null? tal))
(debug:print-info 4 "I'm pretty sure I shouldn't get here."))
(else
(debug:print-info 4 "Exiting loop with...\n hed=" hed "\n tal=" tal "\n reruns=" reruns))
|
| ︙ | | |
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
|
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
|
-
+
|
(force (set! runflag #t))
;; NOT_STARTED, run no matter what
((member (test:get-state testdat) '("DELETED" "NOT_STARTED"))(set! runflag #t))
;; not -rerun and PASS, WARN or CHECK, do no run
((and (or (not rerun)
keepgoing)
;; Require to force re-run for COMPLETED or *anything* + PASS,WARN or CHECK
(or (member (test:get-status testdat) '("PASS" "WARN" "CHECK"))
(or (member (test:get-status testdat) '("PASS" "WARN" "CHECK" "SKIP"))
(member (test:get-state testdat) '("COMPLETED"))))
(debug:print-info 2 "running test " test-name "/" item-path " suppressed as it is " (test:get-state testdat) " and " (test:get-status testdat))
(set! runflag #f))
;; -rerun and status is one of the specifed, run it
((and rerun
(let* ((rerunlst (string-split rerun ","))
(must-rerun (member (test:get-status testdat) rerunlst)))
|
| ︙ | | |
Modified server.scm
from [44714046fc]
to [a854b85066].
| ︙ | | |
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
|
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
|
-
+
-
+
|
(if (setup-for-run)
(let ((db (open-db)))
(let loop ()
(let ((last-write-flush-time #f))
(mutex-lock! *incoming-mutex*)
(set! last-write-flush-time *server:last-write-flush*)
(mutex-unlock! *incoming-mutex*)
(if (> (- (current-milliseconds) last-write-flush-time) 400)
(if (> (- (current-milliseconds) last-write-flush-time) 10)
(begin
(mutex-lock! *db:process-queue-mutex*)
(db:process-cached-writes db)
(mutex-unlock! *db:process-queue-mutex*)
(thread-sleep! 0.5))))
(thread-sleep! 0.005))))
(loop)))
(begin
(debug:print 0 "ERROR: failed to setup for Megatest in server:write-queue-handler")
(exit 1))))
;;======================================================================
;; S E R V E R U T I L I T I E S
|
| ︙ | | |
Modified tasks.scm
from [16cec1c8c7]
to [e04939ec8c].
| ︙ | | |
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
|
21
22
23
24
25
26
27
28
29
30
31
32
33
34
|
-
-
-
-
-
-
-
-
|
;;======================================================================
;; Tasks db
;;======================================================================
(define (tasks:open-db)
(let* ((dbpath (conc *toppath* "/monitor.db"))
(exists (file-exists? dbpath))
;; ;; BUGGISHNESS: Remove this code in six months. Today is 11/13/2012
;; (if (< (file-change-time dbpath) 1352851396.0)
;; (begin
;; (debug:print 0 "NOTE: removing old db file " dbpath)
;; (delete-file dbpath)
;; #f)
;; #t)
;; #f))
|
| ︙ | | |
123
124
125
126
127
128
129
130
131
132
133
134
135
136
|
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
|
+
+
+
+
|
(case action
((delete)(sqlite3:execute mdb "DELETE FROM servers WHERE hostname=? AND port=?;" hostname port))
(else (sqlite3:execute mdb "UPDATE servers SET state='dead' WHERE hostname=? AND port=?;" hostname port)))
(debug:print 0 "ERROR: tasks:server-deregister called with neither pid nor port specified"))))
(define (tasks:server-deregister-self mdb hostname)
(tasks:server-deregister mdb hostname pid: (current-process-id)))
;; need a simple call for robustly removing records given host and port
(define (tasks:server-delete mdb hostname port)
(tasks:server-deregister mdb hostname port: port action: 'delete))
(define (tasks:server-get-server-id mdb hostname iface port pid)
(debug:print-info 12 "tasks:server-get-server-id " mdb " " hostname " " iface " " port " " pid)
(let ((res #f))
(sqlite3:for-each-row
(lambda (id)
(set! res id))
|
| ︙ | | |
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
|
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
|
-
+
-
+
+
-
+
+
-
-
+
+
+
+
+
+
|
;; (if (null? tal)
;; #f
;; (loop (car tal)(cdr tal))))))))))
(define (tasks:remove-server-records mdb)
(sqlite3:execute mdb "DELETE FROM servers;"))
(define (tasks:mark-server hostname port pid state)
(define (tasks:mark-server hostname port pid state transport)
(if port
(open-run-close tasks:server-deregister tasks:open-db hostname port: port)
(open-run-close tasks:server-deregister tasks:open-db hostname pid: pid)))
(define (tasks:kill-server status hostname port pid)
(define (tasks:kill-server status hostname port pid transport)
(debug:print-info 1 "Removing defunct server record for " hostname ":" port)
(if port
(open-run-close tasks:server-deregister tasks:open-db hostname port: port)
(open-run-close tasks:server-deregister tasks:open-db hostname pid: pid))
(if status ;; #t means alive
(begin
(if (equal? hostname (get-host-name))
(handle-exceptions
exn
(debug:print-info 0 "server may or may not be dead, check for megatest -server running as pid " pid "\n"
" EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
(debug:print 1 "Sending signal/term to " pid " on " hostname)
(process-signal pid signal/term)
(thread-sleep! 5) ;; give it five seconds to die peacefully then do a brutal kill
;;(process-signal pid signal/kill)
(process-signal pid signal/kill)) ;; local machine, send sig term
) ;; local machine, send sig term
(begin
(debug:print-info 1 "Stopping remote servers not yet supported."))))
(debug:print-info 1 "Telling alive server on " hostname ":" port " to commit servercide")
(cdb:kill-server zmq-socket)))) ;; remote machine, try telling server to commit suicide
;; (debug:print-info 1 "Telling alive server on " hostname ":" port " to commit servercide")
;; (let ((serverdat (list hostname port)))
;; (case (string->symbol transport)
;; ((http)(http-transport:client-connect hostname port))
;; (else (debug:print "ERROR: remote stopping servers of type " transport " not supported yet")))
;; (cdb:kill-server serverdat))))) ;; remote machine, try telling server to commit suicide
(begin
(if status
(if (equal? hostname (get-host-name))
(begin
(debug:print-info 1 "Sending signal/term to " pid " on " hostname)
(process-signal pid signal/term) ;; local machine, send sig term
(thread-sleep! 5) ;; give it five seconds to die peacefully then do a brutal kill
|
| ︙ | | |
Modified tests.scm
from [40dd9ff166]
to [45344ee04b].
| ︙ | | |
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
|
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
|
-
-
+
|
;; 2. logf is same as outputfilename
(let* ((outputfilename (conc "megatest-rollup-" test-name ".html"))
(orig-dir (current-directory))
(logf-info (cdb:remote-run db:test-get-logfile-info #f run-id test-name))
(logf (if logf-info (cadr logf-info) #f))
(path (if logf-info (car logf-info) #f)))
;; This query finds the path and changes the directory to it for the test
(set! logf (car logf-info))
(debug:print 1 "summarize-items with logf " logf)
(debug:print 4 "summarize-items with logf " logf ", outputfilename " outputfilename " and force " force)
(if (or (equal? logf "logs/final.log")
(equal? logf outputfilename)
force)
(begin
(if (obtain-dot-lock outputfilename 1 20 30) ;; retry every second for 20 seconds, call it dead after 30 seconds and steal the lock
(print "Obtained lock for " outputfilename)
(print "Failed to obtain lock for " outputfilename))
|
| ︙ | | |
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
|
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
|
-
+
|
(keep-test #t)
(test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path))
(tdat (cdb:get-test-info-by-id *runremote* test-id)))
(if tdat
(begin
;; Look at the test state and status
(if (or (member (db:test-get-status tdat)
'("PASS" "WARN" "WAIVED" "CHECK"))
'("PASS" "WARN" "WAIVED" "CHECK" "SKIP"))
(member (db:test-get-state tdat)
'("INCOMPLETE" "KILLED")))
(set! keep-test #f))
;; examine waitons for any fails. If it is FAIL or INCOMPLETE then eliminate this test
;; from the runnable list
(if keep-test
|
| ︙ | | |
Modified tests/Makefile
from [1ecc7b9fdb]
to [4cbe947088].
| ︙ | | |
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
|
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
|
-
-
+
+
-
+
-
-
-
-
-
-
+
+
+
+
+
+
|
LOGGING =
OS = $(shell grep ID /etc/*-release|cut -d= -f2)
FS = $(shell df -T .|tail -1|awk '{print $$2}')
VER = $(shell fsl info|grep checkout|awk '{print $$2}'|cut -c 1-5)
# The NEWTARGET causes some tests to fail. Do not use until this is fixed.
NEWTARGET = "-target $(OS)/$(FS)/$(VER)"
TARGET = "-target ubuntu/nfs/none"
NEWTARGET = "$(OS)/$(FS)/$(VER)"
TARGET = "ubuntu/nfs/none"
all : test1 test2 test3 test4 test5
server :
(cd ..;make;make install) && \
(cd fullrun;../../bin/megatest -server - -debug 22)
test0 : cleanprep
cd simplerun ; $(MEGATEST) -server - -debug $(DEBUG)
test1 : cleanprep
rm -f simplerun/megatest.db
rm -rf simplelinks/ simpleruns/
mkdir -p simplelinks simpleruns
cd simplerun;cp ../../*_records.scm .;perl -pi.bak -e 's/define-inline/define/' *_records.scm
cd simplerun;echo '(load "../tests.scm")' | $(MEGATEST) -repl -debug $(DEBUG)
test2 : fullprep
cd fullrun;$(MEGATEST) -runtests ez_pass,runfirst/a/% -reqtarg ubuntu/nfs/none :runname $(RUNNAME) -debug $(DEBUG) $(LOGGING)
cd fullrun;megatest -runall -target ubuntu/nfs/none :runname $(RUNNAME)_01 -testpatt %/,%/ai -debug $(DEBUG)
cd fullrun;megatest -runtests % -target ubuntu/nfs/none :runname $(RUNNAME)_01 -testpatt %/,%/ai -debug $(DEBUG)
cd fullrun;megatest -runtests %/,%/ai -target ubuntu/nfs/none :runname $(RUNAME)_02 -debug $(DEBUG)
cd fullrun;megatest -runtests runfirst/%,%/ai -target ubuntu/nfs/none :runname $(RUNNAME)_02 -debug $(DEBUG)
cd fullrun;megatest -runtests %/,%/winter -target ubuntu/nfs/none :runname $(RUNNAME)_03 -debug $(DEBUG)
sleep 40;cd fullrun;megatest -target ubuntu/nfs/none :runname $(RUNNAME) -set-state-status COMPLETED,FORCED :state COMPLETED :status PASS -testpatt ez_p%s,runfirst/ -debug $(DEBUG) $(LOGGING)
test3 : fullprep
cd fullrun;$(MEGATEST) -runtests runfirst -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -debug 10
test4 : fullprep
cd fullrun;$(MEGATEST) -debug $(DEBUG) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -m "This is a comment specific to a run" -v $(LOGGING)
# NOTE: Only one instance can be a server
test5 : fullprep
cd fullrun;sleep 0;$(MEGATEST) -runall $(TARGET) :runname $(RUNNAME)_aa -debug $(DEBUG) $(LOGGING) > aa.log 2> aa.log &
cd fullrun;sleep 10;$(MEGATEST) -runall $(TARGET) :runname $(RUNNAME)_ab -debug $(DEBUG) $(LOGGING) > ab.log 2> ab.log &
cd fullrun;sleep 10;$(MEGATEST) -runall $(TARGET) :runname $(RUNNAME)_ac -debug $(DEBUG) $(LOGGING) > ac.log 2> ac.log &
cd fullrun;sleep 10;$(MEGATEST) -runall $(TARGET) :runname $(RUNNAME)_ad -debug $(DEBUG) $(LOGGING) > ad.log 2> ad.log &
# cd fullrun;sleep 10;$(MEGATEST) -runall $(TARGET) :runname $(RUNNAME)_ae -debug $(DEBUG) $(LOGGING) > ae.log 2> ae.log &
# cd fullrun;sleep 10;$(MEGATEST) -runall $(TARGET) :runname $(RUNNAME)_af -debug $(DEBUG) $(LOGGING) > af.log 2> af.log &
cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_aa -debug $(DEBUG) $(LOGGING) > aa.log 2> aa.log &
cd fullrun;sleep 10;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ab -debug $(DEBUG) $(LOGGING) > ab.log 2> ab.log &
cd fullrun;sleep 10;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ac -debug $(DEBUG) $(LOGGING) > ac.log 2> ac.log &
cd fullrun;sleep 10;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ad -debug $(DEBUG) $(LOGGING) > ad.log 2> ad.log &
# cd fullrun;sleep 10;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ae -debug $(DEBUG) $(LOGGING) > ae.log 2> ae.log &
# cd fullrun;sleep 10;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_af -debug $(DEBUG) $(LOGGING) > af.log 2> af.log &
test6: fullprep
cd fullrun;$(MEGATEST) -runtests runfirst -testpatt %/1 -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_itempatt -v
cd fullrun;$(MEGATEST) -runtests runfirst -testpatt %blahha% -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_itempatt -debug 10
cd fullrun;$(MEGATEST) -rollup :runname newrun -target ubuntu/nfs/none -debug 10
|
| ︙ | | |
Added tests/fdktestqa/fdk.config version [3481fe6c37].
|
1
2
3
4
5
6
7
8
9
10
11
12
|
+
+
+
+
+
+
+
+
+
+
+
+
|
[fields]
SYSTEM TEXT
RELEASE TEXT
[setup]
# Adjust max_concurrent_jobs to limit how much you load your machines
max_concurrent_jobs 500
# This is your link path, you can move it but it is generally better to keep it stable
linktree #{shell readlink -f #{getenv PWD}/../simplelinks}
[include testqa/configs/megatest.abc.config]
|
| | | | | | | | | | |
Added tests/fdktestqa/testqa/configs/megatest.abc.config version [b0c9fe881b].
|
1
2
3
4
5
6
7
8
9
10
|
+
+
+
+
+
+
+
+
+
+
|
# Valid values for state and status for steps, NB// It is not recommended you use this
[validvalues]
state start end completed
# Job tools are more advanced ways to control how your jobs are launched
[jobtools]
useshell yes
launcher nbfake
[include megatest.def.config]
|
| | | | | | | | |
Added tests/fdktestqa/testqa/configs/megatest.def.config version [614ea68417].
|
1
2
3
4
5
6
7
8
|
+
+
+
+
+
+
+
+
|
# You can override environment variables for all your tests here
[env-override]
EXAMPLE_VAR example value
# As you run more tests you may need to add additional disks, the names are arbitrary but must be unique
[disks]
disk0 #{scheme (nice-path "#{getenv PWD}/../simpleruns")}
|
| | | | | | |
Added tests/fdktestqa/testqa/megatest.config version [c04381f809].
|
1
2
3
4
5
|
+
+
+
+
+
|
[setup]
testcopycmd cp --remove-destination -rlv TEST_SRC_PATH/. TEST_TARG_PATH/.
[include ../fdk.config]
|
| | | |
Added tests/fdktestqa/testqa/runconfigs.config version [346ed47154].
|
1
2
3
4
5
6
|
+
+
+
+
+
+
|
[default]
ALLTESTS see this variable
# Your variables here are grouped by targets [SYSTEM/RELEASE]
[SYSTEM_val/RELEASE_val]
ANOTHERVAR only defined if target is SYSTEM_val/RELEASE_val
|
| | | | |
Added tests/fdktestqa/testqa/tests/bigrun/step1.sh version [8c4fcc7255].
|
1
2
3
|
+
+
+
|
#!/bin/sh
sleep 10
exit 0
|
| |
Added tests/fdktestqa/testqa/tests/bigrun/testconfig version [25b4432948].
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
# Add additional steps here. Format is "stepname script"
[ezsteps]
step1 step1.sh
# Test requirements are specified here
[requirements]
# waiton setup
priority 0
# Iteration for your tests are controlled by the items section
[items]
NUMBER #{scheme (string-intersperse (map number->string (sort (let loop ((a 0)(res '()))(if (< a 120)(loop (+ a 1)(cons a res)) res)) >)) " ")}
# test_meta is a section for storing additional data on your test
[test_meta]
author matt
owner matt
description An example test
tags tagone,tagtwo
reviewed never
|
| | | | | | | | | | | | | | | | | | |
Modified tests/fullrun/megatest.config
from [5787cd5928]
to [d25787fc32].
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
|
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
|
-
+
-
+
|
[fields]
sysname TEXT
fsname TEXT
datapath TEXT
# refareas can be searched to find previous runs
# the path points to where megatest.db exists
[refareas]
area1 /tmp/oldarea/megatest
[include #{getenv MT_RUN_AREA_HOME}/config/mt_include_1.config]
[include config/mt_include_1.config]
[setup]
# It is possible (but not recommended) to override the rsync command used
# to populate the test directories. For test development the following
# example can be useful
#
testcopycmd cp --remove-destination -rsv TEST_SRC_PATH/. TEST_TARG_PATH/.
# or for hard links
# testcopycmd cp --remove-destination -rlv TEST_SRC_PATH/ TEST_TARG_PATH/
# testcopycmd cp --remove-destination -rlv TEST_SRC_PATH/. TEST_TARG_PATH/.
# FULL or 2, NORMAL or 1, OFF or 0
synchronous OFF
# Throttle roughly scales the db access milliseconds to seconds delay
throttle 0.2
# Max retries allows megatest to re-check that a tests status has changed
# as tests can have transient FAIL status occasionally
|
| ︙ | | |
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
|
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
|
-
+
|
# XTERM [system xterm]
# RUNDEAD [system exit 56]
[server]
# If the server can't be started on this port it will try the next port until
# it succeeds
port 8090
port 8080
# This server will keep running this number of hours after last access.
# Three minutes is 0.05 hours
timeout 0.05
## disks are:
## name host:/path/to/area
|
| ︙ | | |