Megatest

Diff
Login

Differences From Artifact [27c42dd921]:

To Artifact [c13d28ecc7]:


184
185
186
187
188
189
190

191
192
193
194
195
196
197
  cnv
  cnv-obj
  drawing
  draw-cache     ;; 
  start-row
  run-start-row
  max-row


  ;; Controls used to launch runs etc.
  command
  command-tb 
  run-name         ;; from run name setting widget
  states           ;; states for -state s1,s2 ...
  statuses         ;; statuses for -status s1,s2 ...







>







184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
  cnv
  cnv-obj
  drawing
  draw-cache     ;; 
  start-row
  run-start-row
  max-row
  running-layout

  ;; Controls used to launch runs etc.
  command
  command-tb 
  run-name         ;; from run name setting widget
  states           ;; states for -state s1,s2 ...
  statuses         ;; statuses for -status s1,s2 ...
262
263
264
265
266
267
268

269
270
271
272
273
274
275
	      not-done-runs:        '()
	      done-runs:            '()
	      num-tests:            15
	      numruns:              16
	      path-run-ids:         (make-hash-table)
	      run-ids:              (make-hash-table)
	      run-keys:             (make-hash-table)

	      searchpatts:          (make-hash-table)
	      start-run-offset:     0
	      start-test-offset:    0
	      state-ignore-hash:    (make-hash-table)
	      status-ignore-hash:   (make-hash-table)
	      xadj:                 0
	      yadj:                 0







>







263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
	      not-done-runs:        '()
	      done-runs:            '()
	      num-tests:            15
	      numruns:              16
	      path-run-ids:         (make-hash-table)
	      run-ids:              (make-hash-table)
	      run-keys:             (make-hash-table)
	      running-layout:       #f
	      searchpatts:          (make-hash-table)
	      start-run-offset:     0
	      start-test-offset:    0
	      state-ignore-hash:    (make-hash-table)
	      status-ignore-hash:   (make-hash-table)
	      xadj:                 0
	      yadj:                 0
1125
1126
1127
1128
1129
1130
1131

1132
1133




1134
1135

