Megatest

Check-in [69dbbbec4b]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Moving globals into a struct (currently also global :) )
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.60_defunct
Files: files | file ages | folders
SHA1: 69dbbbec4b4dff85cbd7e64a3157b01b9f467ce3
User & Date: matt on 2016-03-14 02:53:17
Other Links: branch diff | manifest | tags
Context
2016-03-14
22:11
Moved most globals into struct. check-in: f8c1c8f6a6 user: matt tags: v1.60_defunct
02:53
Moving globals into a struct (currently also global :) ) check-in: 69dbbbec4b user: matt tags: v1.60_defunct
2016-03-13
17:03
Handle env vars where space eliminated by trimwhitespace. check-in: 9c080e705b user: matt tags: v1.60_defunct
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Modified dashboard.scm from [bad0524744] to [b3a00b95a1].

︙︙
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26

(use format)
(require-library iup)
(import (prefix iup iup:))

(use canvas-draw)
(import canvas-draw-iup)

(use sqlite3 srfi-1 posix regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:))

(declare (uses common))
(declare (uses margs))
(declare (uses keys))
(declare (uses items))
(declare (uses db))








|








12
13
14
15
16
17
18
19
20
21
22
23
24
25
26

(use format)
(require-library iup)
(import (prefix iup iup:))

(use canvas-draw)
(import canvas-draw-iup)

(use sqlite3 srfi-1 posix regex regex-case srfi-69 defstruct)
(import (prefix sqlite3 sqlite3:))

(declare (uses common))
(declare (uses margs))
(declare (uses keys))
(declare (uses items))
(declare (uses db))
︙︙
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
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140

      (exit)))

(if (not (launch:setup))
    (begin
      (print "Failed to find megatest.config, exiting") 
      (exit 1)))






