Megatest

Check-in [6a2f23dbf3]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Factored tests into hash of id => testdat
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.61
Files: files | file ages | folders
SHA1: 6a2f23dbf32d60df4e1e565d50a6dc30a0a33192
User & Date: matt on 2016-07-22 00:35:19
Other Links: branch diff | manifest | tags
Context
2016-07-22
15:09
Added hash of fulltestname => testdat check-in: 082dea7a8d user: mrwellan tags: v1.61
00:35
Factored tests into hash of id => testdat check-in: 6a2f23dbf3 user: matt tags: v1.61
2016-07-21
21:08
more rework check-in: aab4163601 user: mrwellan tags: v1.61
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified dashboard.scm from [8e0ed9ce08] to [dbda040961].

︙
159
160
161
162
163
164
165


166
167
168

169
170
171
172




173
174
175
176
177
178
179
180
181
182



183
184
185
186
187
188
189
190





191
192
193
194
195
196
197

198
199
200
201

202
203
204
205
206
207
208


209
210
211

212
213
214
215

216
217
218
219

220
221
222
223
224
225




226
227
228
229
230
231
232

159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215


216
217






218
219

220

221




222




223



224


225
226
227
228
229
230
231
232
233
234
235








+
+



+




+
+
+
+










+
+
+








+
+
+
+
+







+


-
-
+

-
-
-
-
-
-
+
+
-

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

-
-
+
+
+
+









;; data for each specific tab goes here
;;
(defstruct dboard:tabdat 
  ;; runs
  allruns          ;; list of dboard:rundat records
  allruns-by-id    ;; hash of run-id -> dboard:rundat records
  done-run-ids     ;; list of run-ids already drawn
  not-done-run-ids ;; list of run-ids not yet drawn
  header           ;; header for decoding the run records
  keys             ;; keys for this run (i.e. target components)
  numruns
  tot-runs

  ;; Runs view
  buttondat 
  item-test-names
  run-keys
  runs-matrix       ;; used in newdashboard
  start-run-offset  ;; left-right slider value
  start-test-offset ;; up-down slider value

  ;; Canvas and drawing data
  cnv
  cnv-obj
  drawing
  draw-cache     ;; 

  ;; 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 ...

  ;; Selector variables
  curr-run-id      ;; current row to display in Run summary view
  curr-test-ids    ;; used only in dcommon:run-update which is used in newdashboard
  filters-changed  ;; to to indicate that the user changed filters for this tab
  hide-empty-runs
  hide-not-hide    ;; toggle for hide/not hide empty runs
  hide-not-hide-button
  searchpatts
  state-ignore-hash    ;; hash of  STATE => #t/#f for display control
  status-ignore-hash   ;; hash of STATUS => #t/#f
  target
  test-patts

  ;; db info to file the .db files for the area
  dbdir
  dbfpath
  dbkeys 
  last-db-update  ;; last db file timestamp
  monitor-db-path ;; where to find monitor.db
  ro               ;; is the database read-only?

  ;; tests data
  last-update      ;; last time rmt:get-tests-for-run was used to get data
  num-tests
  num-tests        ;; total number of tests to show (used in the old runs display)

  path-run-ids
  ro
  run-keys
  run-name
  runs
  runs-listbox
  ;; runs tree
  path-run-ids     ;; path (target / runname) => id
  runs-matrix 
  runs-tree
  searchpatts

  start-run-offset
  start-test-offset
  state-ignore-hash
  states 
  ;; tab data
  status-ignore-hash
  statuses
  target
  test-patts
  last-update      ;; last time this tab was updated
  tests
  tests-tree
  tot-runs
  view-changed
  xadj
  yadj
  xadj             ;; x slider number (if using canvas)
  yadj             ;; y slider number (if using canvas)

  tests-tree       ;; used in newdashboard
  )

(define (dboard:tabdat-target-string vec)
  (let ((targ (dboard:tabdat-target vec)))
    (if (list? targ)(string-intersperse targ "/") "no-target-specified")))