1136
1137
1138
1139
1140
1141
1142
				  (lambda ()
				    (let ((tabdat        (dboard:common-get-tabdat commondat tab-num: tab-num)))
				      (if tabdat
					  (let ((last-data-update (dboard:tabdat-last-data-update tabdat))
						(now-time         (current-seconds)))
					    (dashboard:run-times-tab-canvas-updater commondat tabdat tab-num)
					    (if (> (- now-time last-data-update) 5)

						(begin
						  (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num)




						  (dashboard:run-times-tab-layout-updater commondat tabdat tab-num)
						  (dboard:tabdat-last-data-update-set! tabdat now-time)))))))

				  "dashboard:run-times-tab-updater"))))
    (dboard:tabdat-drawing-set! tabdat drawing)
    (dboard:commondat-add-updater commondat run-times-tab-updater tab-num: tab-num)
    (iup:split
     #:orientation "VERTICAL" ;; "HORIZONTAL"
     #:value 200
     (let* ((tb      (iup:treebox







>
|
|
>
>
>
>
|
|
>







1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
				  (lambda ()
				    (let ((tabdat        (dboard:common-get-tabdat commondat tab-num: tab-num)))
				      (if tabdat
					  (let ((last-data-update (dboard:tabdat-last-data-update tabdat))
						(now-time         (current-seconds)))
					    (dashboard:run-times-tab-canvas-updater commondat tabdat tab-num)
					    (if (> (- now-time last-data-update) 5)
						(if (not (dboard:tabdat-running-layout tabdat))
						    (begin
						      (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num)
						      (dboard:tabdat-last-data-update-set! tabdat now-time)
						      (thread-start! (make-thread
								      (lambda ()
									(dboard:tabdat-running-layout-set! tabdat #t)
									(dashboard:run-times-tab-layout-updater commondat tabdat tab-num)
									(dboard:tabdat-running-layout-set! tabdat #f)))))
						  ))))))
				  "dashboard:run-times-tab-updater"))))
    (dboard:tabdat-drawing-set! tabdat drawing)
    (dboard:commondat-add-updater commondat run-times-tab-updater tab-num: tab-num)
    (iup:split
     #:orientation "VERTICAL" ;; "HORIZONTAL"
     #:value 200
     (let* ((tb      (iup:treebox
2490
2491
2492
2493
2494
2495
2496
2497

2498
2499
2500
2501
2502
2503
2504
2505
		     res))))

;; run times canvas updater
;;
(define (dashboard:run-times-tab-canvas-updater commondat tabdat tab-num)
  (let ((cnv (dboard:tabdat-cnv tabdat))
	(dwg (dboard:tabdat-drawing tabdat))
	(mtx (dboard:tabdat-runs-mutex tabdat)))

    (if (and cnv dwg)
	(begin
	  (mutex-lock! mtx)
	  (canvas-clear! cnv)
	  (vg:draw dwg tabdat)
	  (mutex-unlock! mtx)
	  (dboard:tabdat-view-changed-set! tabdat #f)))))
  







|
>
|







2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
		     res))))

;; run times canvas updater
;;
(define (dashboard:run-times-tab-canvas-updater commondat tabdat tab-num)
  (let ((cnv (dboard:tabdat-cnv tabdat))
	(dwg (dboard:tabdat-drawing tabdat))
	(mtx (dboard:tabdat-runs-mutex tabdat))
	(vch (dboard:tabdat-view-changed tabdat)))
    (if (and cnv dwg vch)
	(begin
	  (mutex-lock! mtx)
	  (canvas-clear! cnv)
	  (vg:draw dwg tabdat)
	  (mutex-unlock! mtx)
	  (dboard:tabdat-view-changed-set! tabdat #f)))))
  
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534

2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
	 (mtx           (dboard:tabdat-runs-mutex tabdat))) 
    (if tabdat
	(let* ((drawing    (dboard:tabdat-drawing tabdat))
	       (runslib    (vg:get/create-lib drawing "runslib")) ;; creates and adds lib
	       (compute-start (current-seconds)))
	  (vg:drawing-xoff-set! drawing (dboard:tabdat-xadj tabdat))
	  (vg:drawing-yoff-set! drawing (dboard:tabdat-yadj tabdat))
	  (let ((allruns (dboard:tabdat-allruns tabdat))
		(rowhash (make-hash-table)) ;; store me in tabdat
		(cnv     (dboard:tabdat-cnv tabdat)))
	    (print "allruns: " allruns)
	    (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv))
			 ((originx originy)             (canvas-origin cnv)))
	      ;; (print "allruns: " allruns)
	      (let runloop ((rundat   (car allruns))
			    (runtal   (cdr allruns))
			    (run-num   1)
			    (doneruns '())
			    (run-start-row 0))
		(let* ((run       (dboard:rundat-run rundat))

		       (key-val-dat (dboard:rundat-key-vals rundat))
		       (run-id   (db:get-value-by-header run (dboard:tabdat-header tabdat) "id"))
		       (key-vals (append key-val-dat
					 (list (let ((x (db:get-value-by-header run (dboard:tabdat-header tabdat) "runname")))
						 (if x x "")))))
		       (run-key  (string-intersperse key-vals "\n"))
		       (run-full-name (string-intersperse key-vals "/")))
		  (if (not (vg:lib-get-component runslib run-full-name))
		      (let* ((hierdat   (dboard:tests-sort-by-time-group-by-item (dboard:rundat-tests rundat))) ;; hierarchial list of ids
			     (tests-ht  (dboard:rundat-tests rundat))
			     (all-tids  (hash-table-keys   tests-ht)) ;; (apply append hierdat)) ;; was testsdat
			     (testsdat  (hash-table-values tests-ht))







|
|
|









|
>

|
|
|
|







2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
	 (mtx           (dboard:tabdat-runs-mutex tabdat))) 
    (if tabdat
	(let* ((drawing    (dboard:tabdat-drawing tabdat))
	       (runslib    (vg:get/create-lib drawing "runslib")) ;; creates and adds lib
	       (compute-start (current-seconds)))
	  (vg:drawing-xoff-set! drawing (dboard:tabdat-xadj tabdat))
	  (vg:drawing-yoff-set! drawing (dboard:tabdat-yadj tabdat))
	  (let* ((allruns (dboard:tabdat-allruns tabdat))
		 (num-runs (length allruns))
		 (cnv     (dboard:tabdat-cnv tabdat)))
	    (print "allruns: " allruns)
	    (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv))
			 ((originx originy)             (canvas-origin cnv)))
	      ;; (print "allruns: " allruns)
	      (let runloop ((rundat   (car allruns))
			    (runtal   (cdr allruns))
			    (run-num   1)
			    (doneruns '())
			    (run-start-row 0))
		(let* ((run         (dboard:rundat-run rundat))
		       (rowhash     (make-hash-table)) ;; store me in tabdat
		       (key-val-dat (dboard:rundat-key-vals rundat))
		       (run-id      (db:get-value-by-header run (dboard:tabdat-header tabdat) "id"))
		       (key-vals    (append key-val-dat
					    (list (let ((x (db:get-value-by-header run (dboard:tabdat-header tabdat) "runname")))
						    (if x x "")))))
		       (run-key  (string-intersperse key-vals "\n"))
		       (run-full-name (string-intersperse key-vals "/")))
		  (if (not (vg:lib-get-component runslib run-full-name))
		      (let* ((hierdat   (dboard:tests-sort-by-time-group-by-item (dboard:rundat-tests rundat))) ;; hierarchial list of ids
			     (tests-ht  (dboard:rundat-tests rundat))
			     (all-tids  (hash-table-keys   tests-ht)) ;; (apply append hierdat)) ;; was testsdat
			     (testsdat  (hash-table-values tests-ht))
2558
2559
2560
2561
2562
2563
2564

2565
2566
2567
2568
2569
2570
2571
			     (maptime    (lambda (tsecs)(* timescale (+ tsecs timeoffset))))
			     (num-tests  (length hierdat))
			     (tot-tests  (length testsdat))
			     (new-run-start-row (+ (dboard:tabdat-max-row tabdat) 2)))
			;; (print "timescale: " timescale " timeoffset: " timeoffset " sizex: " sizex " originx: " originx)
			(mutex-lock! mtx)
			(vg:add-comp-to-lib runslib run-full-name runcomp)

			(mutex-unlock! mtx)
			;; (set! run-start-row (+ max-row 2))
			;; (dboard:tabdat-start-row-set! tabdat (+ new-run-start-row 1))
			;; get tests in list sorted by event time ascending
			(let testsloop ((test-ids  (car hierdat))              ;; loop on tests (NOTE: not items!)
					(tests-tal (cdr hierdat))
					(test-num  1))







>







2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
			     (maptime    (lambda (tsecs)(* timescale (+ tsecs timeoffset))))
			     (num-tests  (length hierdat))
			     (tot-tests  (length testsdat))
			     (new-run-start-row (+ (dboard:tabdat-max-row tabdat) 2)))
			;; (print "timescale: " timescale " timeoffset: " timeoffset " sizex: " sizex " originx: " originx)
			(mutex-lock! mtx)
			(vg:add-comp-to-lib runslib run-full-name runcomp)
			(vg:instantiate drawing "runslib" run-full-name run-full-name 0 (* new-run-start-row row-height))
			(mutex-unlock! mtx)
			;; (set! run-start-row (+ max-row 2))
			;; (dboard:tabdat-start-row-set! tabdat (+ new-run-start-row 1))
			;; get tests in list sorted by event time ascending
			(let testsloop ((test-ids  (car hierdat))              ;; loop on tests (NOTE: not items!)
					(tests-tal (cdr hierdat))
					(test-num  1))
2605
2606
2607
2608
2609
2610
2611

2612
2613
2614
2615
2616
2617
2618
					;;     (dashboard:add-bar rowhash (- rownum 1) event-time end-time num-rows: (+ 1 num-items))
					(if (not first-rownum)
					    (begin
					      (dashboard:row-collision rowhash (- rownum 1) event-time end-time num-rows: num-items)
					      (set! first-rownum rownum)))
					(dashboard:add-bar rowhash rownum event-time end-time)
					(vg:add-obj-to-comp runcomp obj)

					(set! test-objs (cons obj test-objs)))))
				;; (print "test-name: " test-name " event-time: " event-time " run-duration: " run-duration)
				(let ((newdoneruns (cons rundat doneruns)))
				  (if (not (null? tidstal))
				      (if #f ;; (> (- (current-seconds) update-start-time) 5)
					  (begin
					    (print "drawing runs taking too long....  have " (length runtal) " remaining")







>







2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
					;;     (dashboard:add-bar rowhash (- rownum 1) event-time end-time num-rows: (+ 1 num-items))
					(if (not first-rownum)
					    (begin
					      (dashboard:row-collision rowhash (- rownum 1) event-time end-time num-rows: num-items)
					      (set! first-rownum rownum)))
					(dashboard:add-bar rowhash rownum event-time end-time)
					(vg:add-obj-to-comp runcomp obj)
					(dboard:tabdat-view-changed-set! tabdat #t)
					(set! test-objs (cons obj test-objs)))))
				;; (print "test-name: " test-name " event-time: " event-time " run-duration: " run-duration)
				(let ((newdoneruns (cons rundat doneruns)))
				  (if (not (null? tidstal))
				      (if #f ;; (> (- (current-seconds) update-start-time) 5)
					  (begin
					    (print "drawing runs taking too long....  have " (length runtal) " remaining")
2626
2627
2628
2629
2630
2631
2632
2633


2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
				       (llx (- (car xtents)   5))
				       (lly (- (cadr xtents) 10))
				       (ulx (+ 5 (caddr xtents)))
				       (uly (+ 0 (cadddr xtents))))
				  (dashboard:add-bar rowhash first-rownum llx ulx num-rows:  num-items)
				  (vg:add-obj-to-comp runcomp (vg:make-rect-obj llx lly ulx uly
										text:  (db:test-get-testname (hash-table-ref tests-ht (car test-ids)))
										font: "Helvetica -10"))))


			    (if (not (null? tests-tal))
				(if #f ;; (> (- (current-seconds) update-start-time) 5)
				    (print "drawing runs taking too long")
				    (testsloop  (car tests-tal)(cdr tests-tal)(+ test-num 1))))))
			;; placeholder box
			(dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat) 1))
			(let ((y   (- sizey (* (dboard:tabdat-max-row tabdat) row-height))))
			  (vg:add-obj-to-comp runcomp (vg:make-rect-obj 0 y 0 y)))
			;; instantiate the component
			(mutex-lock! mtx)
			(let* ((extents   (vg:components-get-extents drawing runcomp))
			       (new-xtnts (apply vg:grow-rect 5 5 extents))
			       (llx       (list-ref new-xtnts 0))
			       (lly       (list-ref new-xtnts 1))
			       (ulx       (list-ref new-xtnts 2))
			       (uly       (list-ref new-xtnts 3))
			       ) ;;  (vg:components-get-extents d1 c1)))
			  (vg:add-obj-to-comp runcomp (vg:make-rect-obj llx lly ulx uly text: run-full-name))
			  (vg:instantiate drawing "runslib" run-full-name run-full-name 0 0))
			(mutex-unlock! mtx)
			(dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat) 1)))
		      ;; end of the run handling loop 
		      (let ((newdoneruns (cons rundat doneruns)))
			(if (null? runtal)
			    (begin
			      (dboard:tabdat-not-done-runs-set! tabdat '())







|
>
>

















|
<







2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665

2666
2667
2668
2669
2670
2671
2672
				       (llx (- (car xtents)   5))
				       (lly (- (cadr xtents) 10))
				       (ulx (+ 5 (caddr xtents)))
				       (uly (+ 0 (cadddr xtents))))
				  (dashboard:add-bar rowhash first-rownum llx ulx num-rows:  num-items)
				  (vg:add-obj-to-comp runcomp (vg:make-rect-obj llx lly ulx uly
										text:  (db:test-get-testname (hash-table-ref tests-ht (car test-ids)))
										font: "Helvetica -10"))
				  (dboard:tabdat-view-changed-set! tabdat #t) ;; trigger a redraw
				  ))
			    (if (not (null? tests-tal))
				(if #f ;; (> (- (current-seconds) update-start-time) 5)
				    (print "drawing runs taking too long")
				    (testsloop  (car tests-tal)(cdr tests-tal)(+ test-num 1))))))
			;; placeholder box
			(dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat) 1))
			(let ((y   (- sizey (* (dboard:tabdat-max-row tabdat) row-height))))
			  (vg:add-obj-to-comp runcomp (vg:make-rect-obj 0 y 0 y)))
			;; instantiate the component
			(mutex-lock! mtx)
			(let* ((extents   (vg:components-get-extents drawing runcomp))
			       (new-xtnts (apply vg:grow-rect 5 5 extents))
			       (llx       (list-ref new-xtnts 0))
			       (lly       (list-ref new-xtnts 1))
			       (ulx       (list-ref new-xtnts 2))
			       (uly       (list-ref new-xtnts 3))
			       ) ;;  (vg:components-get-extents d1 c1)))
			  (vg:add-obj-to-comp runcomp (vg:make-rect-obj llx lly ulx uly text: run-full-name)))

			(mutex-unlock! mtx)
			(dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat) 1)))
		      ;; end of the run handling loop 
		      (let ((newdoneruns (cons rundat doneruns)))
			(if (null? runtal)
			    (begin
			      (dboard:tabdat-not-done-runs-set! tabdat '())