Megatest

Diff
Login

Differences From Artifact [feba132a9c]:

To Artifact [ff9b120b1b]:


96
97
98
99
100
101
102

103
104
105
106
107
108
109
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110







+







	srfi-1
	regex regex-case srfi-69
	typed-records
	sparse-vectors
	format
	srfi-4
	srfi-14
	srfi-18
	)

;; (include "common_records.scm")
;; (include "db_records.scm")
;; (include "run_records.scm")
;; (include "task_records.scm")
;; (include "megatest-version.scm")
130
131
132
133
134
135
136




137
138
139
140
141
142
143
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148







+
+
+
+







	subrunmod
	tasksmod
	testsmod
	tree
	vgmod
        ducttape-lib
	)

;; globals to dashboard module
(define *updaters-running* #f)
(define *updaters-thread*  #f)

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

Usage: dashboard [options]
196
197
198
199
200
201
202
203

204
205
206
207
208
209
210
201
202
203
204
205
206
207

208
209
210
211
212
213
214
215







-
+







			(exit 1))))
		'("MT_RUN_AREA_HOME" "MT_MEGATEST" "MT_CMDINFO" "MT_TEST_RUN_DIR" "MT_LINKTREE" "MT_TESTSUITENAME"))
      (print ". Done. All ok.")))

(if (not (null? remargs))
    (begin
      (print "Unrecognised arguments: " (string-intersperse remargs " "))
      (exit)))
      ))

(if (args:get-arg "-h")
    (begin
      (print help)
      (exit)))

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







-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+







;;(debug:print-info 13 *default-log-port* "After common:watchdog spawn")
;; (if (not (args:get-arg "-use-db-cache"))
;;     (begin
;;       (debug:print-info 0 *default-log-port* "Forcing db-cache mode due to read-only access to megatest.db")
;;       (hash-table-set! args:arg-hash "-use-db-cache" #t)));;;)
;;)

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

;;======================================================================
;; buttons color using image
;;======================================================================

(define *images* (make-hash-table))

878
879
880
881
882
883
884

885
886


887
888
889
890
891
892
893
894
895
896
883
884
885
886
887
888
889
890


891
892



893
894
895
896
897
898
899







+
-
-
+
+
-
-
-







		      (> elapsed-time 2)) ;; stop loading data after 5 seconds, on the next call more data *should* be loaded since get-tests-for-run uses last update
		  (begin
		    (when (> elapsed-time 2)   
                      (debug:print 0 *default-log-port* "NOTE: updates are taking a long time, " elapsed-time "s elapsed.")
                      (let* ((old-val (iup:attribute *tim* "TIME"))
                             (new-val (number->string (inexact->exact (floor (* 2  (string->number old-val)))))))
                        (if (< (string->number new-val) 5000)
                            (begin
                            ((debug:print 0 *default-log-port* "NOTE: increasing poll interval from "old-val" to "new-val)
                            (iup:attribute-set! *tim* "TIME" new-val))))
			      (debug:print 0 *default-log-port* "NOTE: increasing poll interval from "old-val" to "new-val)
                              (iup:attribute-set! *tim* "TIME" new-val)))))


                      )
		    (dboard:tabdat-allruns-set! tabdat new-res)
		    maxtests)
		  (if (> (dboard:rundat-run-data-offset run-struct) 0)
		      (loop run tal new-res newmaxtests) ;; not done getting data for this run
		      (loop (car tal)(cdr tal) new-res newmaxtests)))))))
    (dboard:tabdat-filters-changed-set! tabdat #f)
    (dboard:update-tree tabdat runs-hash header tb)))
1049
1050
1051
1052
1053
1054
1055
1056

1057
1058
1059
1060
1061
1062
1063
1052
1053
1054
1055
1056
1057
1058

1059
1060
1061
1062
1063
1064
1065
1066