(define (dboard:tabdat-test-patts-use vec)
︙
291
292
293
294
295
296
297
298
299



300
301

302
303
304
305
306
307
308

294
295
296
297
298
299
300


301
302
303
304

305
306
307
308
309
310
311
312








-
-
+
+
+

-
+








  )

;; used to keep the rundata from rmt:get-tests-for-run
;; in sync. 
;;
(defstruct dboard:rundat
  run
  tests-drawn
  tests  
  tests-drawn    ;; list of id's already drawn on screen
  tests-notdrawn ;; list of id's NOT already drawn
  tests          ;; hash of id => testdat
  key-vals
  last-update
  last-update    ;; last query to db got records from before last-update
  )

(define (dboard:runsdat-make-init)
  (make-dboard:runsdat
   runs-index: (make-hash-table)
   tests-index: (make-hash-table)
   matrix-dat: (make-sparse-array)))
︙
455
456
457
458
459
460
461
462
463
464



465
466
467
468
469
470
471
472
473
474
475
476
477












478
479

480
481
482
483
484

485
486
487
488
489
490
491
492
493
494
495
496
497












498
499
500
501
502
503
504
505
506

507
508

509

510
511
512
513
514
515
516
517
518
519
520
521
522
523
524




























525
526
527

528
529
530
531
532
533
534
535
536
537

538
539


540
541
542
543
544
545
546

459
460
461
462
463
464
465



466
467
468
469
470
471
472
473
474
475
476
477
478
479


480
481
482
483
484
485
486
487
488
489
490
491


492
493
494
495
496

497













498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516


517
518
519
520

521

522
523
524











525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553


554










555


556
557
558
559
560
561
562
563
564








-
-
-
+
+
+











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




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







-
-
+


+
-
+
-



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

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








	 (statuses    (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)))
	 (sort-info   (get-curr-sort))
	 (sort-by     (vector-ref sort-info 1))
	 (sort-order  (vector-ref sort-info 2))
	 (bubble-type (if (member sort-order '(testname))
			  'testname
			  'itempath))
	 (prev-dat    (let ((rec (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)))
			(if rec rec (make-dboard:rundat run: run tests: '() key-vals: key-vals last-update: -100)))) ;; -100 is before time began
	 (prev-tests  (dboard:rundat-tests prev-dat)) ;; (vector-ref prev-dat 1))
	 (run-dat    (let ((rec (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)))
			(if rec rec (make-dboard:rundat run: run tests: (make-hash-table) key-vals: key-vals last-update: -100)))) ;; -100 is before time began
	 ;; (prev-tests  (dboard:rundat-tests prev-dat)) ;; (vector-ref prev-dat 1))
	 (last-update (dboard:tabdat-last-update tabdat)) ;; (vector-ref prev-dat 3))
	 (tmptests    (rmt:get-tests-for-run run-id testnamepatt states statuses  ;; run-id testpatt states statuses
					     #f #f                                ;; offset limit 
					     (dboard:tabdat-hide-not-hide tabdat) ;; no-in
					     sort-by                              ;; sort-by
					     sort-order                           ;; sort-order
					     #f ;; 'shortlist                           ;; qrytype
					     (if (dboard:tabdat-filters-changed tabdat) 
						 0
						 last-update) ;; last-update
					     *dashboard-mode*)) ;; use dashboard mode
	 (tests      (dashboard:merge-changed-tests prev-tests tmptests  (dboard:tabdat-hide-not-hide tabdat) prev-tests)))
    (dboard:rundat-last-update-set! prev-dat (- (current-seconds) 10)) ;; go back two seconds in time to ensure all changes are captured.
	 (use-new    (dboard:tabdat-hide-not-hide tabdat))
	 (tests-ht   (dboard:rundat-tests run-dat))
	 (start-time (current-seconds)))
    (for-each 
     (lambda (tdat)
       (let ((test-id (db:test-get-id tdat))
	     (state   (db:test-get-state tdat)))
	 (if (equal? state "DELETED")
	     (hash-table-delete! tests-ht test-id)
	     (hash-table-set! tests-ht test-id tdat))))
     tmptests)
    (dboard:rundat-last-update-set! run-dat (- (current-seconds) 10)) ;; go back two seconds in time to ensure all changes are captured.
    (print "prev-tests: " (length prev-tests) " tests: " (length tests))
    tests))
    tests-ht))

