248
249
250
251
252
253
254
255
256
257
258
259
260
261
|
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
289
290
291
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(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))))
(define (dashboard-tests:step-run-control test-id stepname teststeps)
(iup:dialog ;; #:close_cb (lambda (a)(exit)) ; #:expand "YES"
#:title stepname
(iup:vbox ; #:expand "YES"
(iup:label (conc "Step: " stepname "\nNB// These buttons only run the test step\nfor the purpose of debugging.\nNot all database updates are done."))
(iup:button "Re-run"
#:expand "HORIZONTAL"
#:action (lambda (obj)
(print "Rerun " stepname)))
(iup:button "Re-run and continue"
#:expand "HORIZONTAL"
#:action (lambda (obj)
(let ((inprocess #f))
(for-each
(lambda (stepn)
(let ((curr-step-name (vector-ref stepn 0)))
(if (equal? curr-step-name stepname)(set! inprocess #t))
(if inprocess (print "Continue " curr-step-name))))
teststeps))))
;; (iup:button "Refresh test data"
;; #:expand "HORIZONTAL"
;; #:action (lambda (obj)
;; (print "Refresh test data " stepname))
)))
;;======================================================================
;;
;;======================================================================
(define (examine-test test-id) ;; run-id run-key origtest)
(let* ((testdat (open-run-close db:get-test-info-by-id #f test-id))
(db-path (conc *toppath* "/megatest.db"))
|
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
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
|
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
|
-
+
-
+
-
+
-
+
-
+
+
+
-
+
|
(cadr keyval))
keydat)
"/"))
(item-path (db:test-get-item-path testdat))
(viewlog (lambda (x)
(if (file-exists? logfile)
;(system (conc "firefox " logfile "&"))
(iup:send-url logfile)
(dashboard-tests:run-html-viewer logfile)
(message-window (conc "File " logfile " not found")))))
(view-a-log (lambda (lfile)
(view-a-log (lambda (lfile)
(let ((lfilename (conc rundir "/" lfile)))
;; (print "lfilename: " lfilename)
(if (file-exists? lfilename)
;(system (conc "firefox " logfile "&"))
(iup:send-url lfilename)
(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"))
"")))
(system (conc "cd " rundir
";xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&")))
";mt_xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&")))
(message-window (conc "Directory " rundir " not found")))))
(widgets (make-hash-table))
(refreshdat (lambda ()
(let* ((curr-mod-time (max (file-modification-time db-path)
(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)
(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
request-update))
(newtestdat (if need-update
(handle-exceptions
exn
(debug:print-info 2 "test db access issue: " ((condition-property-accessor 'exn 'message) exn))
(open-run-close db:get-test-info-by-id #f test-id )))))
(cond
((and need-update newtestdat)
(set! testdat newtestdat)
(set! teststeps (db:get-compressed-steps test-id work-area: rundir))
(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))
;; (debug:print 0 "INFO: teststeps=" (intersperse teststeps "\n "))
(if (eq? curr-mod-time db-mod-time) ;; do only once if same
(set! db-mod-time (+ curr-mod-time 1))
(set! db-mod-time curr-mod-time)
(set! db-mod-time curr-mod-time))
(set! last-update (current-milliseconds))
(set! request-update #f) ;; met the need ...
)
(need-update ;; if this was true and yet there is no data ....
(db:test-set-testname! testdat "DEAD OR DELETED TEST")))
(if need-update
(begin
|
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
|
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
|
+
-
+
-
-
+
+
+
+
+
|
#:numlin 30
#:numcol-visible 6
#:numlin-visible 5
#:click-cb (lambda (obj lin col status)
;; (if (equal? col 6)
(let* ((mtrx-rc (conc lin ":" 6))
(fname (iup:attribute obj mtrx-rc))) ;; col))))
(if (eq? col 6)
(view-a-log fname)))
(view-a-log fname)
;; (print "obj: " obj " mtrx-rc: " mtrx-rc " fname: " fname " lin: " lin " col: " col " status: " status)))
)))
|