| ︙ | | |
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
|
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
|
-
+
+
-
+
-
+
|
(newstate #f)
(wtxtbox #f))
(iup:frame
#:title "Set fields"
(iup:vbox
(iup:hbox (iup:label "Comment:")
(let ((txtbox (iup:textbox #:action (lambda (val a b)
(rmt:test-set-state-status-by-id run-id test-id #f #f b)
;; (rmt:test-set-state-status-by-id run-id test-id #f #f b)
(rmt:test-set-state-status run-id test-id #f #f b)
;; IDEA: Just set a variable with the proc to call?
(rmt:test-set-state-status-by-id run-id test-id #f #f b)
;; (rmt:test-set-state-status-by-id run-id test-id #f #f b)
(set! newcomment b))
#:value (db:test-get-comment testdat)
#:expand "HORIZONTAL")))
(set! wtxtbox txtbox)
txtbox))
(apply iup:hbox
(iup:label "STATE:" #:size "30x")
(let* ((btns (map (lambda (state)
(let ((btn (iup:button state
#:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10"
#:action (lambda (x)
;; (rmt:test-set-state-status-by-id run-id test-id state #f #f)
(rmt:roll-up-pass-fail-counts run-id test-id #f state #f #f) ;; test-name passed in as test-id is respected
(rmt:set-state-status-and-roll-up-items run-id test-id #f state #f #f) ;; test-name passed in as test-id is respected
(db:test-set-state! testdat state)))))
btn))
(map cadr *common:std-states*)))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ"))))
(vector-set! *state-status* 0
(lambda (state color)
(for-each
(lambda (btn)
|
| ︙ | | |
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
|
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
|
-
+
|
(begin
(iup:attribute-set! wtxtbox "VALUE" c)
(if (not *dashboard-comment-share-slot*)
(set! *dashboard-comment-share-slot* wtxtbox)))
))))
(begin
;; (rmt:test-set-state-status-by-id run-id test-id #f status #f)
(rmt:roll-up-pass-fail-counts run-id test-id #f #f status #f) ;; test-name passed in as test-id is respected
(rmt:set-state-status-and-roll-up-items run-id test-id #f #f status #f) ;; test-name passed in as test-id is respected
(db:test-set-status! testdat status))))))))
btn))
(map cadr *common:std-statuses*)))) ;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP"))))
(vector-set! *state-status* 1
(lambda (status color)
(for-each
(lambda (btn)
|
| ︙ | | |
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
|
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
|
-
+
+
|
#:expand "HORIZONTAL"
#:action (lambda (obj)
(let ((comment (iup:attribute comnt "VALUE"))
(test-id (db:test-get-id testdat)))
(if (or (not wpatt)
(string-match wregx comment))
(begin
(rmt:test-set-state-status-by-id run-id test-id #f "WAIVED" comment)
;; (rmt:test-set-state-status-by-id run-id test-id #f "WAIVED" comment)
(rmt:test-set-state-status-by run-id test-id #f "WAIVED" comment)
(db:test-set-status! testdat "WAIVED")
(cmtcmd comment)
(iup:destroy! dlog))))))
(iup:button "Cancel"
#:expand "HORIZONTAL"
#:action (lambda (obj)
(iup:destroy! dlog)))))))
|
| ︙ | | |
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
|
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
|
-
+
|
(setup-env-defaults runconfigf run-id (make-hash-table) keydat environ-patt: keystring))
(make-hash-table))))
(testconfig (begin
;; (runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path)
(runs:set-megatest-env-vars run-id inkeyvals: keydat inrunname: runname intarget: keystring testname: testname itempath: item-path) ;; these may be needed by the launching process
(handle-exceptions
exn
(tests:get-testconfig (db:test-get-testname testdat) test-registry #f)
(tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f)
(tests:get-testconfig (db:test-get-testname testdat) test-registry #t))))
(viewlog (lambda (x)
(if (file-exists? logfile)
;(system (conc "firefox " logfile "&"))
(dashboard-tests:run-html-viewer logfile)
(message-window (conc "File " logfile " not found")))))
(view-a-log (lambda (lfile)
|
| ︙ | | |