202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
|
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
|
-
+
-
+
-
+
-
+
-
-
+
+
-
+
|
(newstatus #f)
(newstate #f))
(iup:frame
#:title "Set fields"
(iup:vbox
(iup:hbox (iup:label "Comment:")
(iup:textbox #:action (lambda (val a b)
(cdb:remote-run db:test-set-state-status-by-id #f test-id #f #f b)
(open-run-close db:test-set-state-status-by-id #f test-id #f #f b)
(set! newcomment b))
#:value (db:test-get-comment testdat)
#:expand "HORIZONTAL"))
(apply iup:hbox
(iup:label "STATE:" #:size "30x")
(let* ((btns (map (lambda (state)
(let ((btn (iup:button state
#:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10"
#:action (lambda (x)
(cdb:remote-run db:test-set-state-status-by-id #f test-id state #f #f)
(open-run-close db:test-set-state-status-by-id #f test-id state #f #f)
(db:test-set-state! testdat state)))))
btn))
(list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "KILLED" "KILLREQ"))))
(vector-set! *state-status* 0
(lambda (state color)
(for-each
(lambda (btn)
(let* ((name (iup:attribute btn "TITLE"))
(newcolor (if (equal? name state) color "192 192 192")))
(if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR")))
(iup:attribute-set! btn "BGCOLOR" newcolor))))
btns)))
btns))
(apply iup:hbox
(iup:label "STATUS:" #:size "30x")
(let* ((btns (map (lambda (status)
(let ((btn (iup:button status
#:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10"
#:action (lambda (x)
(cdb:remote-run db:test-set-state-status-by-id #f test-id #f status #f)
(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"))))
(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")))
(iup:attribute-set! btn "BGCOLOR" newcolor))))
btns)))
btns))))))
;;======================================================================
;;
;;======================================================================
(define (examine-test test-id) ;; run-id run-key origtest)
(let* ((testdat (cdb:remote-run db:get-test-info-by-id #f test-id))
(let* ((testdat (open-run-close db:get-test-info-by-id #f test-id))
(db-path (conc *toppath* "/megatest.db"))
(db-mod-time 0) ;; (file-modification-time db-path))
(last-update 0) ;; (current-seconds))
(request-update #t)
(db #f))
(if (not testdat)
(begin
(debug:print 0 "ERROR: No test data found for test " test-id ", exiting")
(exit 1))
(let* ((run-id (if testdat (db:test-get-run_id testdat) #f))
(keydat (if testdat (cdb:remote-run db:get-key-val-pairs #f run-id) #f))
(rundat (if testdat (cdb:remote-run db:get-run-info #f run-id) #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))
(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 (cdb:remote-run db:testmeta-get-record #f testname)))
(let ((tm (open-run-close db:testmeta-get-record #f testname)))
(if tm tm (make-db:testmeta)))
(make-db:testmeta)))
(keystring (string-intersperse
(map (lambda (keyval)
;; (conc ":" (car keyval) " " (cadr keyval)))
(cadr keyval))
|
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
|
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
|
-
+
|
";xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&")))
(message-window (conc "Directory " rundir " not found")))))
(refreshdat (lambda ()
(let* ((curr-mod-time (file-modification-time db-path))
(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 (cdb:remote-run db:get-test-info-by-id #f test-id))))
(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! 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)))
|
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
|
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
|
-
+
|
(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)))
(cdb:remote-run db:read-test-data #f test-id "%")))
(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)))
)))
(iup:show self)
(iup:callback-set! *tim* "ACTION_CB"
|