335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
|
(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 (dashboard-tests:run-html-viewer lfilename)
(let ((htmlviewercmd (configf:lookup *configdat* "setup" "htmlviewercmd")))
(if htmlviewercmd
(system (conc "(" htmlviewercmd " " lfilename " ) &"))
(iup:send-url lfilename))))
|
<
<
<
<
<
<
|
335
336
337
338
339
340
341
342
343
344
345
346
347
348
|
(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 (dashboard-tests:run-a-step info)
#t)
(define (dashboard-tests:step-run-control testdat stepname testconfig)
(iup:dialog ;; #:close_cb (lambda (a)(exit)) ; #:expand "YES"
#:title stepname
(iup:vbox ; #:expand "YES"
|
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
|
#: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 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)))))))
|
|
|
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
|
#: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 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)))))))
|
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
|
#f ;; do nothing, just keep on trucking ....
(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) (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)
(let ((lfilename (conc rundir "/" lfile)))
;; (print "lfilename: " lfilename)
(if (file-exists? lfilename)
;(system (conc "firefox " logfile "&"))
(dashboard-tests:run-html-viewer lfilename)
(message-window (conc "File " lfilename " not found"))))))
(xterm (lambda (x)
(if (directory-exists? rundir)
(let ((shell (if (get-environment-variable "SHELL")
(conc "-e " (get-environment-variable "SHELL"))
"")))
(common:without-vars
|
|
|
|
|
|
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
|
#f ;; do nothing, just keep on trucking ....
(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 ;; NOTE: I've no idea why this was written this way. Research, study and fix needed!
(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) item-path test-registry #t))))
(viewlog (lambda (x)
(if (file-exists? logfile)
;(system (conc "firefox " logfile "&"))
(dcommon:run-html-viewer logfile)
(message-window (conc "File " logfile " not found")))))
(view-a-log (lambda (lfile)
(let ((lfilename (conc rundir "/" lfile)))
;; (print "lfilename: " lfilename)
(if (file-exists? lfilename)
;(system (conc "firefox " logfile "&"))
(dcommon:run-html-viewer lfilename)
(message-window (conc "File " lfilename " not found"))))))
(xterm (lambda (x)
(if (directory-exists? rundir)
(let ((shell (if (get-environment-variable "SHELL")
(conc "-e " (get-environment-variable "SHELL"))
"")))
(common:without-vars
|