︙ | | | ︙ | |
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
|
(declare (uses vg))
(declare (uses subrun))
;; (declare (uses dashboard-main))
(declare (uses mt))
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "task_records.scm")
(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
(include "vg_records.scm")
(define help (conc
"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
|
<
|
46
47
48
49
50
51
52
53
54
55
56
57
58
59
|
(declare (uses vg))
(declare (uses subrun))
;; (declare (uses dashboard-main))
(declare (uses mt))
(include "common_records.scm")
(include "db_records.scm")
(include "task_records.scm")
(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
(include "vg_records.scm")
(define help (conc
"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
|
︙ | | | ︙ | |
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
|
(hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) path #f)
#f))
(define (new-tree-path->run-id rdat path)
(if (not (null? path))
(hash-table-ref/default (dboard:rdat-path-run-ids tabdat) path #f)
#f))
;; (define (dboard:get-tests-dat tabdat run-id last-update)
;; (let* ((access-mode (dboard:tabdat-access-mode tabdat))
;; (tdat (if run-id (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run
;; run-id
;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
;; (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)) ;; '()
;; (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)) ;; '()
;; #f #f ;; offset limit
;; (dboard:tabdat-hide-not-hide tabdat) ;; not-in
;; #f #f ;; sort-by sort-order
;; #f ;; get all? "id,testname,item_path,state,status,event_time,run_duration" ;; qryval
;; (if (dboard:tabdat-filters-changed tabdat)
;; 0
;; last-update)
;; *dashboard-mode*)
;; '()))) ;; get 'em all
;; ;; (debug:print 0 *default-log-port* "dboard:get-tests-dat: got " (length tdat) " test records for run " run-id)
;; (sort tdat (lambda (a b)
;; (let* ((aval (vector-ref a 2))
;; (bval (vector-ref b 2))
;; (anum (string->number aval))
;; (bnum (string->number bval)))
;; (if (and anum bnum)
;; (< anum bnum)
;; (string<= aval bval)))))))
(define (dashboard:safe-cadr-assoc name lst)
(let ((res (assoc name lst)))
(if (and res (> (length res) 1))
(cadr res)
#f)))
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
|
(hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) path #f)
#f))
(define (new-tree-path->run-id rdat path)
(if (not (null? path))
(hash-table-ref/default (dboard:rdat-path-run-ids tabdat) path #f)
#f))
(define (dashboard:safe-cadr-assoc name lst)
(let ((res (assoc name lst)))
(if (and res (> (length res) 1))
(cadr res)
#f)))
|
︙ | | | ︙ | |
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
|
(lambda ()
;; Bummer - we dont have the global get/set api mapped in chicken
;; (let* ((modkeys (iup:global "MODKEYSTATE")))
;; (BB> "modkeys="modkeys))
(debug:print-info 13 *default-log-port* "click-cb: obj="obj" lin="lin" col="col" status="status)
;; status is corrupted on Brandon's home machine. will have to wait until after shutdown to see if it is still broken in PDX SLES
(let* ((toolpath (car (argv)))
(key (conc lin ":" col))
(test-id (hash-table-ref/default cell-lookup key -1))
(run-id (dboard:tabdat-curr-run-id tabdat))
(run-info (rmt:get-run-info run-id))
(target (rmt:get-target run-id))
(runname (db:get-value-by-header (db:get-rows run-info)
|
<
|
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
|
(lambda ()
;; Bummer - we dont have the global get/set api mapped in chicken
;; (let* ((modkeys (iup:global "MODKEYSTATE")))
;; (BB> "modkeys="modkeys))
(debug:print-info 13 *default-log-port* "click-cb: obj="obj" lin="lin" col="col" status="status)
(let* ((toolpath (car (argv)))
(key (conc lin ":" col))
(test-id (hash-table-ref/default cell-lookup key -1))
(run-id (dboard:tabdat-curr-run-id tabdat))
(run-info (rmt:get-run-info run-id))
(target (rmt:get-target run-id))
(runname (db:get-value-by-header (db:get-rows run-info)
|
︙ | | | ︙ | |
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
|
#:action (lambda (obj val index lbstate)
(set! *tests-sort-reverse* index)
(mark-for-update tabdat))))
(default-cmd (car (list-ref *tests-sort-type-index* *tests-sort-reverse*))))
(iuplistbox-fill-list sort-lb cmds-list selected-item: default-cmd)
;; (set! hide-empty (iup:button "HideEmpty"
;; ;; #:expand HORIZONTAL"
;; #:expand "NO" #:size "80x15"
;; #:action (lambda (obj)
;; (dboard:tabdat-hide-empty-runs-set! tabdat (not (dboard:tabdat-hide-empty-runs tabdat)))
;; (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-empty-runs tabdat) "+HideE" "-HideE"))
;; (mark-for-update tabdat))))
(set! hide (iup:button "Hide"
#:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL"
#:action (lambda (obj)
(dboard:tabdat-hide-not-hide-set! tabdat #t) ;; (not (dboard:tabdat-hide-not-hide tabdat)))
;; (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-not-hide tabdat) "HideTests" "NotHide"))
(iup:attribute-set! hide "BGCOLOR" sel-color)
(iup:attribute-set! show "BGCOLOR" nonsel-color)
(mark-for-update tabdat))))
(set! show (iup:button "Show"
#:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL"
#:action (lambda (obj)
(dboard:tabdat-hide-not-hide-set! tabdat #f) ;; (not (dboard:tabdat-hide-not-hide tabdat)))
(iup:attribute-set! show "BGCOLOR" sel-color)
(iup:attribute-set! hide "BGCOLOR" nonsel-color)
(mark-for-update tabdat))))
(iup:attribute-set! hide "BGCOLOR" sel-color)
(iup:attribute-set! show "BGCOLOR" nonsel-color)
;; (dboard:tabdat-hide-not-hide-button-set! tabdat hideit) ;; never used, can eliminate ...
(iup:vbox
(iup:hbox hide show)
sort-lb)))
)
;; insert extra widget here
(if extra-widget
extra-widget
(iup:hbox)) ;; empty widget
)))
(let* ((status-toggles (map (lambda (status)
(iup:toggle (conc status)
#:fontsize 8 ;; btn-fontsz ;; "10"
;; #:expand "HORIZONTAL"
|
<
<
<
<
<
<
<
<
<
<
<
|
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
|
#:action (lambda (obj val index lbstate)
(set! *tests-sort-reverse* index)
(mark-for-update tabdat))))
(default-cmd (car (list-ref *tests-sort-type-index* *tests-sort-reverse*))))
(iuplistbox-fill-list sort-lb cmds-list selected-item: default-cmd)
(set! hide (iup:button "Hide"
#:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL"
#:action (lambda (obj)
(dboard:tabdat-hide-not-hide-set! tabdat #t) ;; (not (dboard:tabdat-hide-not-hide tabdat)))
;; (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-not-hide tabdat) "HideTests" "NotHide"))
(iup:attribute-set! hide "BGCOLOR" sel-color)
(iup:attribute-set! show "BGCOLOR" nonsel-color)
(mark-for-update tabdat))))
(set! show (iup:button "Show"
#:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL"
#:action (lambda (obj)
(dboard:tabdat-hide-not-hide-set! tabdat #f) ;; (not (dboard:tabdat-hide-not-hide tabdat)))
(iup:attribute-set! show "BGCOLOR" sel-color)
(iup:attribute-set! hide "BGCOLOR" nonsel-color)
(mark-for-update tabdat))))
(iup:attribute-set! hide "BGCOLOR" sel-color)
(iup:attribute-set! show "BGCOLOR" nonsel-color)
(iup:vbox
(iup:hbox hide show)
sort-lb)))
)
;; insert extra widget here
(if extra-widget
extra-widget
(iup:hbox)) ;; empty widget
)))
(let* ((status-toggles (map (lambda (status)
(iup:toggle (conc status)
#:fontsize 8 ;; btn-fontsz ;; "10"
;; #:expand "HORIZONTAL"
|
︙ | | | ︙ | |
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
|
(define (dashboard:recalc modtime please-update-buttons last-db-update-time)
(or please-update-buttons
(and ;; (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) ;; can't use this - it needs to be tab specific
(> modtime (- last-db-update-time 3)) ;; add three seconds of margin
(> (current-seconds)(+ last-db-update-time 1)))))
;; (define *monitor-db-path* #f)
(define *last-monitor-update-time* 0)
;; Force creation of the db in case it isn't already there.
;; (tasks:open-db)
(define (dashboard:get-youngest-run-db-mod-time dbdir)
(handle-exceptions
|
<
|
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
|
(define (dashboard:recalc modtime please-update-buttons last-db-update-time)
(or please-update-buttons
(and ;; (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) ;; can't use this - it needs to be tab specific
(> modtime (- last-db-update-time 3)) ;; add three seconds of margin
(> (current-seconds)(+ last-db-update-time 1)))))
(define *last-monitor-update-time* 0)
;; Force creation of the db in case it isn't already there.
;; (tasks:open-db)
(define (dashboard:get-youngest-run-db-mod-time dbdir)
(handle-exceptions
|
︙ | | | ︙ | |
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
|
(vg:drawing-cache-set! dwg '())
(dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table))
;; (dboard:tabdat-allruns-set! tabdat '())
(dboard:tabdat-max-row-set! tabdat 0)
(dboard:tabdat-last-filter-str-set! tabdat filtrstr)))
(update-rundat tabdat
runpatt
;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%")
(dboard:tabdat-numruns tabdat)
testpatt ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%")
targpatt
;; old method
;; (let ((res '()))
;; (for-each (lambda (key)
;; (if (not (equal? key "runname"))
;; (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f)))
;; (if val (set! res (cons (list key val) res))))))
;; (dboard:tabdat-dbkeys tabdat))
;; res)
)))))
;; run times canvas updater
;;
(define (dashboard:run-times-tab-canvas-updater commondat tabdat tab-num)
(let ((cnv (dboard:tabdat-cnv tabdat))
(dwg (dboard:tabdat-drawing tabdat))
(mtx (dboard:tabdat-runs-mutex tabdat))
(vch (dboard:tabdat-view-changed tabdat)))
(if (and cnv dwg vch)
(begin
(vg:drawing-xoff-set! dwg (dboard:tabdat-xadj tabdat))
(vg:drawing-yoff-set! dwg (dboard:tabdat-yadj tabdat))
(mutex-lock! mtx)
(canvas-clear! cnv)
(vg:draw dwg tabdat)
(mutex-unlock! mtx)
(dboard:tabdat-view-changed-set! tabdat #f)))))
;; doesn't work.
;;
;;(define (gotoescape tabdat escape)
;; (or (dboard:tabdat-layout-update-ok tabdat)
;; (escape #t)))
(define (dboard:graph-db-open dbstr)
(let* ((parts (string-split dbstr ":"))
(dbpth (if (< (length parts) 2) ;; assume then a filename was provided
dbstr
(if (equal? (car parts) "sqlite3")
(cadr parts)
(begin
|
<
<
<
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
|
(vg:drawing-cache-set! dwg '())
(dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table))
;; (dboard:tabdat-allruns-set! tabdat '())
(dboard:tabdat-max-row-set! tabdat 0)
(dboard:tabdat-last-filter-str-set! tabdat filtrstr)))
(update-rundat tabdat
runpatt
(dboard:tabdat-numruns tabdat)
testpatt
targpatt)))))
;; run times canvas updater
;;
(define (dashboard:run-times-tab-canvas-updater commondat tabdat tab-num)
(let ((cnv (dboard:tabdat-cnv tabdat))
(dwg (dboard:tabdat-drawing tabdat))
(mtx (dboard:tabdat-runs-mutex tabdat))
(vch (dboard:tabdat-view-changed tabdat)))
(if (and cnv dwg vch)
(begin
(vg:drawing-xoff-set! dwg (dboard:tabdat-xadj tabdat))
(vg:drawing-yoff-set! dwg (dboard:tabdat-yadj tabdat))
(mutex-lock! mtx)
(canvas-clear! cnv)
(vg:draw dwg tabdat)
(mutex-unlock! mtx)
(dboard:tabdat-view-changed-set! tabdat #f)))))
(define (dboard:graph-db-open dbstr)
(let* ((parts (string-split dbstr ":"))
(dbpth (if (< (length parts) 2) ;; assume then a filename was provided
dbstr
(if (equal? (car parts) "sqlite3")
(cadr parts)
(begin
|
︙ | | | ︙ | |