Megatest

Check-in [0354dc0594]
Login
Overview
Comment:Added beginnings of hierarcial browser for runs/tests
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | development
Files: files | file ages | folders
SHA1: 0354dc0594c0875b512e6e6a56c7e624d5166550
User & Date: matt on 2013-03-20 01:13:49
Other Links: branch diff | manifest | tags
Context
2013-03-20
01:22
Added beginnings of hierarcial browser for runs/tests check-in: 7eba48f076 user: matt tags: development
01:13
Added beginnings of hierarcial browser for runs/tests check-in: 0354dc0594 user: matt tags: development
2013-03-19
21:48
Adding couple iup templates for convinence check-in: dcb61c5ab0 user: matt tags: development
Changes

Modified iupexamples/tree.scm from [47b7e553da] to [d7a813a1c2].

1
2
3
4
5
6
7
8
9
10
11
12
13




14
15
16
17

18
19
20
21
22
23
24
25
26
27




















28
1
2
3
4
5
6
7
8
9




10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49









-
-
-
-
+
+
+
+




+










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


(use iup)

(define t #f) 

(define tree-dialog
  (dialog
   #:title "Tree Test"
   (let ((t1 (treebox
                 #:selection_cb (lambda (obj id state)
                                    (print "selection_db with id=" id " state=" state)
                                    (print "SPECIALDATA: " (attribute obj "SPECIALDATA"))
                                    ))))
	      #:selection_cb (lambda (obj id state)
			       (print "selection_db with id=" id " state=" state)
			       (print "SPECIALDATA: " (attribute obj "SPECIALDATA"))
			       ))))
     (set! t t1)
     t1)))

(show tree-dialog)

(map (lambda (elname el)
       (print "Adding " elname " with value " el)
       (attribute-set! t elname el)
       (attribute-set! t "SPECIALDATA" el))
     '("VALUE" "NAME"    "ADDLEAF" "ADDBRANCH1" "ADDLEAF2"    "VALUE")
     '("0"     "Figures" "Other"   "triangle"   "equilateral" "4")
     )
(map (lambda (attr)
       (print attr " is " (attribute t attr)))
     '("KIND1" "PARENT2" "STATE1"))

(define (tree-find-node obj path)
  ;; start at the base of the tree
  (let loop ((hed     (car path))
	     (tal     (cdr path))
	     (depth   0)
	     (nodenum 0))
    (attribute-set! obj "VALUE" nodenum)
    (if (not (equal? (string->number (attribute obj "VALUE")) nodenum))
	;; when not equal we have reached the end of the line
	#f
	(let ((node-depth (string->number (attribute obj (conc "DEPTH" nodenum))))
	      (node-title (attribute obj (conc "TITLE" nodenum))))
	  (if (and (equal? depth node-depth)
		   (equal? hed   node-title)) ;; yep, this is the one!
	      (if (null? tal) ;; end of the line
		  nodenum
		  (loop (car tal)(cdr tal)(+ depth 1) nodenum))
	      (loop hed tal depth (+ nodenum 1)))))))

(main-loop)

Modified newdashboard.scm from [6d2b8b8744] to [c4f927772d].

79
80
81
82
83
84
85



86
87
88
89
90
91
92
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95







+
+
+







    (client:launch))


(debug:setup)

(define *tim* (iup:timer))
(define *ord* #f)
(define *runs-matrix* #f) ;; This is the table of the runs, need it to be global (for now)
(define *runs-data*   #f)

(iup:attribute-set! *tim* "TIME" 300)
(iup:attribute-set! *tim* "RUN" "YES")

(define (message-window msg)
  (iup:show
   (iup:dialog
    (iup:vbox 
129
130
131
132
133
134
135
136
137


138
139
140
141
142
143
144
132
133
134
135
136
137
138


139
140
141
142
143
144
145
146
147







-
-
+
+







		       ;;  					     #:modal? #t
		       ;;  					     ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current
		       ;;  					     ;; #:x 'mouse
		       ;;  					     ;; #:y 'mouse
		       ;;  )					     
		       ))))



;; mtest is actually the megatest.config file
;;
(define (mtest)
  (let* ((curr-row-num     0)
	 (rawconfig        (read-config (conc *toppath* "/megatest.config") #f 'return-string))
	 (keys-matrix      (iup:matrix
		            #:expand "VERTICAL"
		            ;; #:scrollbar "YES"
		            #:numcol 1
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
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346






347
348
349

350
351
352


353
354
355
356
357
358
359
360




361
362
363
364
365
366
367
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
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348


















349













350
351
352


353
354
355
356
357
358
359
360
361
362
363
364
365
366
367

368
369
370
371
372
373
374
375

376
377



378
379
380
381
382
383
384
385
386
387
388







+
+




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











-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-

-
-
-
-
-
-
-
-
-
-
-
-
-



-
-







+
+
+
+
+
+


-
+



+
+


-


-
-
-
+
+
+
+







		      validvals-matrix)
		     ))))
	 (iup:attribute-set! tabs "TABTITLE0" "Required settings")
	 (iup:attribute-set! tabs "TABTITLE1" "Optional settings")
	 tabs))
       ))))

