245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
|
btns))))))
;;======================================================================
;;
;;======================================================================
(define (examine-test db test-id) ;; run-id run-key origtest)
(let* ((testdat (rdb:get-test-data-by-id db test-id)))
(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 (rdb:get-key-val-pairs db run-id) #f))
(rundat (if testdat (rdb:get-run-info db run-id) #f))
|
|
>
>
>
>
|
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
|
btns))))))
;;======================================================================
;;
;;======================================================================
(define (examine-test db test-id) ;; run-id run-key origtest)
(let* ((testdat (rdb:get-test-data-by-id db test-id))
(db-path (conc *toppath* "/megatest.db"))
(db-mod-time (file-modification-time db-path))
(last-update (current-seconds))
(request-update #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 (rdb:get-key-val-pairs db run-id) #f))
(rundat (if testdat (rdb:get-run-info db run-id) #f))
|
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
|
(let ((shell (if (get-environment-variable "SHELL")
(conc "-e " (get-environment-variable "SHELL"))
"")))
(system (conc "cd " rundir
";xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&")))
(message-window (conc "Directory " rundir " not found")))))
(refreshdat (lambda ()
(let ((newtestdat (rdb:get-test-data-by-id db test-id)))
(if newtestdat
(begin
;(mutex-lock! mx1)
(set! testdat newtestdat)
(set! teststeps (rdb: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))
;(mutex-unlock! mx1)
)
(begin
(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
(lambda (testdat)
(let ((newval (cmd testdat))
|
>
>
>
>
|
>
|
<
<
|
|
|
|
|
<
<
<
>
|
|
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
|
(let ((shell (if (get-environment-variable "SHELL")
(conc "-e " (get-environment-variable "SHELL"))
"")))
(system (conc "cd " rundir
";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 (rdb:get-test-data-by-id db test-id))))
(cond
((and need-update newtestdat)
(set! testdat newtestdat)
(set! teststeps (rdb: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)))
(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
(lambda (testdat)
(let ((newval (cmd testdat))
|