232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
|
(db:test-get-uname testdat))) ;; )
)))))
;; if there is a submegatest create a button to launch dashboard in that area
;;
(define (submegatest-panel dbstruct keydat testdat runname testconfig)
(let* ((subarea (configf:lookup testconfig "setup" "submegatest"))
(area-exists (and subarea (file-exists? subarea))))
;; (debug:print-info 0 *default-log-port* "Megatest subarea=" subarea ", area-exists=" area-exists)
(if subarea
(iup:frame
#:title "Megatest Run Info" ; #:expand "YES"
(iup:button
"Launch Dashboard"
#:action (lambda (obj)
|
|
|
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
|
(db:test-get-uname testdat))) ;; )
)))))
;; if there is a submegatest create a button to launch dashboard in that area
;;
(define (submegatest-panel dbstruct keydat testdat runname testconfig)
(let* ((subarea (configf:lookup testconfig "setup" "submegatest"))
(area-exists (and subarea (common:file-exists? subarea))))
;; (debug:print-info 0 *default-log-port* "Megatest subarea=" subarea ", area-exists=" area-exists)
(if subarea
(iup:frame
#:title "Megatest Run Info" ; #:expand "YES"
(iup:button
"Launch Dashboard"
#:action (lambda (obj)
|
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
|
(cadr keyval))
keydat)
"/"))
(item-path (db:test-get-item-path testdat))
;; this next block was added to fix a bug where variables were
;; needed. Revisit this.
(runconfig (let ((runconfigf (conc *toppath* "/runconfigs.config"))) ;; no rush but it would be good to convert this call to use runconfig:read
(if (file-exists? runconfigf)
(handle-exceptions
exn
#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
(conc "cd " rundir
";mt_xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&")
"MT_.*"))
(message-window (conc "Directory " rundir " not found")))))
(widgets (make-hash-table))
(refreshdat (lambda ()
(let* ((curr-mod-time (file-modification-time db-path))
;; (max ..... (if (file-exists? testdat-path)
;; (file-modification-time testdat-path)
;; (begin
;; (set! testdat-path (conc rundir "/testdat.db"))
;; 0))))
(need-update (or (and (>= curr-mod-time db-mod-time)
(> (current-milliseconds)(+ last-update 250))) ;; every half seconds if db touched
(> (current-milliseconds)(+ last-update 10000)) ;; force update even 10 seconds
|
|
|
|
|
|
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
|
(cadr keyval))
keydat)
"/"))
(item-path (db:test-get-item-path testdat))
;; this next block was added to fix a bug where variables were
;; needed. Revisit this.
(runconfig (let ((runconfigf (conc *toppath* "/runconfigs.config"))) ;; no rush but it would be good to convert this call to use runconfig:read
(if (common:file-exists? runconfigf)
(handle-exceptions
exn
#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 (common: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 (common: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
(conc "cd " rundir
";mt_xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&")
"MT_.*"))
(message-window (conc "Directory " rundir " not found")))))
(widgets (make-hash-table))
(refreshdat (lambda ()
(let* ((curr-mod-time (file-modification-time db-path))
;; (max ..... (if (common:file-exists? testdat-path)
;; (file-modification-time testdat-path)
;; (begin
;; (set! testdat-path (conc rundir "/testdat.db"))
;; 0))))
(need-update (or (and (>= curr-mod-time db-mod-time)
(> (current-milliseconds)(+ last-update 250))) ;; every half seconds if db touched
(> (current-milliseconds)(+ last-update 10000)) ;; force update even 10 seconds
|