;; The runconfigs.config file
;;
(define (rconfig)
  (iup:vbox
   (iup:frame #:title "Default")))

(define (tests)
  (iup:hbox 
   (iup:frame #:title "Tests browser")))

(define *runs-matrix* #f)

(define *tests-treebox* #f)
(define *tests-node-map* (make-hash-table)) ;; map paths to nodes

;;======================================================================
;; tree stuff
;;======================================================================

;; path is a list of nodes, each the child of the previous
;; this routine returns the id so another node can be added
;; either as a leaf or as a branch
;;
;; BUG: This needs a stop sensor for when a branch is exhausted
;;
(define (tree-find-node obj path)
  ;; start at the base of the tree
  (let loop ((hed      (car path))
	     (tal      (cdr path))
	     (depth    0)
	     (nodenum  0)
)
;;	     (maxdepth 9999999999999)) ;; Use TOTALCHILDCOUNTid
    (iup:attribute-set! obj "VALUE" nodenum)
    (if (not (equal? (string->number (iup:attribute obj "VALUE")) nodenum))
	;; when not equal we have reached the end of the line
	#f
	(let ((node-depth (string->number (iup:attribute obj (conc "DEPTH" nodenum))))
	      (node-title (iup:attribute obj (conc "TITLE" nodenum))))
	  (if (and (equal? depth node-depth)
		   (equal? hed   node-title)) ;; yep, this is the one!
	      (if (null? tal) ;; end of the line
		  nodenum
		  (loop (car tal)(cdr tal)(+ depth 1) nodenum))
	      (loop hed tal depth (+ nodenum 1)))))))

;; Test browser
(define (tests)
  (iup:hbox 
   (let* ((tb      (iup:treebox
		    #:selection_cb (lambda (obj id state)
				     (print "obj: " obj ", id: " id ", state: " state)))))
     (set! *tests-treebox* tb)
     tb)
   (iup:vbox
    )))
       
;; Overall runs browser
;;
(define (runs)
  (let* ((runs-matrix     (iup:matrix
			   #:expand "YES"
			   ;; #:fittosize "YES"
			   #:scrollbar "YES"
			   #:numcol 100
			   #:numlin 100
			   #:numcol-visible 7
			   #:numlin-visible 7
			   #:click-cb (lambda (obj lin col status)
					(print "obj: " obj " lin: " lin " col: " col " status: " status)))))
;;     (iup:attribute-set! keys-matrix "0:0" "Field Num")
;;     (iup:attribute-set! keys-matrix "0:1" "Field Name")
;;     (iup:attribute-set! keys-matrix "WIDTH1" "100")
;;     (iup:attribute-set! disks-matrix "0:0" "Disk Name")
;;     (iup:attribute-set! disks-matrix "0:1" "Disk Path")
;;     (iup:attribute-set! disks-matrix "WIDTH1" "120")
;;     (iup:attribute-set! disks-matrix "WIDTH0" "100")
;;     (iup:attribute-set! disks-matrix "ALIGNMENT1" "ALEFT")
;;     (iup:attribute-set! disks-matrix "FIXTOTEXT" "C1")
;;     (iup:attribute-set! disks-matrix "RESIZEMATRIX" "YES")
    ;; fill in keys
;;     (set! curr-row-num 1)
;;     (for-each 
;;      (lambda (var)
;;        (iup:attribute-set! keys-matrix (conc curr-row-num ":0") curr-row-num)
;;        (iup:attribute-set! keys-matrix (conc curr-row-num ":1") var)
;;        (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup *configdat* "fields" var)))
;;      (configf:section-vars rawconfig "fields"))

    ;; fill in existing info
;;    (for-each 
;;     (lambda (mat fname)
;;       (set! curr-row-num 1)
;;       (for-each
;;	(lambda (var)
;;	  (iup:attribute-set! mat (conc curr-row-num ":0") var)
;;	  (iup:attribute-set! mat (conc curr-row-num ":1") (config-lookup rawconfig fname var))
;;	  (set! curr-row-num (+ curr-row-num 1)))
;;	(configf:section-vars rawconfig fname)))
;;     (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix disks-matrix)
;;     (list "setup"      "jobtools"      "validvalues"      "env-override" "disks"))

    (iup:attribute-set! runs-matrix "RESIZEMATRIX" "YES")
    (iup:attribute-set! runs-matrix "WIDTH0" "100")

;;    (iup:attribute-set! validvals-matrix "WIDTH1" "290")
;;    (iup:attribute-set! envovrd-matrix   "WIDTH1" "290")
    (set! *runs-matrix* runs-matrix)
    (iup:hbox
     (iup:frame 
      #:title "Runs browser"
      (iup:vbox
       runs-matrix)))))

;; Browse and control a single run
;;
(define (runcontrol)
  (iup:hbox))

;; Main Panel
(define (main-panel)
  (iup:dialog
   #:title "Menu Test"
   #:title "Megatest Control Panel"
   #:menu (main-menu)
   (let ((tabtop (iup:tabs 
		  (runs)
		  (tests)
		  (runcontrol)
		  (mtest) 
		  (rconfig)
		  (tests)
		  )))
     (iup:attribute-set! tabtop "TABTITLE0" "Runs")
     (iup:attribute-set! tabtop "TABTITLE3" "Tests")
     (iup:attribute-set! tabtop "TABTITLE1" "megatest.config") 
     (iup:attribute-set! tabtop "TABTITLE2" "runconfigs.config")
     (iup:attribute-set! tabtop "TABTITLE1" "Tests")
     (iup:attribute-set! tabtop "TABTITLE2" "Run Control")
     (iup:attribute-set! tabtop "TABTITLE3" "megatest.config") 
     (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config")
     tabtop)))

;;======================================================================
;; Process runs
;;======================================================================

(define *data* (make-hash-table))
375
376
377
378
379
380
381
382

383
384
385
386
387
388
389
390
391
392
393
394
395
396
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
423
396
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
423
424
425
426
427
428
429
430

431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475







-
+

















-
+
+
+
+
+





-
+
+










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







;;
;; Mode is 'full or 'incremental for full refresh or incremental refresh
(define (run-update keys data runname keypatts testpatt states statuses mode)
  (let* (;; count and offset => #f so not used
	 ;; the synchash calls modify the "data" hash
	 (get-runs-sig  (conc (client:get-signature) " get-runs"))
	 (get-tests-sig (conc (client:get-signature) " get-tests"))
	 (run-changes  (synchash:client-get 'db:get-runs get-runs-sig (length keypatts) data runname #f #f keypatts))
	 (run-changes   (synchash:client-get 'db:get-runs get-runs-sig (length keypatts) data runname #f #f keypatts))
	 ;; Now can calculate the run-ids
	 (run-hash    (hash-table-ref/default data get-runs-sig #f))
	 (run-ids     (if run-hash (filter number? (hash-table-keys run-hash)) '()))
	 (test-changes (synchash:client-get 'db:get-tests-for-runs-mindata get-tests-sig 0 data run-ids testpatt states statuses))
	 (runs-hash    (hash-table-ref/default data get-runs-sig #f))
	 (header       (hash-table-ref/default runs-hash "header" #f))
	 (run-ids      (sort (filter number? (hash-table-keys runs-hash))
			     (lambda (a b)
			       (let* ((record-a (hash-table-ref runs-hash a))
				      (record-b (hash-table-ref runs-hash b))
				      (time-a   (db:get-value-by-header record-a header "event_time"))
				      (time-b   (db:get-value-by-header record-b header "event_time")))
				 (> time-a time-b)))
			     ))
	 (runid-to-col    (hash-table-ref *data* "runid-to-col"))
	 (testname-to-row (hash-table-ref *data* "testname-to-row")) 
	 (colnum       1)
	 (rownum       0)) ;; rownum = 0 is the header
	 (rownum       0) ;; rownum = 0 is the header
	 ;; These are used in populating the tests tree
	 (branchnum   0)
	 (leafnum     0)) ;; IUP is funky here, keep adding using 
    
	 ;; tests related stuff
	 ;; (all-testnames (delete-duplicates (map db:test-get-testname test-changes))))

    ;; Given a run-id and testname/item_path calculate a cell R:C


    ;; NOTE: Also build the test tree browser and look up table
    ;;
    ;; Each run is unique on its keys and runname or run-id, store in hash on colnum
    (for-each (lambda (run-id)
		(let* (;; (run-id    (db:get-value-by-header rundat header "id"))
		       (run-record (hash-table-ref/default runs-hash run-id #f))
		       (key-vals   (map (lambda (key)(db:get-value-by-header run-record header key))
					  (map key:get-fieldname keys)))
		       (run-name   (db:get-value-by-header run-record header "runname"))
		       (col-name   (conc (string-intersperse key-vals "\n") "\n" run-name)))
		    (iup:attribute-set! *runs-matrix* (conc rownum ":" colnum) col-name)
		    (hash-table-set! runid-to-col run-id (list colnum run-record))
		    ;; Here we update *tests-treebox* and *tests-node-map* 
		    (let loop ((hed      (car key-vals))
			       (tal      (cdr key-vals))
			       (depth    0)
			       (pathl    (list (car key-vals))))
		      (let ((nodenum (tree-find-node *tests-treebox* pathl)))
			(if nodenum ;;
			    (if (not (null? tal)) ;; if null here then this path has already been added
				(loop (car tal)(cdr tal)(+ depth 1)(append pathl (list hed))))
			    (if (eq? depth 0)
				(iup:attribute-set! *tests-treebox* "INSERTBRANCH" hed)
				(debug:print 0 "ERROR: Failed to add " hed " no parent matching " pathl)))))
			    


;;		      (let* ((path         (string-intersperse pathl "/"))
;;			     (parent-found (hash-table-ref/default *tests-node-map* prevpath #f))
;;			     (found        (hash-table-ref/default *tests-node-map* path #f))
;;			     (refnode      (if parent-found parent-found 0))) ;; add to this node
;;			(if (not found) ;; this level in the hierarchy might have already been added
;;			    (begin
;;			      ;; first add to the tree
;;			      (iup:attribute-set! *tests-treebox* (conc "ADDBRANCH" (if refnode refnode 0)) hed)
;;			      (hash-table-set! *tests-node-map* path (iup:attribute *tests-treebox* "PARENT")))
;;		      (if (not (null? tal))
;;			  (loop (car tal)(cdr tal)(+ depth 1)(conc path "/" hed))))
		    (set! colnum (+ colnum 1))))
		run-ids)

    ;; Scan all tests to be displayed and organise all the test names, respecting what is in the hash table
    ;; Do this analysis in the order of the run-ids, the most recent run wins
    (for-each (lambda (run-id)
		(let* ((new-test-dat   (car test-changes))
473
474
475
476
477
478
479
















480
481
482
483
484
485
486
487
488
489

490
491
492
493
494
495
496
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
565







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










+







			    tests)))
	      run-ids)

    (iup:attribute-set! *runs-matrix* "REDRAW" "ALL")
    ;; (debug:print 2 "run-changes: " run-changes)
    ;; (debug:print 2 "test-changes: " test-changes)
    (list run-changes test-changes)))

;; Given the master data struct and a key fill out the tree
;; browser for tests
;;
;; node-path is a hash of node-id to path key1/key2/key3/runname/testname/itempath
;;
;; (define (test-tree-update testtree runsdata node-path)
;;   (let* ((runs-sig   (conc (client:get-signature " get-runs")))
;; 	 (tests-sig  (conc (client:get-signature) " get-tests"))
;; 	 (runs-data  (hash-table-ref/default runsdata #f))
;; 	 (tests-data (hash-table-ref/default runsdata #f)))
;;     (if (not runs-data) 
;; 	(debug:print 0 "ERROR: no data found for " runs-sig)
;; 	(for-each (lambda (run-id)
;; 		    (let ((run-dat (hash-table-ref runs-data run-id)))
		    

(define (newdashboard)
  (let* ((data     (make-hash-table))
	 (keys     (cdb:remote-run db:get-keys #f))
	 (runname  "%")
	 (testpatt "%")
	 (keypatts (map (lambda (k)(list (vector-ref k 0) "%")) keys))
	 (states   '())
	 (statuses '())
	 (nextmintime (current-milliseconds)))
    (set! *runs-data* data) ;; make this data available to the rest of the application
    (iup:show (main-panel))
    (iup:callback-set! *tim*
		       "ACTION_CB"
		       (lambda (x)
			 ;; Want to dedicate no more than 50% of the time to this so skip if
			 ;; 2x delta time has not passed since last query
			 (if (< nextmintime (current-milliseconds))