-
+







	 (all-test-names (make-hash-table))
	 (use-bgcolor (equal? (configf:lookup *configdat* "dashboard" "use-bgcolor") "yes")) ;; doesn't work
	 )
    ;; create a concise list of test names
    ;;
    (for-each
     (lambda (rundat)
       (if rundat
       (if (dboard:rundat? rundat)
	   (let* ((testdats  (dboard:rundat-tests rundat))
		  (testnames (map test:test-get-fullname (hash-table-values testdats))))
	     (dcommon:rundat-copy-tests-to-by-name rundat)
	     ;; for the normalized list of testnames (union of all runs)
	     (if (not (and (dboard:tabdat-hide-empty-runs tabdat)
			   (null? testnames)))
		 (for-each (lambda (testname)
1235
1236
1237
1238
1239
1240
1241
1242

1243
1244
1245
1246
1247
1248
1249
1238
1239
1240
1241
1242
1243
1244

1245
1246
1247
1248
1249
1250
1251
1252







-
+







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

(define (dashboard:update-target-selector tabdat #!key (action-proc #f))
  (let* ((runconf-targs (common:get-runconfig-targets *configdat*))
  (let* ((runconf-targs (common:get-runconfig-targets *runconfigdat*))
	 (key-lbs       (dboard:tabdat-key-listboxes tabdat))
	 (db-target-dat (rmt:get-targets))
	 (header        (vector-ref db-target-dat 0))
	 (db-targets    (vector-ref db-target-dat 1))
	 (munge-target  (lambda (x)            ;; create a target vector from a string. Pad with na if needed.
			  (list->vector
			   (take (append (string-split x "/")
1339
1340
1341
1342
1343
1344
1345
1346

1347
1348
1349
1350
1351
1352
1353
1342
1343
1344
1345
1346
1347
1348

1349
1350
1351
1352
1353
1354
1355
1356







-
+







	(dboard:tabdat-run-name-set! tabdat curr-runname))
    (dashboard:update-run-command tabdat)))

;; used by run-controls
;;
(define (dashboard:update-tree-selector tabdat #!key (action-proc #f))
  (let* ((tb            (dboard:tabdat-runs-tree tabdat))
	 (runconf-targs (common:get-runconfig-targets *configdat*))
	 (runconf-targs (common:get-runconfig-targets *runconfigdat*))
	 (db-target-dat (rmt:get-targets))
         (runs-tree-ht  (dboard:tabdat-runs-tree-ht tabdat))
	 (header        (vector-ref db-target-dat 0))
	 (db-targets    (vector-ref db-target-dat 1))
	 (munge-target  (lambda (x)            ;; create a target vector from a string. Pad with na if needed.
			  (take (append (string-split x "/")
					(make-list (length header) "na"))
3246
3247
3248
3249
3250
3251
3252
3253

3254
3255
3256



3257
3258
3259
3260
3261
3262
3263
3249
3250
3251
3252
3253
3254
3255

3256



3257
3258
3259
3260
3261
3262
3263
3264
3265
3266







-
+
-
-
-
+
+
+







			 (zeroth-point   (conc "SELECT " timef "," varfn "," valfn " FROM " tablen " WHERE " varfn "='" fieldname "' AND " timef " < " tstart " LIMIT 1")))
		     (hash-table-set! res-ht fieldname ;; (fetch-rows (sql db qrystr)))))
				      (reverse
				       (sqlite3:fold-row
					(lambda (res t var val)
					  (cons (vector t var val) res))
					'() db all-dat-qrystr)))
		     (let ((zeropt (handle-exceptions
		     (let ((zeropt (condition-case 
				    exn
				    #f
				    (sqlite3:first-row db all-dat-qrystr))))
				       (sqlite3:first-row db all-dat-qrystr)
				     (exn (busy)(db:generic-error-printout exn "ERROR: database " dbdef
                                     " is locked. Try copying to another location, remove original and copy back.")))))
		       (if zeropt ;; NOTE: Add zeropt to the beginning of the list as the list was reversed above.
			   (hash-table-set! res-ht
					    fieldname
					    (cons
					     (apply vector tstart (cdr zeropt))						    
					     (hash-table-ref/default res-ht fieldname '())))))))
		 fields)
3621
3622
3623
3624
3625
3626
3627
















3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647






3648
3649
3650
3651
3652

3653
3654
3655
3656
3657



3658
3659
3660
3661


3662
3663
3664
3665
3666
3667
3668

3669
3670
3671
3672
3673
3674
3675
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658








3659
3660
3661
3662
3663
3664





3665





3666
3667
3668
3669
3670


3671
3672
3673
3674
3675
3676
3677
3678

3679
3680
3681
3682
3683
3684
3685
3686







+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+












-
-
-
-
-
-
-
-
+
+
+
+
+
+
-
-
-
-
-
+
-
-
-
-
-
+
+
+


-
-
+
+






-
+







				      (begin
					(if (dboard:tabdat-layout-update-ok tabdat)
					    (runloop (car runtal)(cdr runtal) (+ run-num 1) newdoneruns)
					    (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat)
					    ))))))))) ;;  new-run-start-row
		)))
	(debug:print 2 *default-log-port* "no tabdat for run-times-tab-updater"))))

(define (dashboard:calc-key-patterns tabdat)
  ;; generate key patterns from the target stored in tabdat
  (let* ((dbkeys  (dboard:tabdat-dbkeys tabdat)))
    (let ((fres   (if (dboard:tabdat-target tabdat)
		      (let ((ptparts (append (dboard:tabdat-target tabdat)(make-list (length dbkeys) "%"))))
			(map (lambda (k v)(list k v)) dbkeys ptparts))
		      (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))))))
				  dbkeys)
			res))))
      fres)))


;; handy trick for printing a record
;;
;;   (pp (dboard:tabdat->alist tabdat))
;; 
;;  removing the tabdat-values proc 
;;
;; (define (tabdat-values tabdat)

;; runs update-rundat using the various filters from the gui
;;
(define (dashboard:do-update-rundat tabdat)
  (dboard:update-rundat
   tabdat
   (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%")
   (dboard:tabdat-numruns tabdat)
   (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
   ;; generate key patterns from the target stored in tabdat
   (let* ((dbkeys (dboard:tabdat-dbkeys tabdat)))
     (let ((fres   (if (dboard:tabdat-target tabdat)
  (let* ((runnamepatt (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%"))
	 (numruns     (dboard:tabdat-numruns tabdat))
	 (testnamepatt (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%"))
	 (keypatts     (dashboard:calc-key-patterns tabdat)))
    (dboard:update-rundat
     tabdat
                       (let ((ptparts (append (dboard:tabdat-target tabdat)(make-list (length dbkeys) "%"))))
                         (map (lambda (k v)(list k v)) dbkeys ptparts))
                       (let ((res '()))
                         (for-each (lambda (key)
                                     (if (not (equal? key "runname"))
     runnamepatt
                                         (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f)))
                                           (if val (set! res (cons (list key val) res))))))
                                   dbkeys)
                         res))))
       fres))))
     numruns
     testnamepatt
     keypatts)))

(define (dashboard:runs-tab-updater commondat tab-num)
  (debug:catch-and-dump 
   (lambda ()
  ;; (debug:catch-and-dump 
  ;;  (lambda ()
     (let* ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))
	    (dbkeys (dboard:tabdat-dbkeys tabdat)))
       (dashboard:do-update-rundat tabdat)
       (let ((uidat (dboard:commondat-uidat commondat)))
	 (update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat)))
       ))
   "dashboard:runs-tab-updater"))
   ;; "dashboard:runs-tab-updater"))

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

(define (dashboard-main)
  (let ((mtdb-path (conc *toppath* "/megatest.db"))) ;; not used for now, update for .db area and use for write access detection
3706
3707
3708
3709
3710
3711
3712

3713
3714
3715
3716
3717
3718
3719

3720
3721
3722
3723
3724
3725
3726
3727


















3728
3729
3730
3731
3732
3733
3734
3735
3736
3737










3738
3739
3740
3741
3742
3743
3744
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727




3728








3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749







3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766







+



-
-
-
-
+
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+



-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+







	 tab-num: 1)
        ;; may not want this alive (manually merged it from v1.66)
	(dboard:commondat-add-updater 
	 commondat 
	 (lambda ()
	   (dashboard:runs-tab-updater commondat 1))
	 tab-num: 2)
	
	(iup:callback-set! *tim*
			   "ACTION_CB"
			   (lambda (time-obj)
			     (let ((update-is-running #f))
			     (mutex-lock! (dboard:commondat-update-mutex commondat))
			     (set! update-is-running (dboard:commondat-updating commondat))
			     (if (not update-is-running)
			     (if (not *updaters-thread*)
			     (dboard:commondat-updating-set! commondat #t))
			     (mutex-unlock! (dboard:commondat-update-mutex commondat))
			     (if (not update-is-running) ;; we know that the update was not running and we now have a lock on doing an update
			     (begin
			     (dboard:common-run-curr-updaters commondat) ;; (dashboard:run-update commondat)
			     (mutex-lock! (dboard:commondat-update-mutex commondat))
			     (dboard:commondat-updating-set! commondat #f)
			     (mutex-unlock! (dboard:commondat-update-mutex commondat)))
				 (begin
				   ;; (debug:print-info 0 *default-log-port* "Updater started...")
				   (set! *updaters-thread*
					 (make-thread
					  (lambda ()
					    (dboard:common-run-curr-updaters commondat))))
				   (thread-start! *updaters-thread*))
				 (begin
				   (debug:print-info 0 *default-log-port* "Updater restarted...")
				   (thread-resume! *updaters-thread*)))
			     (thread-sleep! 0.25)
			     (if (eq? (thread-state *updaters-thread*) 'running)
				 (begin
				   (debug:print-info 0 *default-log-port* "Updater suspended...")
				   (thread-suspend! *updaters-thread*))
				 (begin
				   (set! *updaters-thread* #f)
				   ;; (debug:print-info 0 *default-log-port* "Updater done...")
				   ))
			     1))))
      
      (let ((th1 (make-thread (lambda ()
				(thread-sleep! 1)
				(dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab 
				) "update buttons once"))
	    (th2 (make-thread iup:main-loop "Main loop")))
	(thread-start! th2)
	(thread-join! th2)))))
      ;; (let ((th1 (make-thread (lambda ()
      ;; 				(thread-sleep! 1)
      ;; 				(dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab 
      ;; 				) "update buttons once"))
      ;; 	    (th2 (make-thread iup:main-loop "Main loop")))
      ;; 	(thread-start! th2)
      ;; 	(thread-join! th2))
      
      (iup:main-loop)
      )))

(define (get-debugcontrolf)
  (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
    (if (common:file-exists? debugcontrolf)
	debugcontrolf
	#f)))

3752
3753
3754
3755
3756
3757
3758

3759




3760

3774
3775
3776
3777
3778
3779
3780
3781

3782
3783
3784
3785
3786
3787







+
-
+
+
+
+

+
(import dashboard)

;; ease debugging by loading ~/.dashboardrc
(let ((debugcontrolf (get-debugcontrolf)))
  (if debugcontrolf
      (load debugcontrolf)))

(import srfi-18)
(main)

(thread-join!
 (thread-start!
  (make-thread main "main")))