Megatest

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

Changes In Branch guitweaks Through [00fe53b20b] Excluding Merge-Ins

This is equivalent to a diff from fa52f9444d to 00fe53b20b

2011-10-26
14:03
Merged guitweaks (includes stuff from private branches check-in: bb8b14dea5 user: mrwellan tags: trunk
10:46
Cleaned up the left labels check-in: a0696770b5 user: mrwellan tags: guitweaks
10:37
Cleaned up the left labels check-in: 00fe53b20b user: mrwellan tags: guitweaks
09:15
Sprucing up the gui a bit. check-in: 9b2128dd16 user: mrwellan tags: guitweaks
2011-10-25
20:12
Fixed command line -runall borked by the monitor stuff check-in: fa52f9444d user: mrwellan tags: trunk
2011-10-24
23:14
Removed transaction from snag task - works much better but needs to be proven no collisions check-in: f03dbc0c69 user: matt tags: trunk

Modified dashboard.scm from [1bf80313b8] to [41f87e4841].

︙
106
107
108
109
110
111
112






113
114
115
116
117
118
119

106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125








+
+
+
+
+
+








(define *verbosity* (cond
		     ((args:get-arg "-debug")(string->number (args:get-arg "-debug")))
		     ((args:get-arg "-v")    2)
		     ((args:get-arg "-q")    0)
		     (else                   1)))

(define uidat #f)

(define-inline (dboard:uidat-get-keycol  vec)(vector-ref vec 0))
(define-inline (dboard:uidat-get-lftcol  vec)(vector-ref vec 1))
(define-inline (dboard:uidat-get-header  vec)(vector-ref vec 2))
(define-inline (dboard:uidat-get-runsvec vec)(vector-ref vec 3))

;; (megatest-dashboard)

;(define img1 (iup:image/palette 16 16 (u8vector->blob (u8vector
;				   1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 
;				   1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 
;				   1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 
;				   1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2
︙
223
224
225
226
227
228
229
230

231
232
233
234
235
236
237

229
230
231
232
233
234
235

236
237
238
239
240
241
242
243








-
+








	    maxtests))
	*num-tests*))) ;; FIXME, naughty coding eh?

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

(define (toggle-hide lnum) ; fulltestname)
  (let* ((btn (vector-ref (vector-ref uidat 0) lnum))
  (let* ((btn (vector-ref (dboard:uidat-get-lftcol uidat) lnum))
	 (fulltestname (iup:attribute btn "TITLE"))
	 (parts        (string-split fulltestname "("))
	 (basetestname (if (null? parts) "" (car parts))))
    ;(print "Toggling " basetestname " currently " (hash-table-ref/default *collapsed* basetestname #f))
    (if (hash-table-ref/default *collapsed* basetestname #f)
	(begin
	  ;(iup:attribute-set! btn "FGCOLOR" "0 0 0")
︙
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

316
317
318
319
320
321
322

296
297
298
299
300
301
302
303

304
305
306
307
308
309


310
311
312



313
314
315
316
317
318
319
320
321

322
323
324
325
326
327
328
329








+
-
+





-
-
+


-
-
-


+



+
+
+
-
+








    ;;     		 (if (equal? (car partsa)(car partsb)) ;; same test
    ;;     		     (> lenb lena)
    ;;     		     #t)
    ;;     		 #t))))))
			     
(define (update-labels uidat)
  (let* ((rown    0)
	 (keycol  (dboard:uidat-get-keycol uidat))
	 (lftcol  (vector-ref uidat 0))
	 (lftcol  (dboard:uidat-get-lftcol uidat))
	 (numcols (vector-length lftcol))
	 (maxn    (- numcols 1))
	 (allvals (make-vector numcols "")))
    (for-each (lambda (name)
		(if (<= rown maxn)
		    (let ((labl (vector-ref lftcol rown)))
		      (vector-set! allvals rown name)))
		    (vector-set! allvals rown name)) ;)
		(set! rown (+ 1 rown)))
	      *alltestnamelst*)
	;      (if (> (length *alltestnamelst*) *start-test-offset*)
	;	  (drop *alltestnamelst* *start-test-offset*)
	;	  '()))
    (let loop ((i 0))
      (let* ((lbl    (vector-ref lftcol i))
	     (keyval (vector-ref keycol i))
	     (oldval (iup:attribute lbl "TITLE"))
	     (newval (vector-ref allvals i)))
	(if (not (equal? oldval newval))
	    (let ((munged-val (let ((parts (string-split newval "(")))
				(if (> (length parts) 1)(conc "  " (car (string-split (cadr parts) ")"))) newval))))
	      (vector-set! keycol i newval)
	    (iup:attribute-set! lbl "TITLE" newval))
	      (iup:attribute-set! lbl "TITLE" munged-val)))
	(iup:attribute-set! lbl "FGCOLOR" (if (hash-table-ref/default *collapsed* newval #f) "0 112 112" "0 0 0"))
	(if (< i maxn)
	    (loop (+ i 1)))))))

(define (get-color-for-state-status state status)
  (case (string->symbol state)
    ((COMPLETED)
︙
336
337
338
339
340
341
342
343
344
345



346
347
348
349
350
351
352

343
344
345
346
347
348
349



350
351
352
353
354
355
356
357
358
359








-
-
-
+
+
+








    (else               "192 192 192")))

(define (update-buttons uidat numruns numtests)
  (if *please-update-buttons*
      (let* ((runs        (if (> (length *allruns*) numruns)
			      (take-right *allruns* numruns)
			      (pad-list *allruns* numruns)))
	     (lftcol      (vector-ref uidat 0))
	     (tableheader (vector-ref uidat 1))
	     (table       (vector-ref uidat 2))
	     (lftcol      (dboard:uidat-get-lftcol uidat))
	     (tableheader (dboard:uidat-get-header uidat))
	     (table       (dboard:uidat-get-runsvec uidat))
	     (coln        0))
	(set! *please-update-buttons* #f)
	(set! *alltestnamelst* '())
	;; create a concise list of test names
	(for-each
	 (lambda (rundat)
	   (if (vector? rundat)
︙
436
437
438
439
440
441
442

443
444
445
446
447
448
449

443
444
445
446
447
448
449
450
451
452
453
454
455
456
457








+








  (hash-table-set! *searchpatts* x val))

(define (make-dashboard-buttons nruns ntests keynames)
  (let* ((nkeys   (length keynames))
	 (runsvec (make-vector nruns))
	 (header  (make-vector nruns))
	 (lftcol  (make-vector ntests))
	 (keycol  (make-vector ntests))
	 (controls '())
	 (lftlst  '())
	 (hdrlst  '())
	 (bdylst  '())
	 (result  '())
	 (i       0))
    ;; controls (along bottom)
︙
457
458
459
460
461
462
463

464
465
466





467
468
469
470
471
472
473

465
466
467
468
469
470
471
472



473
474
475
476
477
478
479
480
481
482
483
484








+
-
-
-
+
+
+
+
+








			   #:action (lambda (obj unk val)
				      (set! *last-db-update-time* 0)
				      (update-search "test-name" val)))
	      (iup:textbox #:size "60x15" #:fontsize "10" #:value "%"
			   #:action (lambda (obj unk val)
				      (set! *last-db-update-time* 0)
				      (update-search "item-name" val)))))
	    (iup:vbox
	    (iup:hbox
	     (iup:button "Quit" #:action (lambda (obj)(sqlite3:finalize! *db*)(exit)))
	     (iup:button "Monitor" #:action (lambda (obj)(system (conc (car (argv))" -guimonitor &"))))
	     (iup:hbox
	      (iup:button "Sort Order" #:acton (lambda (obj)(toggle-sort-order))))
	     (iup:hbox
	      (iup:button "Quit" #:action (lambda (obj)(sqlite3:finalize! *db*)(exit)))
	      (iup:button "Monitor" #:action (lambda (obj)(system (conc (car (argv))" -guimonitor &")))))
	     ))
	   ;; (iup:button "<-  Left" #:action (lambda (obj)(set! *start-run-offset*  (+ *start-run-offset* 1))))
	   ;; (iup:button "Up     ^" #:action (lambda (obj)(set! *start-test-offset* (if (> *start-test-offset* 0)(- *start-test-offset* 1) 0))))
	   ;; (iup:button "Down   v" #:action (lambda (obj)(set! *start-test-offset* (if (>= *start-test-offset* (length *alltestnamelst*))(length *alltestnamelst*)(+ *start-test-offset* 1)))))
	   ;; (iup:button "Right ->" #:action (lambda (obj)(set! *start-run-offset*  (if (> *start-run-offset* 0)(- *start-run-offset* 1) 0))))
	   (iup:frame 
	    #:title "hide"
︙
537
538
539
540
541
542
543

544
545
546
547
548
549
550

548
549
550
551
552
553
554
555
556
557
558
559
560
561
562








+








									       ))
							 #:expand "YES" 
							 #:orientation "VERTICAL")
					   (apply iup:vbox (reverse res)))))))
       (else
	(let ((labl  (iup:button "" 
				 #:flat "YES" 
				 #:alignment "ALEFT"
				 ; #:image img1
				 ; #:impress img2
				 #:size "100x15"
				 #:fontsize "10"
				 #:action (lambda (obj)
					    (set! *last-db-update-time* 0)
					    (toggle-hide testnum))))) ;; (iup:attribute obj "TITLE"))))
︙
601
602
603
604
605
606
607
608

609
610
611
612
613
614
615

613
614
615
616
617
618
619

620
621
622
623
624
625
626
627








-
+








	       (cons (apply iup:vbox lftlst)
		     (list 
		      (iup:vbox
		       ;; the header
		       (apply iup:hbox (reverse hdrlst))
		       (apply iup:hbox (reverse bdylst))))))
       controls)))
    (vector lftcol header runsvec)))
    (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* "%" "%" '()))
︙

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