(define *useserver* (cond
















		     ((args:get-arg "-use-local") #f)
		     ((configf:lookup *configdat* "dashboard" "use-server")
		      (let ((ans (config:lookup *configdat* "dashboard" "use-server")))
			(if (equal? ans "yes") #t #f)))
		     (else #t)))

(define *dbdir* (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
(define *dbstruct-local*  (make-dbr:dbstruct path:  *dbdir*
					     local: #t))
(define *db-file-path* (db:dbfile-path 0))

;; HACK ALERT: this is a hack, please fix.
(define *read-only* (not (file-read-access? *db-file-path*)))

(define toplevel #f)
(define dlg      #f)
(define max-test-num 0)
(define *keys*   (if *useserver*
		     (rmt:get-keys)
		     (db:get-keys *dbstruct-local*)))

(define *dbkeys*  (append *keys* (list "runname")))

(define *header*       #f)
(define *allruns*     '())
(define *allruns-by-id* (make-hash-table)) ;; 

(define *buttondat*    (make-hash-table)) ;; <run-id color text test run-key>
(define *alltestnamelst* '())
(define *searchpatts*  (make-hash-table))
(define *num-runs*      8)
(define *tot-run-count* (if *useserver*
			    (rmt:get-num-runs "%")
			    (db:get-num-runs *dbstruct-local* "%")))

;; (define *tot-run-count* (db:get-num-runs *dbstruct-local* "%"))

;; Update management
;;
(define *last-update*   (current-seconds))
(define *last-db-update-time* 0)
(define *please-update-buttons* #t)
(define *delayed-update* 0)
(define *update-is-running* #f)
(define *update-mutex* (make-mutex))

(define *all-item-test-names* '())
(define *num-tests*     15)
(define *start-run-offset*  0)








>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|

|
|
|
|


|

<
<
<
|
|
|
|
<
|
<
<
<
<
<
<
<
<
<
|
|

<
<


|
<
<








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
120
121
122
123
124
125
126



127
128
129
130

131









132
133
134


135
136
137


138
139
140
141
142
143
144

      (exit)))

(if (not (launch:setup))
    (begin
      (print "Failed to find megatest.config, exiting") 
      (exit 1)))

;; create a stuct for all the miscellaneous state
;;
(defstruct d:alldat 
  dbdir          dblocal     dbfpath
  keys           dbkeys      header      
  allruns        useserver   ro
  allruns-by-id  buttondat   searchpatts
  numruns        tot-runs    
  last-db-update 
  please-update  )

(define *alldat* (make-d:alldat
		  header: #f 
		  allruns: '()
		  allruns-by-id: (make-hash-table)
		  buttondat: (make-hash-table)
		  searchpatts: (make-hash-table)
		  numruns: 16
		  last-db-update: 0
		  please-update: #t))

(d:alldat-useserver-set! *alldat* (cond
				   ((args:get-arg "-use-local") #f)
				   ((configf:lookup *configdat* "dashboard" "use-server")
				    (let ((ans (config:lookup *configdat* "dashboard" "use-server")))
				      (if (equal? ans "yes") #t #f)))
				   (else #t)))

(d:alldat-dbdir-set! *alldat* (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
(d:alldat-dblocal-set! *alldat* (make-dbr:dbstruct path:  (d:alldat-dbdir *alldat*)
						   local: #t))
(d:alldat-dbfpath-set! *alldat* (db:dbfile-path 0))

;; HACK ALERT: this is a hack, please fix.
(d:alldat-ro-set! *alldat* (not (file-read-access? (d:alldat-dbfpath *alldat*))))




(d:alldat-keys-set! *alldat* (if (d:alldat-useserver *alldat*)
				 (rmt:get-keys)
				 (db:get-keys (d:alldat-dblocal *alldat*))))
(d:alldat-dbkeys-set! *alldat* (append (d:alldat-keys *alldat*) (list "runname")))

(d:alldat-tot-runs-set! *alldat* (if (d:alldat-useserver *alldat*)









				     (rmt:get-num-runs "%")
				     (db:get-num-runs (d:alldat-dblocal *alldat*) "%")))



;; Update management
;;



(define *delayed-update* 0)
(define *update-is-running* #f)
(define *update-mutex* (make-mutex))

(define *all-item-test-names* '())
(define *num-tests*     15)
(define *start-run-offset*  0)
︙︙
240
241
242
243
244
245
246
247
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

	    (string>? test-name1 test-name2)
	    test1-older))))
    
;; create a virtual table of all the tests
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
(define (update-rundat runnamepatt numruns testnamepatt keypatts)
  (let* ((referenced-run-ids '())
	 (allruns     (if *useserver*
			  (rmt:get-runs runnamepatt numruns *start-run-offset* keypatts)
			  (db:get-runs *dbstruct-local* runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2))
				      *start-run-offset* keypatts)))
	 (header      (db:get-header allruns))
	 (runs        (db:get-rows   allruns))
	 (result      '())
	 (maxtests    0)
	 (states      (hash-table-keys *state-ignore-hash*))
	 (statuses    (hash-table-keys *status-ignore-hash*))
	 (sort-info   (get-curr-sort))
	 (sort-by     (vector-ref sort-info 1))
	 (sort-order  (vector-ref sort-info 2))
	 (bubble-type (if (member sort-order '(testname))
			  'testname
			  'itempath)))
    ;; 
    ;; trim runs to only those that are changing often here
    ;; 
    (for-each (lambda (run)
		(let* ((run-id      (db:get-value-by-header run header "id"))
		       (key-vals    (if *useserver* 
					(rmt:get-key-vals run-id)
					(db:get-key-vals *dbstruct-local* run-id)))
		       (prev-dat    (let ((rec (hash-table-ref/default *allruns-by-id* run-id #f)))
				      (if rec rec (vector run '() key-vals -100)))) ;; -100 is before time began
		       (prev-tests  (vector-ref prev-dat 1))
		       (last-update (vector-ref prev-dat 3))
		       (tmptests    (if *useserver*
					(rmt:get-tests-for-run run-id testnamepatt states statuses
							       #f #f
							       *hide-not-hide*
							       sort-by
							       sort-order
							       'shortlist
							       last-update)
					(db:get-tests-for-run *dbstruct-local* run-id testnamepatt states statuses
							      #f #f
							      *hide-not-hide*
							      sort-by
							      sort-order
							      'shortlist
							      last-update)))
		       (tests       (let ((newdat (filter








|

|


















|

|
|



|







|








244
245
246
247
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
292
293
294

	    (string>? test-name1 test-name2)
	    test1-older))))
    
;; create a virtual table of all the tests
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
(define (update-rundat runnamepatt numruns testnamepatt keypatts)
  (let* ((referenced-run-ids '())
	 (allruns     (if (d:alldat-useserver *alldat*)
			  (rmt:get-runs runnamepatt numruns *start-run-offset* keypatts)
			  (db:get-runs (d:alldat-dblocal *alldat*) runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2))
				      *start-run-offset* keypatts)))
	 (header      (db:get-header allruns))
	 (runs        (db:get-rows   allruns))
	 (result      '())
	 (maxtests    0)
	 (states      (hash-table-keys *state-ignore-hash*))
	 (statuses    (hash-table-keys *status-ignore-hash*))
	 (sort-info   (get-curr-sort))
	 (sort-by     (vector-ref sort-info 1))
	 (sort-order  (vector-ref sort-info 2))
	 (bubble-type (if (member sort-order '(testname))
			  'testname
			  'itempath)))
    ;; 
    ;; trim runs to only those that are changing often here
    ;; 
    (for-each (lambda (run)
		(let* ((run-id      (db:get-value-by-header run header "id"))
		       (key-vals    (if (d:alldat-useserver *alldat*) 
					(rmt:get-key-vals run-id)
					(db:get-key-vals (d:alldat-dblocal *alldat*) run-id)))
		       (prev-dat    (let ((rec (hash-table-ref/default (d:alldat-allruns-by-id *alldat*) run-id #f)))
				      (if rec rec (vector run '() key-vals -100)))) ;; -100 is before time began
		       (prev-tests  (vector-ref prev-dat 1))
		       (last-update (vector-ref prev-dat 3))
		       (tmptests    (if (d:alldat-useserver *alldat*)
					(rmt:get-tests-for-run run-id testnamepatt states statuses
							       #f #f
							       *hide-not-hide*
							       sort-by
							       sort-order
							       'shortlist
							       last-update)
					(db:get-tests-for-run (d:alldat-dblocal *alldat*) run-id testnamepatt states statuses
							      #f #f
							      *hide-not-hide*
							      sort-by
							      sort-order
							      'shortlist
							      last-update)))
		       (tests       (let ((newdat (filter
︙︙
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323

		  ;; Not sure this is needed?
		  (set! referenced-run-ids (cons run-id referenced-run-ids))
		  (if (> (length tests) maxtests)
		      (set! maxtests (length tests)))
		  (if (or (not *hide-empty-runs*) ;; this reduces the data burden when set
			  (not (null? tests)))
		      (let ((dstruct (vector run tests key-vals (- (current-seconds) 10))))
			(hash-table-set! *allruns-by-id* run-id dstruct)
			(set! result (cons dstruct result))))))
	      runs)

    (set! *header*  header)
    (set! *allruns* result)
    (debug:print-info 6 "*allruns* has " (length *allruns*) " runs")
    maxtests))

(define *collapsed* (make-hash-table))
; (define *row-lookup* (make-hash-table)) ;; testname => (rownum lableobj)

(define (toggle-hide lnum) ; fulltestname)
  (let* ((btn (vector-ref (dboard:uidat-get-lftcol uidat) lnum))








|



|
|
|








307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327

		  ;; Not sure this is needed?
		  (set! referenced-run-ids (cons run-id referenced-run-ids))
		  (if (> (length tests) maxtests)
		      (set! maxtests (length tests)))
		  (if (or (not *hide-empty-runs*) ;; this reduces the data burden when set
			  (not (null? tests)))
		      (let ((dstruct (vector run tests key-vals (- (current-seconds) 10))))
			(hash-table-set! (d:alldat-allruns-by-id *alldat*) run-id dstruct)
			(set! result (cons dstruct result))))))
	      runs)

    (d:alldat-header-set! *alldat* header)
    (d:alldat-allruns-set! *alldat* result)
    (debug:print-info 6 "(d:alldat-allruns *alldat*) has " (length (d:alldat-allruns *alldat*)) " runs")
    maxtests))

(define *collapsed* (make-hash-table))
; (define *row-lookup* (make-hash-table)) ;; testname => (rownum lableobj)

(define (toggle-hide lnum) ; fulltestname)
  (let* ((btn (vector-ref (dboard:uidat-get-lftcol uidat) lnum))
︙︙
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470

		     (res '()))
	    (let ((newres (append res (hash-table-ref tests hed))))
	      (if (null? tal)
		  newres
		  (loop (car tal)(cdr tal) newres))))))))
      
(define (update-buttons uidat numruns numtests)
  (let* ((runs        (if (> (length *allruns*) numruns)
			  (take-right *allruns* numruns)
			  (pad-list *allruns* numruns)))
	 (lftcol      (dboard:uidat-get-lftcol uidat))
	 (tableheader (dboard:uidat-get-header uidat))
	 (table       (dboard:uidat-get-runsvec uidat))
	 (coln        0))
    (set! *alltestnamelst* '())
    ;; create a concise list of test names
    (for-each








|
|
|








458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474

		     (res '()))
	    (let ((newres (append res (hash-table-ref tests hed))))
	      (if (null? tal)
		  newres
		  (loop (car tal)(cdr tal) newres))))))))
      
(define (update-buttons uidat numruns numtests)
  (let* ((runs        (if (> (length (d:alldat-allruns *alldat*)) numruns)
			  (take-right (d:alldat-allruns *alldat*) numruns)
			  (pad-list (d:alldat-allruns *alldat*) numruns)))
	 (lftcol      (dboard:uidat-get-lftcol uidat))
	 (tableheader (dboard:uidat-get-header uidat))
	 (table       (dboard:uidat-get-runsvec uidat))
	 (coln        0))
    (set! *alltestnamelst* '())
    ;; create a concise list of test names
    (for-each
︙︙
487
488
489
490
491
492
493
494
495
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

					 '())))
			     (append xl (make-list (- *num-tests* (length xl)) ""))))
    (update-labels uidat)
    (for-each
     (lambda (rundat)
       (if (not rundat) ;; handle padded runs
	   ;;           ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration
	   (set! rundat (vector (make-vector 20 #f) '() (map (lambda (x) "") *keys*))));; 3)))
       (let* ((run      (vector-ref rundat 0))
	      (testsdat (vector-ref rundat 1))
	      (key-val-dat (vector-ref rundat 2))
	      (run-id   (db:get-value-by-header run *header* "id"))
	      (key-vals (append key-val-dat
				(list (let ((x (db:get-value-by-header run *header* "runname")))
					(if x x "")))))
	      (run-key  (string-intersperse key-vals "\n")))
	 
	 ;; fill in the run header key values
	 (let ((rown      0)
	       (headercol (vector-ref tableheader coln)))
	   (for-each (lambda (kval)
		       (let* ((labl      (vector-ref headercol rown)))
			 (if (not (equal? kval (iup:attribute labl "TITLE")))
			     (iup:attribute-set! (vector-ref headercol rown) "TITLE" kval))
			 (set! rown (+ rown 1))))
		     key-vals))
	 
	 ;; For this run now fill in the buttons for each test
	 (let ((rown 0)
	       (columndat  (vector-ref table coln)))
	   (for-each
	    (lambda (testname)
	      (let ((buttondat  (hash-table-ref/default *buttondat* (mkstr coln rown) #f)))
		(if buttondat
		    (let* ((test       (let ((matching (filter 
							(lambda (x)(equal? (test:test-get-fullname x) testname))
							testsdat)))
					 (if (null? matching)
					     (vector -1 -1 "" "" "" 0 "" "" 0 "" "" "" 0 "" "")
					     (car matching))))








|



|

|


















|








491
492
493
494
495
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

					 '())))
			     (append xl (make-list (- *num-tests* (length xl)) ""))))
    (update-labels uidat)
    (for-each
     (lambda (rundat)
       (if (not rundat) ;; handle padded runs
	   ;;           ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration
	   (set! rundat (vector (make-vector 20 #f) '() (map (lambda (x) "") (d:alldat-keys *alldat*)))));; 3)))
       (let* ((run      (vector-ref rundat 0))
	      (testsdat (vector-ref rundat 1))
	      (key-val-dat (vector-ref rundat 2))
	      (run-id   (db:get-value-by-header run (d:alldat-header *alldat*) "id"))
	      (key-vals (append key-val-dat
				(list (let ((x (db:get-value-by-header run (d:alldat-header *alldat*) "runname")))
					(if x x "")))))
	      (run-key  (string-intersperse key-vals "\n")))
	 
	 ;; fill in the run header key values
	 (let ((rown      0)
	       (headercol (vector-ref tableheader coln)))
	   (for-each (lambda (kval)
		       (let* ((labl      (vector-ref headercol rown)))
			 (if (not (equal? kval (iup:attribute labl "TITLE")))
			     (iup:attribute-set! (vector-ref headercol rown) "TITLE" kval))
			 (set! rown (+ rown 1))))
		     key-vals))
	 
	 ;; For this run now fill in the buttons for each test
	 (let ((rown 0)
	       (columndat  (vector-ref table coln)))
	   (for-each
	    (lambda (testname)
	      (let ((buttondat  (hash-table-ref/default (d:alldat-buttondat *alldat*) (mkstr coln rown) #f)))
		(if buttondat
		    (let* ((test       (let ((matching (filter 
							(lambda (x)(equal? (test:test-get-fullname x) testname))
							testsdat)))
					 (if (null? matching)
					     (vector -1 -1 "" "" "" 0 "" "" 0 "" "" "" 0 "" "")
					     (car matching))))
︙︙
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588

     runs)))

(define (mkstr . x)
  (string-intersperse (map conc x) ","))

(define (set-bg-on-filter)
  (let ((search-changed (not (null? (filter (lambda (key)
					      (not (equal? (hash-table-ref *searchpatts* key) "%")))
					    (hash-table-keys *searchpatts*)))))
	(state-changed  (not (null? (hash-table-keys *state-ignore-hash*))))
	(status-changed (not (null? (hash-table-keys *status-ignore-hash*)))))
    (iup:attribute-set! *hide-not-hide-tabs* "BGCOLOR"
			(if (or search-changed
				state-changed
				status-changed)
			    "190 180 190"
			    "190 190 190"
			    ))))

(define (update-search x val)
  (hash-table-set! *searchpatts* x val)
  (set-bg-on-filter))

(define (mark-for-update)
  (set! *last-db-update-time* 0)
  (set! *delayed-update* 1))

;;======================================================================
;; R U N C O N T R O L
;;======================================================================

;; target populating logic








|
|











|



|








561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592

     runs)))

(define (mkstr . x)
  (string-intersperse (map conc x) ","))

(define (set-bg-on-filter)
  (let ((search-changed (not (null? (filter (lambda (key)
					      (not (equal? (hash-table-ref (d:alldat-searchpatts *alldat*) key) "%")))
					    (hash-table-keys (d:alldat-searchpatts *alldat*))))))
	(state-changed  (not (null? (hash-table-keys *state-ignore-hash*))))
	(status-changed (not (null? (hash-table-keys *status-ignore-hash*)))))
    (iup:attribute-set! *hide-not-hide-tabs* "BGCOLOR"
			(if (or search-changed
				state-changed
				status-changed)
			    "190 180 190"
			    "190 190 190"
			    ))))

(define (update-search x val)
  (hash-table-set! (d:alldat-searchpatts *alldat*) x val)
  (set-bg-on-filter))

(define (mark-for-update)
  (d:alldat-last-db-update-set! *alldat* 0)
  (set! *delayed-update* 1))

;;======================================================================
;; R U N C O N T R O L
;;======================================================================

;; target populating logic
︙︙
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641

	  (if (not (null? values))
	      (let ((newval (car values)))
		(iup:attribute-set! lb "VALUE" newval)
		newval))))))

(define (dashboard:update-target-selector key-lbs #!key (action-proc #f))
  (let* ((runconf-targs (common:get-runconfig-targets))
	 (db-target-dat (if *useserver* 
			    (rmt:get-targets)
			    (db:get-targets *dbstruct-local*)))
	 (header        (vector-ref db-target-dat 0))
	 (db-targets    (vector-ref db-target-dat 1))
	 (all-targets   (append db-targets
				(map (lambda (x)
				       (list->vector
					(take (append (string-split x "/")
						      (make-list (length header) "na"))








|

|








629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645

	  (if (not (null? values))
	      (let ((newval (car values)))
		(iup:attribute-set! lb "VALUE" newval)
		newval))))))

(define (dashboard:update-target-selector key-lbs #!key (action-proc #f))
  (let* ((runconf-targs (common:get-runconfig-targets))
	 (db-target-dat (if (d:alldat-useserver *alldat*) 
			    (rmt:get-targets)
			    (db:get-targets (d:alldat-dblocal *alldat*))))
	 (header        (vector-ref db-target-dat 0))
	 (db-targets    (vector-ref db-target-dat 1))
	 (all-targets   (append db-targets
				(map (lambda (x)
				       (list->vector
					(take (append (string-split x "/")
						      (make-list (length header) "na"))
︙︙
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806

	 (test-patterns-textbox  #f))
    (hash-table-set! tests-draw-state 'first-time #t)
    ;; (hash-table-set! tests-draw-state 'scalef 1)
    ;; (hash-table-set! tests-draw-state 'dotscale 60)
    (tests:get-full-data test-names test-records '() all-tests-registry)
    (set! sorted-testnames (tests:sort-by-priority-and-waiton test-records))
    
    ;; refer to *keys*, *dbkeys* for keys
    (iup:vbox
     ;; The command line display/exectution control
     (iup:frame
      #:title "Command to be exectuted"
      (iup:hbox
       (iup:label "Run on" #:size "40x")
       (iup:radio 








|








796
797
798
799
800
801
802
803
804
805
806
807
808
809
810

	 (test-patterns-textbox  #f))
    (hash-table-set! tests-draw-state 'first-time #t)
    ;; (hash-table-set! tests-draw-state 'scalef 1)
    ;; (hash-table-set! tests-draw-state 'dotscale 60)
    (tests:get-full-data test-names test-records '() all-tests-registry)
    (set! sorted-testnames (tests:sort-by-priority-and-waiton test-records))
    
    ;; refer to (d:alldat-keys *alldat*), (d:alldat-dbkeys *alldat*) for keys
    (iup:vbox
     ;; The command line display/exectution control
     (iup:frame
      #:title "Command to be exectuted"
      (iup:hbox
       (iup:label "Run on" #:size "40x")
       (iup:radio
︙︙
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877

				 #:dropdown "YES"
				 #:action (lambda (obj val index lbstate)
					    (iup:attribute-set! tb "VALUE" val)
					    (dboard:data-set-run-name! *data* val)
					    (dashboard:update-run-command))))
		(refresh-runs-list (lambda ()
				     (let* ((target        (dboard:data-get-target-string *data*))
					    (runs-for-targ (if *useserver*
							       (rmt:get-runs-by-patt *keys* "%" target #f #f #f)
							       (db:get-runs-by-patt *dbstruct-local* *keys* "%" target #f #f #f)))
					    (runs-header   (vector-ref runs-for-targ 0))
					    (runs-dat      (vector-ref runs-for-targ 1))
					    (run-names     (cons default-run-name 
								 (map (lambda (x)
									(db:get-value-by-header x runs-header "runname"))
								      runs-dat))))
				       (iup:attribute-set! lb "REMOVEITEM" "ALL")








|
|
|








865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881

				 #:dropdown "YES"
				 #:action (lambda (obj val index lbstate)
					    (iup:attribute-set! tb "VALUE" val)
					    (dboard:data-set-run-name! *data* val)
					    (dashboard:update-run-command))))
		(refresh-runs-list (lambda ()
				     (let* ((target        (dboard:data-get-target-string *data*))
					    (runs-for-targ (if (d:alldat-useserver *alldat*)
							       (rmt:get-runs-by-patt (d:alldat-keys *alldat*) "%" target #f #f #f)
							       (db:get-runs-by-patt (d:alldat-dblocal *alldat*) (d:alldat-keys *alldat*) "%" target #f #f #f)))
					    (runs-header   (vector-ref runs-for-targ 0))
					    (runs-dat      (vector-ref runs-for-targ 1))
					    (run-names     (cons default-run-name 
								 (map (lambda (x)
									(db:get-value-by-header x runs-header "runname"))
								      runs-dat))))
				       (iup:attribute-set! lb "REMOVEITEM" "ALL")
︙︙
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149

		      (lambda (obj lin col status)
			(let* ((toolpath (car (argv)))
			       (key      (conc lin ":" col))
			       (test-id  (hash-table-ref/default cell-lookup key -1))
			       (cmd      (conc toolpath " -test " (dboard:data-get-curr-run-id *data*) "," test-id "&")))
			  (system cmd)))))
	 (updater  (lambda ()
		     (let* ((runs-dat     (if *useserver*
					      (rmt:get-runs-by-patt *keys* "%" #f #f #f #f)
					      (db:get-runs-by-patt db *keys* "%" #f #f #f #f)))
			    (runs-header  (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
			    (run-id       (dboard:data-get-curr-run-id *data*))
			    (tests-dat    (let ((tdat (if run-id
							  (if *useserver*
							      (rmt:get-tests-for-run run-id 
										     (hash-table-ref/default *searchpatts* "test-name" "%/%")
										     (hash-table-keys *state-ignore-hash*) ;; '()
										     (hash-table-keys *status-ignore-hash*) ;; '()
										     #f #f
										     *hide-not-hide*
										     #f #f
										     "id,testname,item_path,state,status") ;; get 'em all
							      (db:get-tests-for-run db run-id 
										    (hash-table-ref/default *searchpatts* "test-name" "%/%")
										    (hash-table-keys *state-ignore-hash*) ;; '()
										    (hash-table-keys *status-ignore-hash*) ;; '()
										    #f #f
										    *hide-not-hide*
										    #f #f
										    "id,testname,item_path,state,status"))
							  '()))) ;; get 'em all








|
|
|



|

|







|








1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153

		      (lambda (obj lin col status)
			(let* ((toolpath (car (argv)))
			       (key      (conc lin ":" col))
			       (test-id  (hash-table-ref/default cell-lookup key -1))
			       (cmd      (conc toolpath " -test " (dboard:data-get-curr-run-id *data*) "," test-id "&")))
			  (system cmd)))))
	 (updater  (lambda ()
		     (let* ((runs-dat     (if (d:alldat-useserver *alldat*)
					      (rmt:get-runs-by-patt (d:alldat-keys *alldat*) "%" #f #f #f #f)
					      (db:get-runs-by-patt db (d:alldat-keys *alldat*) "%" #f #f #f #f)))
			    (runs-header  (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
			    (run-id       (dboard:data-get-curr-run-id *data*))
			    (tests-dat    (let ((tdat (if run-id
							  (if (d:alldat-useserver *alldat*)
							      (rmt:get-tests-for-run run-id 
										     (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%")
										     (hash-table-keys *state-ignore-hash*) ;; '()
										     (hash-table-keys *status-ignore-hash*) ;; '()
										     #f #f
										     *hide-not-hide*
										     #f #f
										     "id,testname,item_path,state,status") ;; get 'em all
							      (db:get-tests-for-run db run-id 
										    (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%")
										    (hash-table-keys *state-ignore-hash*) ;; '()
										    (hash-table-keys *status-ignore-hash*) ;; '()
										    #f #f
										    *hide-not-hide*
										    #f #f
										    "id,testname,item_path,state,status"))
							  '()))) ;; get 'em all
︙︙
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194

		       
		       ;; (iup:attribute-set! tb "VALUE" "0")
		       ;; (iup:attribute-set! tb "NAME" "Runs")
		       ;; Update the runs tree
		       (for-each (lambda (run-id)
				   (let* ((run-record (hash-table-ref/default runs-hash run-id #f))
					  (key-vals   (map (lambda (key)(db:get-value-by-header run-record runs-header key))
							   *keys*))
					  (run-name   (db:get-value-by-header run-record runs-header "runname"))
					  (col-name   (conc (string-intersperse key-vals "\n") "\n" run-name))
					  (run-path   (append key-vals (list run-name)))
					  (existing   (tree:find-node tb run-path)))
				     (if (not (hash-table-ref/default (dboard:data-get-path-run-ids *data*) run-path #f))
					 (begin
					   (hash-table-set! (dboard:data-get-run-keys *data*) run-id run-path)








|








1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198

		       
		       ;; (iup:attribute-set! tb "VALUE" "0")
		       ;; (iup:attribute-set! tb "NAME" "Runs")
		       ;; Update the runs tree
		       (for-each (lambda (run-id)
				   (let* ((run-record (hash-table-ref/default runs-hash run-id #f))
					  (key-vals   (map (lambda (key)(db:get-value-by-header run-record runs-header key))
							   (d:alldat-keys *alldat*)))
					  (run-name   (db:get-value-by-header run-record runs-header "runname"))
					  (col-name   (conc (string-intersperse key-vals "\n") "\n" run-name))
					  (run-path   (append key-vals (list run-name)))
					  (existing   (tree:find-node tb run-path)))
				     (if (not (hash-table-ref/default (dboard:data-get-path-run-ids *data*) run-path #f))
					 (begin
					   (hash-table-set! (dboard:data-get-run-keys *data*) run-id run-path)
︙︙
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334

							       (set! *hide-not-hide* (not *hide-not-hide*))
							       (iup:attribute-set! obj "TITLE" (if *hide-not-hide* "HideTests" "NotHide"))
							       (mark-for-update)))))
		(set! *hide-not-hide-button* hideit)
		hideit))
	     (iup:hbox
	      (iup:button "Quit"      #:action (lambda (obj)
						 ;; (if *dbstruct-local* (db:close-all *dbstruct-local*))
						 (exit)))
	      (iup:button "Refresh"   #:action (lambda (obj)
						 (mark-for-update)))
	      (iup:button "Collapse"  #:action (lambda (obj)
						 (let ((myname (iup:attribute obj "TITLE")))
						   (if (equal? myname "Collapse")
						       (begin








|








1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338

							       (set! *hide-not-hide* (not *hide-not-hide*))
							       (iup:attribute-set! obj "TITLE" (if *hide-not-hide* "HideTests" "NotHide"))
							       (mark-for-update)))))
		(set! *hide-not-hide-button* hideit)
		hideit))
	     (iup:hbox
	      (iup:button "Quit"      #:action (lambda (obj)
						 ;; (if (d:alldat-dblocal *alldat*) (db:close-all (d:alldat-dblocal *alldat*)))
						 (exit)))
	      (iup:button "Refresh"   #:action (lambda (obj)
						 (mark-for-update)))
	      (iup:button "Collapse"  #:action (lambda (obj)
						 (let ((myname (iup:attribute obj "TITLE")))
						   (if (equal? myname "Collapse")
						       (begin
︙︙
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384

							  (hash-table-set! *state-ignore-hash* state #t)
							  (hash-table-delete! *state-ignore-hash* state))
						      (set-bg-on-filter))))
		   (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED")))
	     (iup:valuator #:valuechanged_cb (lambda (obj)
					       (let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10))))
						     (oldmax   (string->number (iup:attribute obj "MAX")))
						     (maxruns  *tot-run-count*))
						 (set! *start-run-offset* val)
						 (mark-for-update)
						 (debug:print 6 "*start-run-offset* " *start-run-offset* " maxruns: " maxruns ", val: " val " oldmax: " oldmax)
						 (iup:attribute-set! obj "MAX" (* maxruns 10))))
			   #:expand "HORIZONTAL"
			   #:max (* 10 (length *allruns*))
			   #:min 0
			   #:step 0.01)))
					;(iup:button "inc rows" #:action (lambda (obj)(set! *num-tests* (+ *num-tests* 1))))
					;(iup:button "dec rows" #:action (lambda (obj)(set! *num-tests* (if (> *num-tests* 0)(- *num-tests* 1) 0))))
	   )
	  )
    








|





|








1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388

							  (hash-table-set! *state-ignore-hash* state #t)
							  (hash-table-delete! *state-ignore-hash* state))
						      (set-bg-on-filter))))
		   (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED")))
	     (iup:valuator #:valuechanged_cb (lambda (obj)
					       (let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10))))
						     (oldmax   (string->number (iup:attribute obj "MAX")))
						     (maxruns  (d:alldat-tot-runs *alldat*)))
						 (set! *start-run-offset* val)
						 (mark-for-update)
						 (debug:print 6 "*start-run-offset* " *start-run-offset* " maxruns: " maxruns ", val: " val " oldmax: " oldmax)
						 (iup:attribute-set! obj "MAX" (* maxruns 10))))
			   #:expand "HORIZONTAL"
			   #:max (* 10 (length (d:alldat-allruns *alldat*)))
			   #:min 0
			   #:step 0.01)))
					;(iup:button "inc rows" #:action (lambda (obj)(set! *num-tests* (+ *num-tests* 1))))
					;(iup:button "dec rows" #:action (lambda (obj)(set! *num-tests* (if (> *num-tests* 0)(- *num-tests* 1) 0))))
	   )
	  )
︙︙
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416

       ((>= testnum ntests)
	;; now lftlst will be an hbox with the test keys and the test name labels
	(set! lftlst (append lftlst (list (iup:hbox  #:expand "HORIZONTAL"
						     (iup:valuator #:valuechanged_cb (lambda (obj)
										       (let ((val (string->number (iup:attribute obj "VALUE")))
											     (oldmax  (string->number (iup:attribute obj "MAX")))
											     (newmax  (* 10 (length *alltestnamelst*))))
											 (set! *please-update-buttons* #t)
											 (set! *start-test-offset* (inexact->exact (round (/ val 10))))
											 (debug:print 6 "*start-test-offset* " *start-test-offset* " val: " val " newmax: " newmax " oldmax: " oldmax)
											 (if (< val 10)
											     (iup:attribute-set! obj "MAX" newmax))
											 ))
								   #:expand "VERTICAL" 
								   #:orientation "VERTICAL"








|








1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420

       ((>= testnum ntests)
	;; now lftlst will be an hbox with the test keys and the test name labels
	(set! lftlst (append lftlst (list (iup:hbox  #:expand "HORIZONTAL"
						     (iup:valuator #:valuechanged_cb (lambda (obj)
										       (let ((val (string->number (iup:attribute obj "VALUE")))
											     (oldmax  (string->number (iup:attribute obj "MAX")))
											     (newmax  (* 10 (length *alltestnamelst*))))
											 (d:alldat-please-update-set! *alldat* #t)
											 (set! *start-test-offset* (inexact->exact (round (/ val 10))))
											 (debug:print 6 "*start-test-offset* " *start-test-offset* " val: " val " newmax: " newmax " oldmax: " oldmax)
											 (if (< val 10)
											     (iup:attribute-set! obj "MAX" newmax))
											 ))
								   #:expand "VERTICAL" 
								   #:orientation "VERTICAL"
︙︙
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500

	(let* ((button-key (mkstr runnum testnum))
	       (butn       (iup:button "" ;; button-key 
				       #:size "60x15" 
				       #:expand "HORIZONTAL"
				       #:fontsize "10" 
				       #:action (lambda (x)
						  (let* ((toolpath (car (argv)))
							 (buttndat (hash-table-ref *buttondat* button-key))
							 (test-id  (db:test-get-id (vector-ref buttndat 3)))
							 (run-id   (db:test-get-run_id (vector-ref buttndat 3)))
							 (cmd  (conc toolpath " -test " run-id "," test-id "&")))
					;(print "Launching " cmd)
						    (system cmd))))))
	  (hash-table-set! *buttondat* button-key (vector 0 "100 100 100" button-key #f #f)) 
	  (vector-set! testvec testnum butn)
	  (loop runnum (+ testnum 1) testvec (cons butn res))))))
    ;; now assemble the hdrlst and bdylst and kick off the dialog
    (iup:show
     (iup:dialog 
      #:title (conc "Megatest dashboard " (current-user-name) ":" *toppath*)
      #:menu (dcommon:main-menu)
      (let* ((runs-view (iup:vbox
			 (apply iup:hbox 
				(cons (apply iup:vbox lftlst)
				      (list 
				       (iup:vbox
					;; the header
					(apply iup:hbox (reverse hdrlst))
					(apply iup:hbox (reverse bdylst))))))
			 controls))
	     (tabs (iup:tabs
		    #:tabchangepos-cb (lambda (obj curr prev)
					(set! *please-update-buttons* #t)
					(set! *current-tab-number* curr))
		    (dashboard:summary db)
		    runs-view
		    (dashboard:one-run db)
		    (dashboard:run-controls)
		    )))
	;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))








|





|


















|








1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504

	(let* ((button-key (mkstr runnum testnum))
	       (butn       (iup:button "" ;; button-key 
				       #:size "60x15" 
				       #:expand "HORIZONTAL"
				       #:fontsize "10" 
				       #:action (lambda (x)
						  (let* ((toolpath (car (argv)))
							 (buttndat (hash-table-ref (d:alldat-buttondat *alldat*) button-key))
							 (test-id  (db:test-get-id (vector-ref buttndat 3)))
							 (run-id   (db:test-get-run_id (vector-ref buttndat 3)))
							 (cmd  (conc toolpath " -test " run-id "," test-id "&")))
					;(print "Launching " cmd)
						    (system cmd))))))
	  (hash-table-set! (d:alldat-buttondat *alldat*) button-key (vector 0 "100 100 100" button-key #f #f)) 
	  (vector-set! testvec testnum butn)
	  (loop runnum (+ testnum 1) testvec (cons butn res))))))
    ;; now assemble the hdrlst and bdylst and kick off the dialog
    (iup:show
     (iup:dialog 
      #:title (conc "Megatest dashboard " (current-user-name) ":" *toppath*)
      #:menu (dcommon:main-menu)
      (let* ((runs-view (iup:vbox
			 (apply iup:hbox 
				(cons (apply iup:vbox lftlst)
				      (list 
				       (iup:vbox
					;; the header
					(apply iup:hbox (reverse hdrlst))
					(apply iup:hbox (reverse bdylst))))))
			 controls))
	     (tabs (iup:tabs
		    #:tabchangepos-cb (lambda (obj curr prev)
					(d:alldat-please-update-set! *alldat* #t)
					(set! *current-tab-number* curr))
		    (dashboard:summary db)
		    runs-view
		    (dashboard:one-run db)
		    (dashboard:run-controls)
		    )))
	;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
︙︙
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672

    (vector keycol lftcol header runsvec)))

(if (or (args:get-arg "-rows")
	(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")

;; Move this stuff to db.scm? I'm not sure that is the right thing to do...
;;
(define *last-db-update-time* (file-modification-time *db-file-path*)) ;; (conc *toppath* "/db/main.db")))
(define *last-recalc-ended-time* 0)

(define (dashboard:been-changed)
  (> (file-modification-time *db-file-path*) *last-db-update-time*))

(define (dashboard:set-db-update-time)
  (set! *last-db-update-time* (file-modification-time *db-file-path*)))

(define (dashboard:recalc modtime please-update-buttons last-db-update-time)
  (or please-update-buttons
      (and (> (current-milliseconds)(+ *last-recalc-ended-time* 150))
	   (> modtime last-db-update-time)
	   (> (current-seconds)(+ last-db-update-time 1)))))

(define *monitor-db-path* (conc *dbdir* "/monitor.db"))
(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)
  (handle-exceptions
   exn
   (begin
     (debug:print 0 "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn))
     (current-seconds)) ;; something went wrong - just print an error and return current-seconds
   (apply max (map (lambda (filen)
		     (file-modification-time filen))
		   (glob (conc *dbdir* "/*.db"))))))

(define (dashboard:run-update x)
  (let* ((modtime         (dashboard:get-youngest-run-db-mod-time)) ;; (file-modification-time *db-file-path*))
	 (monitor-modtime (if (file-exists? *monitor-db-path*)
			      (file-modification-time *monitor-db-path*)
			      -1))
	 (run-update-time (current-seconds))
	 (recalc          (dashboard:recalc modtime *please-update-buttons* *last-db-update-time*)))
    (if (and (eq? *current-tab-number* 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)
	  (if dashboard:update-servers-table (dashboard:update-servers-table))))
    (if recalc
	(begin	
	  (case *current-tab-number* 
	    ((0) 
	     (if dashboard:update-summary-tab (dashboard:update-summary-tab)))
	    ((1) ;; The runs table is active
	     (update-rundat (hash-table-ref/default *searchpatts* "runname" "%") *num-runs*
			    (hash-table-ref/default *searchpatts* "test-name" "%/%")
			    ;; (hash-table-ref/default *searchpatts* "item-name" "%")
			    (let ((res '()))
			      (for-each (lambda (key)
					  (if (not (equal? key "runname"))
					      (let ((val (hash-table-ref/default *searchpatts* key #f)))
						(if val (set! res (cons (list key val) res))))))
					*dbkeys*)
			      res))
	     (update-buttons uidat *num-runs* *num-tests*))
	    ((2)
	     (dashboard:update-run-summary-tab))
	    (else
	     (let ((updater (hash-table-ref/default *updaters* *current-tab-number* #f)))
	       (if updater (updater)))))
	  (set! *please-update-buttons* #f)
	  (set! *last-db-update-time* modtime)
	  (set! *last-update* run-update-time)
	  (set! *last-recalc-ended-time* (current-milliseconds))))))

;;======================================================================
;; The heavy lifting starts here
;;======================================================================

;; ease debugging by loading ~/.dashboardrc
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
  (if (file-exists? debugcontrolf)
      (load debugcontrolf)))

(cond 
 ((args:get-arg "-run")
  (let ((runid (string->number (args:get-arg "-run"))))
    (if runid
	(begin
	  (lambda (x)
	    (on-exit std-exit-procedure)
	    (examine-run *dbstruct-local* runid)))
	(begin
	  (print "ERROR: runid is not a number " (args:get-arg "-run"))
	  (exit 1)))))
 ((args:get-arg "-test") ;; run-id,test-id
  (let* ((dat     (let ((d (map string->number (string-split (args:get-arg "-test") ","))))
		    (if (> (length d) 1)
			d
			(list #f #f))))
	 (run-id  (car dat))
	 (test-id (cadr dat)))
    (if (and (number? run-id)
	     (number? test-id)
	     (>= test-id 0))
	(examine-test run-id test-id)
	(begin
	  (debug:print 3 "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test"))
	  (exit 1)))))
 ((args:get-arg "-guimonitor")
  (gui-monitor *dbstruct-local*))
 (else
  (set! uidat (make-dashboard-buttons *dbstruct-local* *num-runs* *num-tests* *dbkeys*))
  (iup:callback-set! *tim*
		     "ACTION_CB"
		     (lambda (x)
		       (let ((update-is-running #f))
			 (mutex-lock! *update-mutex*)
			 (set! update-is-running *update-is-running*)
			 (if (not update-is-running)
			     (set! *update-is-running* #t))
			 (mutex-unlock! *update-mutex*)
			 (if (not update-is-running)
			   (begin
			     (dashboard:run-update x)
			     (mutex-lock! *update-mutex*)
			     (set! *update-is-running* #f)
			     (mutex-unlock! *update-mutex*))))
		       1))))

(let ((th1 (make-thread (lambda ()
			  (thread-sleep! 1)
			  (set! *please-update-buttons* #t)
			  (dashboard:run-update 1)) "update buttons once"))
			  ;; need to wait for first *update-is-running* #t
			  ;; (let loop ()
			  ;;   (mutex-lock! *update-mutex*)
			  ;;   (if *update-is-running*
			  ;;       (begin
			  ;;         (set! *please-update-buttons* #t)
			  ;;         (mark-for-update)
			  ;;         (print "Did redraw trigger")) "First update after startup")
			  ;;   (mutex-unlock! *update-mutex*)
			  ;;   (thread-sleep! 1)
			  ;;   (if (not *please-update-buttons*)
			  ;;       (loop))))))
      (th2 (make-thread iup:main-loop "Main loop")))
  (thread-start! th1)
  (thread-start! th2)
  (thread-join! th2))

;; (iup:main-loop)(db:close-all *dbstruct-local*)








|
|








|



|


|







|













|


|




|












|
|
|



|

|

|





|
|
|


















|


















|

|



















|


















|

1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676

    (vector keycol lftcol header runsvec)))

(if (or (args:get-arg "-rows")
	(get-environment-variable "DASHBOARDROWS" ))
    (begin
      (set! *num-tests* (string->number (or (args:get-arg "-rows")
					    (get-environment-variable "DASHBOARDROWS"))))
      (update-rundat "%" (d:alldat-numruns *alldat*) "%/%" '()))
    (set! *num-tests* (min (max (update-rundat "%" (d:alldat-numruns *alldat*) "%/%" '()) 8) 20)))

(define *tim* (iup:timer))
(define *ord* #f)
(iup:attribute-set! *tim* "TIME" 300)
(iup:attribute-set! *tim* "RUN" "YES")

;; Move this stuff to db.scm? I'm not sure that is the right thing to do...
;;
(d:alldat-last-db-update-set! *alldat* (file-modification-time (d:alldat-dbfpath *alldat*))) ;; (conc *toppath* "/db/main.db")))
(define *last-recalc-ended-time* 0)

(define (dashboard:been-changed)
  (> (file-modification-time (d:alldat-dbfpath *alldat*)) (d:alldat-last-db-update *alldat*)))

(define (dashboard:set-db-update-time)
  (d:alldat-last-db-update-set! *alldat* (file-modification-time (d:alldat-dbfpath *alldat*))))

(define (dashboard:recalc modtime please-update-buttons last-db-update-time)
  (or please-update-buttons
      (and (> (current-milliseconds)(+ *last-recalc-ended-time* 150))
	   (> modtime last-db-update-time)
	   (> (current-seconds)(+ last-db-update-time 1)))))

(define *monitor-db-path* (conc (d:alldat-dbdir *alldat*) "/monitor.db"))
(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)
  (handle-exceptions
   exn
   (begin
     (debug:print 0 "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn))
     (current-seconds)) ;; something went wrong - just print an error and return current-seconds
   (apply max (map (lambda (filen)
		     (file-modification-time filen))
		   (glob (conc (d:alldat-dbdir *alldat*) "/*.db"))))))

(define (dashboard:run-update x)
  (let* ((modtime         (dashboard:get-youngest-run-db-mod-time)) ;; (file-modification-time (d:alldat-dbfpath *alldat*)))
	 (monitor-modtime (if (file-exists? *monitor-db-path*)
			      (file-modification-time *monitor-db-path*)
			      -1))
	 (run-update-time (current-seconds))
	 (recalc          (dashboard:recalc modtime (d:alldat-please-update *alldat*) (d:alldat-last-db-update *alldat*))))
    (if (and (eq? *current-tab-number* 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)
	  (if dashboard:update-servers-table (dashboard:update-servers-table))))
    (if recalc
	(begin	
	  (case *current-tab-number* 
	    ((0) 
	     (if dashboard:update-summary-tab (dashboard:update-summary-tab)))
	    ((1) ;; The runs table is active
	     (update-rundat (hash-table-ref/default (d:alldat-searchpatts *alldat*) "runname" "%") (d:alldat-numruns *alldat*)
			    (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%")
			    ;; (hash-table-ref/default (d:alldat-searchpatts *alldat*) "item-name" "%")
			    (let ((res '()))
			      (for-each (lambda (key)
					  (if (not (equal? key "runname"))
					      (let ((val (hash-table-ref/default (d:alldat-searchpatts *alldat*) key #f)))
						(if val (set! res (cons (list key val) res))))))
					(d:alldat-dbkeys *alldat*))
			      res))
	     (update-buttons uidat (d:alldat-numruns *alldat*) *num-tests*))
	    ((2)
	     (dashboard:update-run-summary-tab))
	    (else
	     (let ((updater (hash-table-ref/default *updaters* *current-tab-number* #f)))
	       (if updater (updater)))))
	  (d:alldat-please-update-set! *alldat* #f)
	  (d:alldat-last-db-update-set! *alldat* modtime)
	  ;; (set! *last-update* run-update-time)
	  (set! *last-recalc-ended-time* (current-milliseconds))))))

;;======================================================================
;; The heavy lifting starts here
;;======================================================================

;; ease debugging by loading ~/.dashboardrc
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
  (if (file-exists? debugcontrolf)
      (load debugcontrolf)))

(cond 
 ((args:get-arg "-run")
  (let ((runid (string->number (args:get-arg "-run"))))
    (if runid
	(begin
	  (lambda (x)
	    (on-exit std-exit-procedure)
	    (examine-run (d:alldat-dblocal *alldat*) runid)))
	(begin
	  (print "ERROR: runid is not a number " (args:get-arg "-run"))
	  (exit 1)))))
 ((args:get-arg "-test") ;; run-id,test-id
  (let* ((dat     (let ((d (map string->number (string-split (args:get-arg "-test") ","))))
		    (if (> (length d) 1)
			d
			(list #f #f))))
	 (run-id  (car dat))
	 (test-id (cadr dat)))
    (if (and (number? run-id)
	     (number? test-id)
	     (>= test-id 0))
	(examine-test run-id test-id)
	(begin
	  (debug:print 3 "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test"))
	  (exit 1)))))
 ((args:get-arg "-guimonitor")
  (gui-monitor (d:alldat-dblocal *alldat*)))
 (else
  (set! uidat (make-dashboard-buttons (d:alldat-dblocal *alldat*) (d:alldat-numruns *alldat*) *num-tests* (d:alldat-dbkeys *alldat*)))
  (iup:callback-set! *tim*
		     "ACTION_CB"
		     (lambda (x)
		       (let ((update-is-running #f))
			 (mutex-lock! *update-mutex*)
			 (set! update-is-running *update-is-running*)
			 (if (not update-is-running)
			     (set! *update-is-running* #t))
			 (mutex-unlock! *update-mutex*)
			 (if (not update-is-running)
			   (begin
			     (dashboard:run-update x)
			     (mutex-lock! *update-mutex*)
			     (set! *update-is-running* #f)
			     (mutex-unlock! *update-mutex*))))
		       1))))

(let ((th1 (make-thread (lambda ()
			  (thread-sleep! 1)
			  (d:alldat-please-update-set! *alldat* #t)
			  (dashboard:run-update 1)) "update buttons once"))
			  ;; need to wait for first *update-is-running* #t
			  ;; (let loop ()
			  ;;   (mutex-lock! *update-mutex*)
			  ;;   (if *update-is-running*
			  ;;       (begin
			  ;;         (set! *please-update-buttons* #t)
			  ;;         (mark-for-update)
			  ;;         (print "Did redraw trigger")) "First update after startup")
			  ;;   (mutex-unlock! *update-mutex*)
			  ;;   (thread-sleep! 1)
			  ;;   (if (not *please-update-buttons*)
			  ;;       (loop))))))
      (th2 (make-thread iup:main-loop "Main loop")))
  (thread-start! th1)
  (thread-start! th2)
  (thread-join! th2))

;; (iup:main-loop)(db:close-all (d:alldat-dblocal *alldat*))

This page was generated in about 0.145s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00