;; tmptests   - new tests data
;; prev-tests - old tests data
;;
(define (dashboard:merge-changed-tests tests tmptests use-new prev-tests) 
;; (define (dashboard:merge-changed-tests tabdat tests tmptests) ;;  use-new prev-tests) 
  (let ((start-time (current-seconds))
	(newdat     (filter
		     (lambda (x)
		       (not (equal? (db:test-get-state x) "DELETED"))) ;; remove deleted tests but do it after merging
		     (delete-duplicates (if use-new ;; (dboard:tabdat-filters-changed tabdat)
					    tmptests
					    (append tmptests prev-tests))
					(lambda (a b)
					  (eq? (db:test-get-id a)(db:test-get-id b)))))))
    (print "Time took: " (- (current-seconds) start-time))
    (if (eq? *tests-sort-reverse* 3) ;; +event_time
	(sort newdat dboard:compare-tests)
	newdat)))
;;   (let* ((newdat     (filter
;; 		      (lambda (x)
;; 			(not (equal? (db:test-get-state x) "DELETED"))) ;; remove deleted tests but do it after merging
;; 		      (delete-duplicates (if use-new ;; (dboard:tabdat-filters-changed tabdat)
;; 					     tmptests
;; 					     (append tmptests prev-tests))
;; 					 (lambda (a b)
;; 					   (eq? (db:test-get-id a)(db:test-get-id b)))))))
;;     (print "Time took: " (- (current-seconds) start-time))
;;     (if (eq? *tests-sort-reverse* 3) ;; +event_time
;; 	(sort newdat dboard:compare-tests)
;; 	newdat)))

