Overview
Context
Changes
Modified dashboard-tests.scm
from [8dedb87be4]
to [aeb4fe9dfc].
| ︙ | | |
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
|
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
|
-
+
|
btns)))
btns))))))
;;======================================================================
;;
;;======================================================================
(define (examine-test db test-id mx1) ;; run-id run-key origtest)
(define (examine-test db test-id) ;; run-id run-key origtest)
(let* ((testdat (db:get-test-data-by-id db test-id))
(run-id (if testdat (db:test-get-run_id testdat) #f))
(keydat (if testdat (keys:get-key-val-pairs db run-id) #f))
(rundat (if testdat (db:get-run-info db run-id) #f))
(runname (if testdat (db:get-value-by-header (db:get-row rundat)
(db:get-header rundat)
"runname") #f))
|
| ︙ | | |
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
|
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
|
-
+
-
+
+
-
+
-
+
+
|
(system (conc "cd " rundir
";xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&")))
(message-window (conc "Directory " rundir " not found")))))
(refreshdat (lambda ()
(let ((newtestdat (db:get-test-data-by-id db test-id)))
(if newtestdat
(begin
(mutex-lock! mx1)
;(mutex-lock! mx1)
(set! testdat newtestdat)
(set! teststeps (db: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))
;(mutex-unlock! mx1)
)
(begin
(db:test-set-testname! testdat "DEAD OR DELETED TEST"))))))
(widgets (make-hash-table))
(self #f)
(store-label (lambda (name lbl cmd)
(hash-table-set! widgets name
(lambda (testdat)
(let ((newval (cmd testdat))
(oldval (iup:attribute lbl "TITLE")))
(if (not (equal? newval oldval))
(begin
(mutex-lock! mx1)
;(mutex-lock! mx1)
(iup:attribute-set! lbl "TITLE" newval)
(mutex-unlock! mx1))))))
;(mutex-unlock! mx1)
)))))
lbl))
(store-button store-label))
(cond
((not testdat)(begin (print "ERROR: bad test info for " test-id)(exit 1)))
((not rundat)(begin (print "ERROR: found test info but there is a problem with the run info for " run-id)(exit 1)))
(else
;; (test-set-status! db run-id test-name state status itemdat)
|
| ︙ | | |
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
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
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
|
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
|
+
+
-
+
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
-
-
-
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
(db:step-get-event_time x)))))
(db:get-steps-for-test db test-id)))
"\n")))
(if (not (equal? currval newval))
(iup:attribute-set! stepsdat "TITLE" newval)))))
stepsdat)))))
(iup:show self)
(iup:callback-set! *tim* "ACTION_CB"
(lambda (x)
;; Now start keeping the gui updated from the db
(let loop ((i 0))
(thread-sleep! 0.1)
(refreshdat) ;; update from the db here
;(thread-suspend! other-thread)
;; update the gui elements here
(for-each
(lambda (key)
;; (print "Updating " key)
((hash-table-ref widgets key) testdat))
(hash-table-keys widgets))
(update-state-status-buttons testdat)
; (iup:refresh self)
(iup:main-loop-flush)
(if *exit-started*
(set! *exit-started* 'ok)
(loop i)))))))
;;
;; (iup:frame (iup:label (conc "TESTNAME:\n" testfullname) #:expand "YES")))
;; (iup:frame #:title "Actions" #:expand "YES"
;; (iup:hbox ;; the actions box
;; (iup:button "View Log" #:action viewlog #:expand "YES")
;; (iup:button "Start Xterm" #:action xterm #:expand "YES")))
;; (iup:frame #:title "Set fields"
;; (iup:vbox
;; (iup:hbox
;; (iup:vbox ;; the state
;; (iup:label "STATE:" #:size "30x")
;; (let ((lb (iup:listbox #:action (lambda (val a b c)
;; ;; (print val " a: " a " b: " b " c: " c)
;; (set! newstate a))
;; #:editbox "YES"
;; #:expand "YES")))
;; (iuplistbox-fill-list lb
;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "KILLED" "KILLREQ")
;; currstate)
;; lb))
;; (iup:vbox ;; the status
;; (iup:label "STATUS:" #:size "30x")
;; (let ((lb (iup:listbox #:action (lambda (val a b c)
;; (set! newstatus a))
;; #:editbox "YES"
;; #:value currstatus
;; #:expand "YES")))
;; (iuplistbox-fill-list lb
;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a")
;; currstatus)
;; lb)))
;; (iup:hbox (iup:label "Comment:")
;; (iup:textbox #:action (lambda (val a b)
;; (set! currcomment b))
;; #:value currcomment
;; #:expand "YES"))
;; (iup:button "Apply"
;; #:expand "YES"
;; #:action (lambda (x)
;; (test-set-status! *db* run-id testname newstate newstatus itempath currcomment)))
;; (iup:hbox (iup:button "Apply and close"
;; #:expand "YES"
;; #:action (lambda (x)
;; (hash-table-delete! *examine-test-dat* testkey)
;; (test-set-status! *db* run-id testname newstate newstatus itempath currcomment)
;; (iup:destroy! self)))
;; (iup:button "Cancel and close"
;; #:expand "YES"
;; #:action (lambda (x)
;; (hash-table-delete! *examine-test-dat* testkey)
;; (iup:destroy! self))))
;; )))
;; (iup:hbox ;; the test steps are tracked here
;; (let ((stepsdat (iup:label "Test steps ........................................." #:expand "YES")))
;; (hash-table-set! widgets "Test Steps" stepsdat)
;; stepsdat)
;; ))))
|
Modified dashboard.scm
from [e93ad79735]
to [e9212eda7d].
| ︙ | | |
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
|
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
|
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
|
(pad-list *allruns* numruns)))
(lftcol (vector-ref uidat 0))
(tableheader (vector-ref uidat 1))
(table (vector-ref uidat 2))
(coln 0))
(set! *alltestnamelst* '())
;; create a concise list of test names
(for-each (lambda (rundat)
(if (vector? rundat)
(let* ((testdat (vector-ref rundat 1))
(testnames (map test:test-get-fullname testdat)))
(for-each (lambda (testname)
(if (not (member testname *alltestnamelst*))
(begin
(set! *alltestnamelst* (append *alltestnamelst* (list testname))))))
testnames))))
runs)
(for-each
(lambda (rundat)
(if (vector? rundat)
(let* ((testdat (vector-ref rundat 1))
(testnames (map test:test-get-fullname testdat)))
(for-each (lambda (testname)
(if (not (member testname *alltestnamelst*))
(begin
(set! *alltestnamelst* (append *alltestnamelst* (list testname))))))
testnames))))
runs)
(set! *alltestnamelst* (collapse-rows *alltestnamelst*)) ;;; argh. please clean up this sillyness
(set! *alltestnamelst* (let ((xl (if (> (length *alltestnamelst*) *start-test-offset*)
(drop *alltestnamelst* *start-test-offset*)
'())))
(append xl (make-list (- *num-tests* (length xl)) ""))))
(update-labels uidat)
|
| ︙ | | |
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
|
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
|
+
+
+
+
+
-
+
-
-
-
-
+
-
-
-
-
-
-
+
+
+
-
-
-
-
+
-
-
-
-
+
+
+
+
-
-
+
+
+
+
-
-
+
+
-
-
+
-
-
-
-
|
(get-environment-variable "DASHBOARDROWS" ))
(begin
(set! *num-tests* (string->number (or (args:get-arg "-rows")
(get-environment-variable "DASHBOARDROWS"))))
(update-rundat "%" *num-runs* "%" "%"))
(set! *num-tests* (min (max (update-rundat "%" *num-runs* "%" "%") 8) 20)))
(define *tim* (iup:timer))
(define *ord* #f)
(iup:attribute-set! *tim* "TIME" 300)
(iup:attribute-set! *tim* "RUN" "YES")
(define (run-update mtx1)
(define (run-update x)
(let loop ((i 0))
(thread-sleep! 0.05)
(mutex-lock! mtx1)
(update-buttons uidat *num-runs* *num-tests*)
(mutex-unlock! mtx1)
(iup:main-loop-flush)
(mutex-lock! mtx1)
(update-rundat (hash-table-ref/default *searchpatts* "runname" "%") *num-runs*
(hash-table-ref/default *searchpatts* "test-name" "%")
(hash-table-ref/default *searchpatts* "item-name" "%"))
(mutex-unlock! mtx1)
(loop i)))
(define *job* #f)
(set! *job* (lambda (mx1)
(on-exit (lambda ()
(sqlite3:finalize! *db*)))
(examine-run *db* runid)))
(lambda (x)
(on-exit (lambda ()
(sqlite3:finalize! *db*)))
(examine-run *db* runid)))
(begin
(print "ERROR: runid is not a number " (args:get-arg "-run"))
(exit 1)))))
((args:get-arg "-test")
(let ((testid (string->number (args:get-arg "-test"))))
(if testid
(set! *job* (lambda (mx1)
(examine-test *db* testid mx1)))
(set! *job* (lambda (mtx1)(run-update mtx1)))))
(run-update x)))))
;(print x)))))
(let* ((mx1 (make-mutex))
(th2 (make-thread iup:main-loop))
(th1 (make-thread (*job* mx1))))
(thread-start! th1)
(thread-start! th2)
(thread-join! th2))
|