Megatest

Changes On Branch 29908b23edeb141d
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Hide Diff Patch Side-by-Side Diff

Changes In Branch v1.60-zero-local-access Through [29908b23ed] Excluding Merge-Ins

This is equivalent to a diff from ab348d3b46 to 29908b23ed

2015-11-12
14:11
Be more lazy on running sync to megatest.db check-in: 27552d9089 user: mrwellan tags: v1.60
2015-11-11
23:00
Merging in v1.60-zero-local-access to v1.60 Closed-Leaf check-in: c6c921401e user: matt tags: v1.60-zero-local-access
22:58
Added simple lock to on-exit call of sync to megatest.db. Set lots of vars when triggers are called. check-in: 2bae638e0f user: matt tags: v1.60-zero-local-access
22:28
Added back sync'ing to megatest.db but with simple file locking and much longer delay check-in: 29908b23ed user: matt tags: v1.60-zero-local-access
20:50
Merged in recent changes to v1.60 in prep for meld check-in: ab0d1e7633 user: matt tags: v1.60-zero-local-access
20:47
All states supported now check-in: ab348d3b46 user: matt tags: v1.60
20:47
Fix typo Closed-Leaf check-in: 56036da5c4 user: matt tags: launcher-exit-handling-refactor
11:27
Merged logpro-abort-check into v1.60/28 but abort not quite right yet check-in: b6900f572f user: mrwellan tags: v1.60

Modified api.scm from [7425d00411] to [d2df3c2dd1].

︙
214
215
216
217
218
219
220

221
222
223
224
225
226
227

214
215
216
217
218
219
220
221
222
223
224
225
226
227
228








+








	    ((get-runs)                     (apply db:get-runs dbstruct params))
	    ((get-num-runs)                 (apply db:get-num-runs dbstruct params))
	    ((get-all-run-ids)              (db:get-all-run-ids dbstruct))
	    ((get-prev-run-ids)             (apply db:get-prev-run-ids dbstruct params))
	    ((get-run-ids-matching-target)  (apply db:get-run-ids-matching-target dbstruct params))
	    ((get-runs-by-patt)             (apply db:get-runs-by-patt dbstruct params))
	    ((get-run-name-from-id)         (apply db:get-run-name-from-id dbstruct params))
	    ((get-run-stats)                (apply db:get-run-stats dbstruct params))

	    ;; STEPS
	    ((get-steps-data)               (apply db:get-steps-data dbstruct params))
	    ((get-steps-for-test)           (apply db:get-steps-for-test dbstruct params))

	    ;; MISC
	    ((have-incompletes?)            (apply db:have-incompletes? dbstruct params))
︙

Modified common.scm from [2955bbfc6b] to [6b9cb42343].

︙
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

295





296
297
298
299
300
301
302

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
295
296
297
298
299
300
301
302
303

304
305
306
307
308
309
310
311
312
313
314
315








+










+
+
+
+
+
+
+
-
-
+
+










+
-
+
+
+
+
+









;;======================================================================
;; E X I T   H A N D L I N G
;;======================================================================

(define (common:legacy-sync-recommended)
  (or (args:get-arg "-runtests")
      (args:get-arg "-run")
      (args:get-arg "-server")
      (args:get-arg "-set-run-status")
      (args:get-arg "-remove-runs")
      (args:get-arg "-get-run-status")
      ))

(define (common:legacy-sync-required)
  (configf:lookup *configdat* "setup" "megatest-db"))