;; this calls dboard:get-tests-for-run-duplicate for each run
;;
;; create a virtual table of all the tests
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
;;
(define (update-rundat tabdat runnamepatt numruns testnamepatt keypatts)
  (let* ((referenced-run-ids '())
	 (allruns     (rmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts))
  (let* ((allruns     (rmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts))
	 (header      (db:get-header allruns))
	 (runs        (db:get-rows   allruns))
	 (start-time  (current-seconds)))
	 (result      '())
    (dboard:tabdat-header-set! tabdat header)
	 (maxtests    0))
    ;; 
    ;; trim runs to only those that are changing often here
    ;; 
    (for-each (lambda (run)
		(let* ((run-id      (db:get-value-by-header run header "id"))
		       (key-vals    (rmt:get-key-vals run-id))
		       (tests       (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
		       (num-tests   (length tests)))
		  ;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat)
		  ;; (tests       (bubble-up tmptests priority: bubble-type))
		  ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively.
		  ;; (debug:print 0 *default-log-port* "Getting data for run " run-id " with key-vals=" key-vals)
		  ;; Not sure this is needed?
		  (if (not (null? tests))
    (if (not (null? runs))
	(let loop ((run      (car runs))
		   (tal      (cdr runs))
		   (res     '())
		   (maxtests 0))
	  (let* ((run-id       (db:get-value-by-header run header "id"))
		 (key-vals     (rmt:get-key-vals run-id))
		 (tests-ht     (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
		 (all-test-ids (hash-table-keys tests-ht))
		 (num-tests    (length all-test-ids)))
	    ;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat)
	    ;; (tests       (bubble-up tmptests priority: bubble-type))
	    ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively.
	    ;; (debug:print 0 *default-log-port* "Getting data for run " run-id " with key-vals=" key-vals)
	    ;; Not sure this is needed?
	    (if (not (null? all-test-ids))
		(let* ((newmaxtests (max num-tests maxtests))
		       (last-update (- (current-seconds) 10))
		       (run-struct  (make-dboard:rundat 
				     run:         run 
				     tests:       tests-ht
				     key-vals:    key-vals
				     last-update: last-update))
		       (new-res     (cons run-struct res))
		       (elapsed-time (- (current-seconds) start-time)))
		  (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct)
		  (if (or (null? tal)
			  (> elapsed-time 5)) ;; stop loading data after 5 seconds, on the next call more data *should* be loaded since get-tests-for-run uses last update
		      (begin
			(set! referenced-run-ids (cons run-id referenced-run-ids))
			(if (> num-tests maxtests)
			(if (> elapsed-time 5)(print "WARNING: timed out in update-testdat " elapsed-time "s"))
			    (set! maxtests num-tests))
			;; (if (or (not (dboard:tabdat-hide-empty-runs tabdat)) ;; this reduces the data burden when set
			;;	(not (null? tests)))
			(let* ((last-update (- (current-seconds) 10))
			       (run-struct  (make-dboard:rundat run: run tests: tests key-vals: key-vals last-update: last-update)))
			  (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct)
			  (set! result (cons run-struct result)))))))
	      runs)
    (dboard:tabdat-header-set! tabdat header)
    (dboard:tabdat-allruns-set! tabdat result)
			(dboard:tabdat-allruns-set! tabdat new-res)
    (debug:print-info 6 *default-log-port* "(dboard:tabdat-allruns tabdat) has " (length (dboard:tabdat-allruns tabdat)) " runs")
    maxtests))
			maxtests)
		      (loop (car tal)(cdr tal) new-res newmaxtests)))))))))

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

(define (toggle-hide lnum uidat) ; fulltestname)
  (let* ((btn (vector-ref (dboard:uidat-get-lftcol uidat) lnum))
	 (fulltestname (iup:attribute btn "TITLE"))
	 (parts        (string-split fulltestname "("))
︙
2292
2293
2294
2295
2296
2297
2298
2299
2300


2301
2302
2303


2304
2305
2306
2307



2308

2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320















2321
2322
2323
2324
2325
2326
2327
2328






2329
2330
2331
2332
2333
2334



2335
2336
2337


2338
2339
2340
2341
2342
2343
2344

2310
2311
2312
2313
2314
2315
2316


2317
2318
2319


2320
2321
2322
2323
2324

2325
2326
2327
2328
2329












2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347





2348
2349
2350
2351
2352
2353
2354
2355
2356



2357
2358
2359
2360


2361
2362
2363
2364
2365
2366
2367
2368
2369








-
-
+
+

-
-
+
+



-
+
+
+

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



-
-
-
-
-
+
+
+
+
+
+



-
-
-
+
+
+

-
-
+
+








  (if (null? lst)
      #f ;; better than an exception for my needs
      (fold (lambda (a b)
	      (if (comp a b) a b))
	    (car lst)
	    lst)))

(define-inline (dboard:sort-testsdat-by-event-time testsdat)
  (sort testsdat
(define-inline (dboard:sort-testsdat-by-event-time test-ids tests-ht)
  (sort test-ids
	(lambda (a b)
	  (< (db:test-get-event_time a)
	     (db:test-get-event_time b)))))
	  (< (db:test-get-event_time (hash-table-ref tests-ht a))
	     (db:test-get-event_time (hash-table-ref tests-ht b))))))

;; first group items into lists, then sort by time
;; finally sort by first item time
;;
;; 
;; NOTE: we are returning lists of lists of ids!
;;
(define (dboard:tests-sort-by-time-group-by-item testsdat)
  (let ((test-ids (hash-table-keys testsdat)))
  (if (null? testsdat)
      testsdat
      (let* ((tests (let ((ht (make-hash-table)))
		      (for-each
		       (lambda (tdat)
			 (let ((testname (db:test-get-testname tdat)))
			   (hash-table-set! 
			    ht 
			    testname
			    (cons tdat (hash-table-ref/default ht testname '())))))
		       testsdat)
		      ht)))
    (if (null? test-ids)
	test-ids
	;; now group all tests by testname tname => (id1 id2 ...), tname2 => ( ...
	(let* ((test-ids-by-name
		(let ((ht (make-hash-table)))
		  (for-each
		   (lambda (tdat)
		     (let ((testname (db:test-get-testname tdat))
			   (test-id  (db:test-get-id tdat)))
		       (hash-table-set! 
			ht 
			testname
			(cons test-id (hash-table-ref/default ht testname '())))))
		   (hash-table-values testsdat))
		  ht)))
	;; remove toplevel tests from iterated tests, sort tests in the list by event time
	(for-each 
	 (lambda (testname)
	   (let ((testslst (hash-table-ref tests testname)))
	     (if (> (length testslst) 1) ;; must be iterated
		 (let ((item-tests (filter (lambda (tdat) ;; filter out toplevel tests
					     (not (equal? (db:test-get-item-path tdat) "")))
					   testslst)))
	   (let ((tests-id-lst (hash-table-ref test-ids-by-name testname)))
	     (if (> (length tests-id-lst) 1) ;; must be iterated
		 (let ((item-tests (filter (lambda (tid) ;; filter out toplevel tests
					     (let ((tdat (hash-table-ref testsdat tid)))
					       (not (equal? (db:test-get-item-path tdat) ""))))
					   tests-id-lst)))
		   (if (not (null? item-tests)) ;; resist bad data, generally should not fail this condition
		       (hash-table-set! tests 
					testname 
					(dboard:sort-testsdat-by-event-time item-tests)))))))
	 (hash-table-keys tests))
	(sort (hash-table-values tests)
					(dboard:sort-testsdat-by-event-time item-tests testsdat)))))))
	 (hash-table-keys test-ids-by-name))
	(sort (hash-table-values test-ids-by-name)
	      (lambda (a b)
		(< (db:test-get-event_time (car a))
		   (db:test-get-event_time (car b))))))))
		(< (db:test-get-event_time (hash-table-ref testsdat (car a)))
		   (db:test-get-event_time (hash-table-ref testsdat (car b))))))))))

(define (dashboard:run-times-tab-updater commondat tab-num)
  ;; each test is an object in the run component
  ;; each run is a component
  ;; all runs stored in runslib library
  (let* ((tabdat        (dboard:common-get-tabdat commondat tab-num: tab-num))
	 (canvas-margin 10)
︙
2391
2392
2393
2394
2395
2396
2397
2398

2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409

2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422




2423
2424
2425
2426
2427
2428
2429

2416
2417
2418
2419
2420
2421
2422

2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433

2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445


2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456








-
+










-
+











-
-
+
+
+
+








	     (dboard:tabdat-view-changed 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))
	  (print "Updating rundat")
	  (time (update-rundat tabdat
	  (update-rundat tabdat
			 "%" ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") 
			 100  ;; (dboard:tabdat-numruns tabdat)
			 "%" ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
			 ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%")
			 (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))))))
				     (dboard:tabdat-dbkeys tabdat))
			   res)))
			   res))
	  (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)
	      (for-each
	       (lambda (rundat)
		 (if rundat
		     (let* ((run       (dboard:rundat-run rundat))
			    (hierdat   (dboard:tests-sort-by-time-group-by-item (dboard:rundat-tests rundat)))
			    (testsdat  (apply append hierdat))
			    (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))
			    (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 "/"))
︙
2451
2452
2453
2454
2455
2456
2457
2458

2459
2460

2461
2462

2463
2464
2465
2466
2467



2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485

2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501

2502
2503
2504

2505
2506
2507
2508
2509
2510
2511
2512
2513
2514

2515
2516
2517
2518
2519
2520
2521

2478
2479
2480
2481
2482
2483
2484

2485
2486

2487
2488

2489
2490
2491
2492


2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511


2512
2513
2514
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
2547
2548








-
+

-
+

-
+



-
-
+
+
+
















-
-
+















-
+


-
+









-
+








		;; (let ((x 10)
		;; 	     (y (- sizey (* start-row row-height))))
		;; 	 (vg:add-objs-to-comp runcomp (vg:make-text x y run-full-name font: "Helvetica -10"))
		;; 	 (dashboard:add-bar rowhash start-row x (+ x 100)))
		       (set! start-row (+ start-row 1))
		       ;; get tests in list sorted by event time ascending
		       (for-each 
			(lambda (testdats)
			(lambda (test-ids)
			  (let ((test-objs   '())
				(iterated     (> (length testdats) 1))
				(iterated     (> (length test-ids) 1))
				(first-rownum #f)
				(num-items    (length testdats))
				(num-items    (length test-ids))
				(item-num     0))
			    (set! test-num (+ test-num 1))
			    (for-each 
			     (lambda (testdat)
			       (let* ((event-time   (maptime (db:test-get-event_time   testdat)))
			     (lambda (test-id)
			       (let* ((testdat      (hash-table-ref tests-ht test-id))
				      (event-time   (maptime (db:test-get-event_time   testdat)))
				      (run-duration (* timescale (db:test-get-run_duration testdat)))
				      (end-time     (+ event-time run-duration))
				      (test-name    (db:test-get-testname     testdat))
				      (item-path    (db:test-get-item-path    testdat))
				      (state         (db:test-get-state       testdat))
				      (status        (db:test-get-status      testdat))
				      (test-fullname (conc test-name "/" item-path))
				      (name-color    (gutils:get-color-for-state-status state status)))
				 (set! item-num (+ item-num 1))
				 ;; (print "event_time: " (db:test-get-event_time   testdat) " mapped event_time: " event-time)
				 ;; (print "run-duration: "  (db:test-get-run_duration testdat) " mapped run_duration: " run-duration)
				 (if (> item-num 50)
				     (if (eq? 0 (modulo item-num 50))
					 (print "processing " run-num " of " num-runs " runs " item-num " of " num-items " of test " test-name ", " test-num " of " num-tests " tests")))
				 (let loop ((rownum run-start-row)) ;; (+ start-row 1)))
				   (set! max-row (max rownum max-row)) ;; track the max row used
				   (print "Allocating test")
				   (time (if (dashboard:row-collision rowhash rownum event-time end-time)
				   (if (dashboard:row-collision rowhash rownum event-time end-time)
				       (loop (+ rownum 1))
				       (let* ((lly (- sizey (* rownum row-height)))
					      (uly (+ lly row-height))
					      (obj (vg:make-rect-obj event-time lly end-time uly
									    fill-color: (vg:iup-color->number (car name-color))
									    text: (if iterated item-path test-name)
									    font: "Helvetica -10")))
					 ;; (if iterated
					 ;;     (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))))))
					 (set! test-objs (cons obj test-objs)))))
				 ;; (print "test-name: " test-name " event-time: " event-time " run-duration: " run-duration)
				 ))
			   testdats)
			   test-ids)
			    ;; If it is an iterated test put box around it now.
			    (if iterated
				(let* ((xtents (vg:get-extents-for-objs drawing test-objs))
				       (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 (car testdats))
									     text:  (db:test-get-testname (hash-table-ref tests-ht (car test-ids)))
									     font: "Helvetica -10"))))))
			hierdat)
		       ;; placeholder box
		       (set! max-row (+ max-row 1))
		       (let ((y   (- sizey (* max-row row-height))))
			 (vg:add-obj-to-comp runcomp (vg:make-rect-obj 0 y 0 y)))
		       ;; instantiate the component
︙

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