| ︙ | | | ︙ | |
41
42
43
44
45
46
47
48
49
50
51
52
53
54
|
(define dashboard:update-summary-tab #f)
(define dashboard:update-servers-table #f)
;;======================================================================
;; C O M M O N D A T A S T R U C T U R E
;;======================================================================
;;
;;======================================================================
;; D O T F I L E
;;======================================================================
(define (dcommon:write-dotfile fname dat)
(with-output-to-file fname
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
|
(define dashboard:update-summary-tab #f)
(define dashboard:update-servers-table #f)
;;======================================================================
;; C O M M O N D A T A S T R U C T U R E
;;======================================================================
;;
;; data common to all tabs goes here
;;
(defstruct dboard:commondat
((curr-tab-num 0) : number)
please-update
tabdats
update-mutex
updaters
updating
uidat ;; needs to move to tabdat at some time
hide-not-hide-tabs
)
(define (dboard:commondat-make)
(make-dboard:commondat
curr-tab-num: 0
tabdats: (make-hash-table)
please-update: #t
update-mutex: (make-mutex)
updaters: (make-hash-table)
updating: #f
hide-not-hide-tabs: #f
))
;; RADT => Matrix defstruct addition
(defstruct dboard:graph-dat
((id #f) : string)
((color #f) : vector)
((flag #t) : boolean)
((cell #f) : number)
)
;; data for runs, tests etc. was used in run summary?
;;
(defstruct dboard:runsdat
;; new system
runs-index ;; target/runname => colnum
tests-index ;; testname/itempath => rownum
matrix-dat ;; vector of vectors rows/cols
)
(define (dboard:runsdat-make-init)
(make-dboard:runsdat
runs-index: (make-hash-table)
tests-index: (make-hash-table)
matrix-dat: (make-sparse-array)))
;; used to keep the rundata from rmt:get-tests-for-run
;; in sync.
;;
(defstruct dboard:rundat
run
tests-drawn ;; list of id's already drawn on screen
tests-notdrawn ;; list of id's NOT already drawn
rowsused ;; hash of lists covering what areas used - replace with quadtree
hierdat ;; put hierarchial sorted list here
tests ;; hash of id => testdat
((tests-by-name (make-hash-table)) : hash-table) ;; hash of testfullname => testdat
key-vals
((last-update 0) : number) ;; last query to db got records from before last-update
((last-db-time 0) : number) ;; last timestamp on megatest.db
((data-changed #f) : boolean)
((run-data-offset 0) : number) ;; get only 100 items per call, set back to zero when received less than 100 items
(db-path #f))
;;======================================================================
;; D O T F I L E
;;======================================================================
(define (dcommon:write-dotfile fname dat)
(with-output-to-file fname
|
| ︙ | | | ︙ | |
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
|
;; modify a cell if the data is changed, return #t or-ed with previous if modified, #f elsewise
;;
(define (dcommon:modifiy-if-different mtrx cell-name new-val prev-changed)
(let ((curr-val (iup:attribute mtrx cell-name)))
(if (not (equal? curr-val new-val))
(begin
(iup:attribute-set! mtrx cell-name col-name)
#t) ;; need a re-draw
prev-changed)))
;; TO-DO
;; 1. Make "data" hash-table hierarchial store of all displayed data
;; 2. Update synchash to understand "get-runs", "get-tests" etc.
|
|
|
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
|
;; modify a cell if the data is changed, return #t or-ed with previous if modified, #f elsewise
;;
(define (dcommon:modifiy-if-different mtrx cell-name new-val prev-changed)
(let ((curr-val (iup:attribute mtrx cell-name)))
(if (not (equal? curr-val new-val))
(begin
(iup:attribute-set! mtrx cell-name new-val) ;; was col-name
#t) ;; need a re-draw
prev-changed)))
;; TO-DO
;; 1. Make "data" hash-table hierarchial store of all displayed data
;; 2. Update synchash to understand "get-runs", "get-tests" etc.
|
| ︙ | | | ︙ | |
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
|
;; (if updater (updater (hash-table-ref/default data get-details-sig #f))))
;;
;; (if changed (iup:attribute-set! (dboard:tabdat-runs-matrix data) "REDRAW" "ALL"))
;; ;; (debug:print 2 *default-log-port* "run-changes: " run-changes)
;; ;; (debug:print 2 *default-log-port* "test-changes: " test-changes)
;; (list run-changes all-test-changes)))
(define (dcommon:runsdat-get-col-num dat target runname force-set)
(let* ((runs-index (dboard:runsdat-runs-index dat))
(col-name (conc target "/" runname))
(res (hash-table-ref/default runs-index col-name #f)))
(if res
res
(if force-set
(let ((max-col-num (+ 1 (common:max (cons-1 (hash-table-values runs-index))))))
(hash-table-set! runs-index col-name max-col-num)
max-col-num)))))
(define (dcommon:runsdat-get-row-num dat testname itempath force-set)
(let* ((tests-index (dboard:runsdat-runs-index dat))
(row-name (conc testname "/" itempath))
(res (hash-table-ref/default runs-index row-name #f)))
(if res
res
(if force-set
(let ((max-row-num (+ 1 (common:max (cons -1 (hash-table-values tests-index))))))
|
|
|
|
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
|
;; (if updater (updater (hash-table-ref/default data get-details-sig #f))))
;;
;; (if changed (iup:attribute-set! (dboard:tabdat-runs-matrix data) "REDRAW" "ALL"))
;; ;; (debug:print 2 *default-log-port* "run-changes: " run-changes)
;; ;; (debug:print 2 *default-log-port* "test-changes: " test-changes)
;; (list run-changes all-test-changes)))
#;(define (dcommon:runsdat-get-col-num dat target runname force-set)
(let* ((runs-index (dboard:runsdat-runs-index dat))
(col-name (conc target "/" runname))
(res (hash-table-ref/default runs-index col-name #f)))
(if res
res
(if force-set
(let ((max-col-num (+ 1 (common:max (cons-1 (hash-table-values runs-index))))))
(hash-table-set! runs-index col-name max-col-num)
max-col-num)))))
#;(define (dcommon:runsdat-get-row-num dat testname itempath force-set)
(let* ((tests-index (dboard:runsdat-runs-index dat))
(row-name (conc testname "/" itempath))
(res (hash-table-ref/default runs-index row-name #f)))
(if res
res
(if force-set
(let ((max-row-num (+ 1 (common:max (cons -1 (hash-table-values tests-index))))))
|
| ︙ | | | ︙ | |
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
|
(if (not testdat)
(begin
(debug:print 2 "ERROR: No test data found for test " test-id ", exiting")
(exit 1))
(let*
((rundir (if testdat
(db:test-get-rundir testdat)
logfile))
(testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ..."))
(xterm (lambda ()
(if (directory-exists? rundir)
(let* ((shell (if (get-environment-variable "SHELL")
(conc "-e " (get-environment-variable "SHELL"))
""))
(command (conc "cd " rundir
|
|
|
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
|
(if (not testdat)
(begin
(debug:print 2 "ERROR: No test data found for test " test-id ", exiting")
(exit 1))
(let*
((rundir (if testdat
(db:test-get-rundir testdat)
(current-directory))) ;; logfile))
(testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ..."))
(xterm (lambda ()
(if (directory-exists? rundir)
(let* ((shell (if (get-environment-variable "SHELL")
(conc "-e " (get-environment-variable "SHELL"))
""))
(command (conc "cd " rundir
|
| ︙ | | | ︙ | |
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
|
(define (dcommon:main-menu)
(iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top)
(iup:menu-item "Files" (iup:menu ;; Note that you can use either #:action or action: for options
(iup:menu-item "Open" action: (lambda (obj)
(let* ((area-name (iup:textbox #:expand "HORIZONTAL"))
(fd (iup:file-dialog #:dialogtype "DIR"))
(top (iup:show fd #:modal? "YES")))
(iup:attribute-set! source-tb "VALUE"
(iup:attribute fd "VALUE"))
(iup:destroy! fd))))
;; (lambda (obj)
;; (iup:show (iup:file-dialog))
;; (print "File->open " obj)))
(iup:menu-item "Save" #:action (lambda (obj)(print "File->save " obj)))
(iup:menu-item "Exit" #:action (lambda (obj)(exit)))))
|
|
|
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
|
(define (dcommon:main-menu)
(iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top)
(iup:menu-item "Files" (iup:menu ;; Note that you can use either #:action or action: for options
(iup:menu-item "Open" action: (lambda (obj)
(let* ((area-name (iup:textbox #:expand "HORIZONTAL"))
(fd (iup:file-dialog #:dialogtype "DIR"))
(top (iup:show fd #:modal? "YES")))
(iup:attribute-set! area-name "VALUE" ;; was source-tb, no idea what is correct
(iup:attribute fd "VALUE"))
(iup:destroy! fd))))
;; (lambda (obj)
;; (iup:show (iup:file-dialog))
;; (print "File->open " obj)))
(iup:menu-item "Save" #:action (lambda (obj)(print "File->save " obj)))
(iup:menu-item "Exit" #:action (lambda (obj)(exit)))))
|
| ︙ | | | ︙ | |
1328
1329
1330
1331
1332
1333
1334
1335
|
;;======================================================================
(define (dcommon:run-html-viewer lfilename)
(let ((htmlviewercmd (configf:lookup *configdat* "setup" "htmlviewercmd")))
(if htmlviewercmd
(system (conc "(" htmlviewercmd " " lfilename " ) &"))
(iup:send-url lfilename))))
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
|
;;======================================================================
(define (dcommon:run-html-viewer lfilename)
(let ((htmlviewercmd (configf:lookup *configdat* "setup" "htmlviewercmd")))
(if htmlviewercmd
(system (conc "(" htmlviewercmd " " lfilename " ) &"))
(iup:send-url lfilename))))
(define (dashboard:monitor-changed? commondat tabdat)
(let* ((run-update-time (current-seconds))
(monitor-db-path (dboard:tabdat-monitor-db-path tabdat))
(monitor-modtime (if (and monitor-db-path (common:file-exists? monitor-db-path))
(file-modification-time monitor-db-path)
-1)))
(if (and (eq? (dboard:commondat-curr-tab-num commondat) 0)
(or (> monitor-modtime *last-monitor-update-time*)
(> (- run-update-time *last-monitor-update-time*) 5))) ;; update every 1/2 minute just in case
(begin
(set! *last-monitor-update-time* run-update-time) ;; monitor-modtime)
#t)
#f)))
;; DOES NOT WORK RELIABLY WITH /tmp WAL mode files. Timestamps only change when the db
;; is closed (I think). If db dir starts with /tmp always return true
;;
(define (dashboard:database-changed? commondat tabdat #!key (context-key 'default))
(let* ((run-update-time (current-seconds))
(dbdir (dboard:tabdat-dbdir tabdat))
(modtime (dashboard:get-youngest-run-db-mod-time dbdir))
(recalc (dashboard:recalc modtime
(dboard:commondat-please-update commondat)
(dboard:get-last-db-update tabdat context-key))))
;; (dboard:tabdat-last-db-update tabdat))))
(if recalc
(dboard:set-last-db-update! tabdat context-key run-update-time))
(dboard:commondat-please-update-set! commondat #f)
recalc))
(define (dashboard:get-youngest-run-db-mod-time dbdir)
(handle-exceptions
exn
(begin
(debug:print 2 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn) " db-dir="dbdir)
(current-seconds)) ;; something went wrong - just print an error and return current-seconds
(common:max (map (lambda (filen)
(file-modification-time filen))
(glob (conc dbdir "/*.db*"))))))
(define (dboard:get-last-db-update tabdat context)
(hash-table-ref/default (dboard:tabdat-last-db-update tabdat) context 0))
(define (dboard:set-last-db-update! tabdat context newtime)
(hash-table-set! (dboard:tabdat-last-db-update tabdat) context newtime))
;; point inside line
;;
(define-inline (dashboard:px-between px lx1 lx2)
(and (< lx1 px)(> lx2 px)))
(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)))))
|