Megatest

Check-in [0a77e08281]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:more-refactoring-eh
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | refactor-dashboard
Files: files | file ages | folders
SHA1: 0a77e08281fc4dff9d944497cfbe0cd48eb93df9
User & Date: mrwellan on 2011-06-26 14:45:04
Other Links: branch diff | manifest | tags
Context
2011-06-26
16:00
Sped up the left labels a bit check-in: 49eeb8afc8 user: mrwellan tags: refactor-dashboard
14:45
more-refactoring-eh check-in: 0a77e08281 user: mrwellan tags: refactor-dashboard
14:14
Refactored again (broke gui into pieces, IUP seems to be having problems with nested containers check-in: 30e0b9adfd user: mrwellan tags: refactor-dashboard
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified dashboard-tests.scm from [0efdf685df] to [93db9f7715].

︙
25
26
27
28
29
30
31

32
33





34
35
36
37
38
39
40

25
26
27
28
29
30
31
32


33
34
35
36
37
38
39
40
41
42
43
44








+
-
-
+
+
+
+
+








			      "Current state: "
			      "Current status: "
			      "Test comment: "
			      "Test id: "))
		   (list (iup:label "" #:expand "VERTICAL"))))
    (apply iup:vbox  ; #:expand "YES"
	   (list 
	    (store-label "testname"
	    (iup:label (db:test-get-testname  testdat) #:expand "HORIZONTAL")
	    (iup:label (db:test-get-item-path testdat) #:expand "HORIZONTAL")
			 (iup:label (db:test-get-testname  testdat) #:expand "HORIZONTAL")
			 (lambda (testdat)(db:test-get-testname testdat)))
	    (store-label "item-path"
			 (iup:label (db:test-get-item-path testdat) #:expand "HORIZONTAL")
			 (lambda (testdat)(db:test-get-item-path testdat)))
	    (store-label "teststate" 
			 (iup:label (db:test-get-state testdat) #:expand "HORIZONTAL")
			 (lambda (testdat)
			   (db:test-get-state testdat)))
	    (let ((lbl   (iup:label (db:test-get-status testdat) #:expand "HORIZONTAL")))
	      (hash-table-set! widgets "teststatus"
			       (lambda (testdat)
︙
204
205
206
207
208
209
210
211
212

213
214
215
216
217
218
219

208
209
210
211
212
213
214


215
216
217
218
219
220
221
222








-
-
+








			       (set! testdat newtestdat)
			       (set! teststeps    (db:get-steps-for-test db test-id))
			       (set! logfile      (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat)))
			       (set! rundir       (db:test-get-rundir testdat))
			       (set! testfullname (db:test-get-fullname testdat))
			       (mutex-unlock! mx1))
			     (begin
			       (sqlite3:finalize! db)
			       (exit 0))))))
			       (db:test-set-testname testdat "DEAD OR DELETED TEST"))))))
	 (widgets      (make-hash-table))
	 (self         #f)
	 (store-label  (lambda (name lbl cmd)
			 (hash-table-set! widgets name 
					  (lambda (testdat)
					    (let ((newval (cmd testdat))
						  (oldval (iup:attribute lbl "TITLE")))
︙

Modified dashboard.scm from [9dc30172fd] to [bb1818123a].

︙
397
398
399
400
401
402
403
404

405
406
407


408



409
410
411
412

413
414
415
416
417
418
419

397
398
399
400
401
402
403

404
405


406
407
408
409
410
411
412
413
414

415
416
417
418
419
420
421
422








-
+

-
-
+
+

+
+
+



-
+








					      (get-environment-variable "DASHBOARDROWS"))))
	(update-rundat "%" *num-runs* "%" "%"))
    (set! *num-tests* (min (max (update-rundat "%" *num-runs* "%" "%") 8) 20)))

(define uidat #f)
;; (megatest-dashboard)

(define (run-update other-thread)
(define (run-update mtx1)
  (let loop ((i 0))
    (thread-sleep! 0.1)
    (thread-suspend! other-thread)
    (thread-sleep! 0.05)
    (mutex-lock! mtx1)
    (update-buttons uidat *num-runs* *num-tests*)
    (mutex-unlock! mtx1)
    (iup:main-loop-flush)
    (mutex-lock! mtx1)
    (update-rundat (hash-table-ref/default *searchpatts* "runname" "%") *num-runs*
		   (hash-table-ref/default *searchpatts* "test-name" "%")
		   (hash-table-ref/default *searchpatts* "item-name" "%"))
    (thread-resume! other-thread)
    (mutex-unlock! mtx1)
    (loop i)))

(define *job* #f)

(cond 
 ((args:get-arg "-run")
  (let ((runid (string->number (args:get-arg "-run"))))
︙
442
443
444
445
446
447
448
449

450
451
452
453
454
455
456
457

445
446
447
448
449
450
451

452
453
454
455
456
457
458
459
460








-
+









		      ;   	 (exit)))
		      (examine-test *db* testid mx1)))
	(begin
	  (print "ERROR: testid is not a number " (args:get-arg "-test"))
	  (exit 1)))))
 (else
  (set! uidat (make-dashboard-buttons *num-runs* *num-tests* dbkeys))
  (set! *job* (lambda (thr)(run-update thr)))))
  (set! *job* (lambda (mtx1)(run-update mtx1)))))


(let* ((mx1 (make-mutex))
       (th2 (make-thread iup:main-loop))
       (th1 (make-thread (*job* mx1))))
  (thread-start! th1)
  (thread-start! th2)
  (thread-join! th2))

Modified db.scm from [49e9eed590] to [4531d1ac51].

︙
191
192
193
194
195
196
197


198
199
200
201
202
203
204

191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206








+
+








(define-inline (db:test-get-rundir       vec) (vector-ref vec 10))
(define-inline (db:test-get-item-path    vec) (vector-ref vec 11))
(define-inline (db:test-get-run_duration vec) (vector-ref vec 12))
(define-inline (db:test-get-final_logf   vec) (vector-ref vec 13))
(define-inline (db:test-get-comment      vec) (vector-ref vec 14))
(define-inline (db:test-get-fullname     vec)
  (conc (db:test-get-testname vec) "/" (db:test-get-item-path vec)))

(define-inline (db:test-set-testname vec val)(vector-set! vec 2 val))

(define (db-get-tests-for-run db run-id . params)
  (let ((res '())
	(testpatt (if (or (null? params)(not (car params))) "%" (car params)))
	(itempatt (if (> (length params) 1)(cadr params) "%")))
    (sqlite3:for-each-row 
     (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment)
︙

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