(define (std-exit-procedure)
  ;; (let ((dbpath      (db:dbfile-path run-id))
  ;; 	(lockf       (conc dbpath "/." run-id ".lck")))
  ;;   (common:simple-file-lock lockf)
  ;;   (db:multi-db-sync (list run-id) 'new2old)
  ;;   (common:simple-file-release-lock lockf))
  (let* ((dbpath      (db:dbfile-path run-id))
	 (lockf       (conc dbpath "/." run-id ".lck"))
  (let ((no-hurry  (if *time-to-exit* ;; hurry up
		       #f
	 (no-hurry  (if *time-to-exit* ;; hurry up
			#f
		       (begin
			 (set! *time-to-exit* #t)
			 #t))))
    (debug:print-info 4 "starting exit process, finalizing databases.")
    (if (and no-hurry (debug:debug-mode 18))
	(rmt:print-db-stats))
    (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds
			      (let ((run-ids (hash-table-keys *db-local-sync*)))
				(if (and (not (null? run-ids))
					 (configf:lookup *configdat* "setup" "megatest-db"))
				    ;; was if no-hurry but I always want it sync'd I think ...
				    (if no-hurry (db:multi-db-sync run-ids 'new2old))))
				    ;; (if no-hurry (db:multi-db-sync run-ids 'new2old))))
				    (begin
				      (common:simple-file-lock lockf)
				      (db:multi-db-sync run-ids 'new2old)
				      (common:simple-file-release-lock lockf))))
			      (if *dbstruct-db* (db:close-all *dbstruct-db*))
			      (if *inmemdb*     (db:close-all *inmemdb*))
			      (if (and *megatest-db*
				       (sqlite3:database? *megatest-db*))
				  (begin
				    (sqlite3:interrupt! *megatest-db*)
				    (sqlite3:finalize! *megatest-db* #t)
︙

Modified dashboard.scm from [3d081ca889] to [7bcb6b3970].

︙
88
89
90
91
92
93
94
95
96




97
98
99
100
101
102
103

88
89
90
91
92
93
94


95
96
97
98
99
100
101
102
103
104
105








-
-
+
+
+
+








      (print "Failed to find megatest.config, exiting") 
      (exit 1)))

(define *useserver* (or(not (args:get-arg "-use-local"))
			(configf:lookup *configdat* "dashboard" "use-server")))

(define *dbdir* (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
(define *dbstruct-local*  (make-dbr:dbstruct path:  *dbdir*
					     local: #t))
(define *dbstruct-local*  (if *useserver*
			      #f
			      (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)
︙

Modified db.scm from [3b21c0f4f0] to [d10bf78e86].

︙
136
137
138
139
140
141
142

143
144








145
146
147
148
149
150
151

136
137
138
139
140
141
142
143


144
145
146
147
148
149
150
151
152
153
154
155
156
157
158








+
-
-
+
+
+
+
+
+
+
+








;;   (let ((fdb (db:get-filedb dbstruct)))
;;     (filedb:get-path db id)))

;; NB// #f => return dbdir only
;;      (was planned to be;  zeroth db with name=main.db)
;;
(define (db:dbfile-path run-id)
  (let* ((dbdirs           (filter string?
  (let* ((dbdir           (or (configf:lookup *configdat* "setup" "dbdir")
			      (conc (configf:lookup *configdat* "setup" "linktree") "/.db")))
				   (list (configf:lookup *configdat* "setup" "dbdir")
					 (conc *toppath* "/.db")
					 (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))))
	 (existing-dirs   (filter file-exists? dbdirs))
	 (dbdir           (if (null? existing-dirs)
			      (or  (configf:lookup *configdat* "setup" "dbdir")
				   (conc *toppath* "/.db"))
			      (car existing-dirs)))
	 (fname           (if run-id
			      (if (eq? run-id 0) "main.db" (conc run-id ".db"))
			      #f)))
    (handle-exceptions
     exn
     (begin
       (debug:print 0 "ERROR: Couldn't create path to " dbdir)
︙
1820
1821
1822
1823
1824
1825
1826
1827
1828


1829
1830
1831
1832
1833
1834
1835

1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865



















1866
1867
1868
1869
1870
1871
1872
1873

1827
1828
1829
1830
1831
1832
1833


1834
1835
1836
1837
1838
1839
1840
1841

1842






























1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861

1862
1863
1864
1865
1866
1867
1868








-
-
+
+






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








	"SELECT id FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;")
    (reverse run-ids)))))

;; get some basic run stats
;;
;; ( (runname (( state  count ) ... ))
;;   (   ...  
(define (db:get-run-stats dbstruct)
  (let* ((dbdat        (db:get-db dbstruct #f))
(define (db:get-run-stats dbstruct run-id run-name)
  (let* ((dbdat        (db:get-db dbstruct run-id))
	 (db           (db:dbdat-get-db dbdat))
	 (totals       (make-hash-table))
	 (curr         (make-hash-table))
	 (res          '())
	 (runs-info    '()))
    ;; First get all the runname/run-ids
    (db:delay-if-busy dbdat)
    ;; (db:delay-if-busy dbdat)
    (sqlite3:for-each-row
     (lambda (run-id runname)
       (set! runs-info (cons (list run-id runname) runs-info)))
     db
     "SELECT id,runname FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;") ;; If you change this to the more logical ASC please adjust calls to db:get-run-stats
    ;; for each run get stats data
    (for-each
     (lambda (run-info)
       ;; get the net state/status counts for this run
       (let* ((run-id   (car  run-info))
	      (run-name (cadr run-info)))
	 (db:with-db
	  dbstruct
	  run-id
	  #f
	  (lambda (db)
	    (sqlite3:for-each-row
	     (lambda (state status count)
	       (let ((netstate (if (equal? state "COMPLETED") status state)))
		 (if (string? netstate)
		     (begin
		       (hash-table-set! totals netstate (+ (hash-table-ref/default totals netstate 0) count))
		       (hash-table-set! curr   netstate (+ (hash-table-ref/default curr   netstate 0) count))))))
	     db
	     "SELECT state,status,count(id) FROM tests AS t GROUP BY state,status ORDER BY state,status DESC;")
	    ;; add the per run counts to res
	    (for-each (lambda (state)
			(set! res (cons (list run-name state (hash-table-ref curr state)) res)))
		      (sort (hash-table-keys curr) string>=))
	    (set! curr (make-hash-table))))))
    (db:with-db
     dbstruct
     run-id
     #f
     (lambda (db)
       (sqlite3:for-each-row
	(lambda (state status count)
	  (let ((netstate (if (equal? state "COMPLETED") status state)))
	    (if (string? netstate)
		(begin
		  (hash-table-set! totals netstate (+ (hash-table-ref/default totals netstate 0) count))
		  (hash-table-set! curr   netstate (+ (hash-table-ref/default curr   netstate 0) count))))))
	db
	"SELECT state,status,count(id) FROM tests AS t GROUP BY state,status ORDER BY state,status DESC;")
       ;; add the per run counts to res
       (for-each (lambda (state)
		   (set! res (cons (list run-name state (hash-table-ref curr state)) res)))
		 (sort (hash-table-keys curr) string>=))
       (set! curr (make-hash-table))))
     runs-info)
    (for-each (lambda (state)
		(set! res (cons (list "Totals" state (hash-table-ref totals state)) res)))
	      (sort (hash-table-keys totals) string>=))
    res))

;; db:get-runs-by-patt
;; get runs by list of criteria
︙
3160
3161
3162
3163
3164
3165
3166
3167

3168
3169
3170
3171
3172
3173
3174

3155
3156
3157
3158
3159
3160
3161

3162
3163
3164
3165
3166
3167
3168
3169








-
+








			   (hash-table-set! tests-hash full-testname testdat))))
		   results)
		  (if (null? tal)
		      (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests
		      (loop (car tal)(cdr tal))))))))))

(define (db:delay-if-busy dbdat #!key (count 6))
  (if (not (configf:lookup *configdat* "server" "delay-on-busy"))
  (if #f ;; (not (configf:lookup *configdat* "server" "delay-on-busy"))
      (and dbdat (db:dbdat-get-db dbdat))
      (if dbdat
	  (let* ((dbpath (db:dbdat-get-path dbdat))
		 (db     (db:dbdat-get-db   dbdat)) ;; we'll return this so (db:delay--if-busy can be called inline
		 (dbfj   (conc dbpath "-journal")))
	    (if (handle-exceptions
		 exn
︙

Modified dcommon.scm from [5d1caffec5] to [f2eb55f8d3].

︙
398
399
400
401
402
403
404
405



406
407
408
409
410
411
412

398
399
400
401
402
403
404

405
406
407
408
409
410
411
412
413
414








-
+
+
+









    general-matrix))

(define (dcommon:run-stats dbstruct)
  (let* ((stats-matrix (iup:matrix expand: "YES"))
	 (changed      #f)
	 (updater      (lambda ()
			 (let* ((run-stats    (db:get-run-stats dbstruct))
			 (let* ((run-stats    (if dbstruct
						  (db:get-run-stats dbstruct)
						  (rmt:get-all-run-stats)))
				(indices      (common:sparse-list-generate-index run-stats)) ;;  proc: set-cell))
				(row-indices  (car indices))
				(col-indices  (cadr indices))
				(max-row      (if (null? row-indices) 1 (apply max (map cadr row-indices))))
				(max-col      (if (null? col-indices) 1 
						  (apply max (map cadr col-indices))))
				(max-visible  (max (- *num-tests* 15) 3))
︙

Modified megatest.scm from [47f4506230] to [a6b3a87608].

︙
325
326
327
328
329
330
331

332

333
334
335
336
337
338
339

325
326
327
328
329
330
331
332

333
334
335
336
337
338
339
340








+
-
+








(define *watchdog*
  (make-thread 
   (lambda ()
     (thread-sleep! 0.05) ;; delay for startup
     (let ((legacy-sync (common:legacy-sync-required))
	   (debug-mode  (debug:debug-mode 1))
	   (last-time   (current-seconds)))
       (if legacy-sync
       (if (common:legacy-sync-recommended)
	;;	(common:legacy-sync-recommended))
	   (let loop ()
	     ;; sync for filesystem local db writes
	     ;;
	     (let ((start-time      (current-seconds))
		   (servers-started (make-hash-table)))
	       (for-each 
		(lambda (run-id)
︙

Modified rmt.scm from [58033889c8] to [1253a2efe8].

︙
620
621
622
623
624
625
626




















627
628
629
630
631
632
633

620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653








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








		  (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results)
		  (if (and (null? results)
			   (not (null? tal)))
		      (loop (car tal)(cdr tal))
		      (if (null? results) #f
			  (car results))))))))))

;; call with run-id #f
;;
(define (rmt:get-all-run-stats)
  (let* ((runs-dat (rmt:get-runs "%" #f #f '()))
	 (header   (db:get-header runs-dat))
	 (runs     (db:get-rows   runs-dat)))
    (fold (lambda (run currdat)
	    (let* ((run-id   (db:get-value-by-header run header "id"))
		   (run-name (db:get-value-by-header run header "runname")))
	      (if (and run-id run-name)
		  (append (rmt:get-run-stats run-id run-name) currdat)
		  (begin
		    (debug:print 0 "ERROR: Bad run-id or run-name in " run)
		    currdat))))
	  '()
	  runs)))

(define (rmt:get-run-stats run-id run-name)
  (rmt:send-receive 'get-run-stats run-id (list run-id run-name)))

;;======================================================================
;;  S T E P S
;;======================================================================

;; Getting steps is more complicated.
;;
;; If given work area
︙

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