Megatest

Diff
Login

Differences From Artifact [7a92ca5dd5]:

To Artifact [420ddf64af]:


42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
(include "db_records.scm")
(include "run_records.scm")
(include "megatest-fossil-hash.scm")

(define help (conc 
"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
  version " megatest-version "
  license GPL, Copyright (C) Matt Welland 2013

Usage: dashboard [options]
  -h                   : this help
  -server host:port    : connect to host:port instead of db access
  -test run-id,test-id : control test identified by testid
  -guimonitor          : control panel for runs








|







42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
(include "db_records.scm")
(include "run_records.scm")
(include "megatest-fossil-hash.scm")

(define help (conc 
"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
  version " megatest-version "
  license GPL, Copyright (C) Matt Welland 2012-2014

Usage: dashboard [options]
  -h                   : this help
  -server host:port    : connect to host:port instead of db access
  -test run-id,test-id : control test identified by testid
  -guimonitor          : control panel for runs

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
      (exit)))

(if (not (setup-for-run))
    (begin
      (print "Failed to find megatest.config, exiting") 
      (exit 1)))

(define *db*  (make-dbr:dbstruct path: *toppath* local: #t))

;; (define sdb:qry (make-sdb:qry)) ;;  'init #f)

;; (if (args:get-arg "-host")
;;     (begin
;;       (set! *runremote* (string-split (args:get-arg "-host" ":")))
;;       (client:launch))
;;     (if (not (args:get-arg "-use-server"))
;; 	(set! *transport-type* 'fs) ;; force fs access
;; 	(client:launch)))

;; HACK ALERT: this is a hack, please fix.
(define *read-only* (not (file-read-access? (conc *toppath* "/megatest.db"))))
;; (client:setup *db*)

(define toplevel #f)
(define dlg      #f)
(define max-test-num 0)
(define *keys*   (db:get-keys *db*))
;; (define *keys*   (cdb:remote-run db:get-keys #f))
;; (define *keys*   (db:get-keys   *db*))

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

(define *header*       #f)
(define *allruns*     '())
(define *allruns-by-id* (make-hash-table)) ;; 
(define *runchangerate* (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* (db:get-num-runs *db* "%"))
;; (define *tot-run-count* (db:get-num-runs *db* "%"))

;; Update management
;;
(define *last-update*   (current-seconds))
(define *last-db-update-time* 0)
(define *please-update-buttons* #t)
(define *delayed-update* 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
      (exit)))

(if (not (setup-for-run))
    (begin
      (print "Failed to find megatest.config, exiting") 
      (exit 1)))

(define *dbstruct-local*  (make-dbr:dbstruct path: *toppath* local: #t))

;; (define sdb:qry (make-sdb:qry)) ;;  'init #f)

;; (if (args:get-arg "-host")
;;     (begin
;;       (set! *runremote* (string-split (args:get-arg "-host" ":")))
;;       (client:launch))
;;     (if (not (args:get-arg "-use-server"))
;; 	(set! *transport-type* 'fs) ;; force fs access
;; 	(client:launch)))

;; HACK ALERT: this is a hack, please fix.
(define *read-only* (not (file-read-access? (conc *toppath* "db/main.db"))))
;; (client:setup *dbstruct-local*)

(define toplevel #f)
(define dlg      #f)
(define max-test-num 0)
(define *keys*   (db:get-keys *dbstruct-local*))
;; (define *keys*   (cdb:remote-run db:get-keys #f))
;; (define *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 *runchangerate* (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* (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)
205
206
207
208
209
210
211
212
213
214
215
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
	 (c2    (map string->number (string-split color2)))
	 (delta (map (lambda (a b)(abs (- a b))) c1 c2)))
    (null? (filter (lambda (x)(> x 3)) delta))))

;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
(define (update-rundat runnamepatt numruns testnamepatt keypatts)
  (let* ((referenced-run-ids '())
	 (allruns     (db:get-runs *db* 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"))
		       (tests       (db:get-tests-for-run *db* run-id testnamepatt states statuses
							  #f #f
							  *hide-not-hide*
							  sort-by
							  sort-order
							  'shortlist))
		       ;; NOTE: bubble-up also sets the global *all-item-test-names*
		       ;; (tests       (bubble-up tmptests priority: bubble-type))
		       (key-vals    (db:get-key-vals *db* run-id)))
		  ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively.
		  ;; (debug:print 0 "Getting data for run " run-id " with key-vals=" key-vals)
		  ;; 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







|


















|







|







205
206
207
208
209
210
211
212
213
214
215
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
	 (c2    (map string->number (string-split color2)))
	 (delta (map (lambda (a b)(abs (- a b))) c1 c2)))
    (null? (filter (lambda (x)(> x 3)) delta))))

;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
(define (update-rundat runnamepatt numruns testnamepatt keypatts)
  (let* ((referenced-run-ids '())
	 (allruns     (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"))
		       (tests       (db:get-tests-for-run *dbstruct-local* run-id testnamepatt states statuses
							  #f #f
							  *hide-not-hide*
							  sort-by
							  sort-order
							  'shortlist))
		       ;; NOTE: bubble-up also sets the global *all-item-test-names*
		       ;; (tests       (bubble-up tmptests priority: bubble-type))
		       (key-vals    (db:get-key-vals *dbstruct-local* run-id)))
		  ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively.
		  ;; (debug:print 0 "Getting data for run " run-id " with key-vals=" key-vals)
		  ;; 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
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
	  (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 (db:get-targets *db*))
	 (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"))







|







559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
	  (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 (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"))
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
				 #: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 (db:get-runs-by-patt *db* *keys* "%" target #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")







|







824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
				 #: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 (db:get-runs-by-patt *dbstruct-local* *keys* "%" target #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")
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
	      (let ((hideit (iup:button "HideTests" #:action (lambda (obj)
							       (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 *db* (db:close-all *db*))(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
							 (for-each (lambda (tname)







|







1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
	      (let ((hideit (iup:button "HideTests" #:action (lambda (obj)
							       (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
							 (for-each (lambda (tname)
1436
1437
1438
1439
1440
1441
1442





1443
1444
1445
1446
1447
1448
1449
1450
1451
(define *monitor-db-path* (conc *toppath* "/db/monitor.db"))
(define *last-monitor-update-time* 0)

;; Force creation of the db in case it isn't already there.
(let ((db (tasks:open-db)))
  (sqlite3:finalize! db))






(define (dashboard:run-update x)
  (let* ((modtime         (file-modification-time *db-file-path*))
	 (monitor-modtime (file-modification-time *monitor-db-path*))
	 (run-update-time (current-seconds))
	 (recalc          (dashboard:recalc modtime *please-update-buttons* *last-db-update-time*)))
    (if (and (eq? *current-tab-number* 0)
	     (> monitor-modtime *last-monitor-update-time*))
	(begin
	  (set! *last-monitor-update-time* monitor-modtime)







>
>
>
>
>

|







1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
(define *monitor-db-path* (conc *toppath* "/db/monitor.db"))
(define *last-monitor-update-time* 0)

;; Force creation of the db in case it isn't already there.
(let ((db (tasks:open-db)))
  (sqlite3:finalize! db))

(define (dashboard:get-youngest-run-db-mod-time)
  (apply max (map (lambda (filen)
		    (file-modification-time filen))
		  (glob (conc *toppath* "/db/*.db")))))

(define (dashboard:run-update x)
  (let* ((modtime         (dashboard:get-youngest-run-db-mod-time)) ;; (file-modification-time *db-file-path*))
	 (monitor-modtime (file-modification-time *monitor-db-path*))
	 (run-update-time (current-seconds))
	 (recalc          (dashboard:recalc modtime *please-update-buttons* *last-db-update-time*)))
    (if (and (eq? *current-tab-number* 0)
	     (> monitor-modtime *last-monitor-update-time*))
	(begin
	  (set! *last-monitor-update-time* monitor-modtime)
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
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
(cond 
 ((args:get-arg "-run")
  (let ((runid (string->number (args:get-arg "-run"))))
    (if runid
	(begin
	  (lambda (x)
	    (on-exit (lambda ()
		       (if *db* (db:close-all *db*))))
	    (examine-run *db* 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     (map string->number (string-split (args:get-arg "-test") ",")))
	 (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 *db*))
 (else
  (set! uidat (make-dashboard-buttons *db* *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))))

(iup:main-loop)
(db:close-all *db*)







|
|















|

|


















|
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
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
(cond 
 ((args:get-arg "-run")
  (let ((runid (string->number (args:get-arg "-run"))))
    (if runid
	(begin
	  (lambda (x)
	    (on-exit (lambda ()
		       (if *dbstruct-local* (db:close-all *dbstruct-local*))))
	    (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     (map string->number (string-split (args:get-arg "-test") ",")))
	 (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))))

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