Megatest

Check-in [f9fa5243ad]
Login
Overview
Comment:Tree working for target
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | development
Files: files | file ages | folders
SHA1: f9fa5243ad1244d72f35c67379e1929f382032b4
User & Date: mrwellan on 2013-03-20 15:56:02
Other Links: branch diff | manifest | tags
Context
2013-03-20
16:17
Added runname, tests and item paths to tree check-in: 972ecc05ca user: mrwellan tags: development
15:56
Tree working for target check-in: f9fa5243ad user: mrwellan tags: development
01:22
Added beginnings of hierarcial browser for runs/tests check-in: 7eba48f076 user: matt tags: development
Changes

Modified iupexamples/tree.scm from [d7a813a1c2] to [63330b3b4e].

1
2

3
4
5
6
7
8
9
1

2
3
4
5
6
7
8
9

-
+








(use iup)
(use iup test)

(define t #f) 

(define tree-dialog
  (dialog
   #:title "Tree Test"
   (let ((t1 (treebox
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

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
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104







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

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

+
     )
(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
  (if (null? path)
      #f ;; or 0 ????
  (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))
      (let loop ((hed      (car path))
		 (tal      (cdr path))
		 (depth    0)
		 (nodenum  0))
	;; (debug:print 0 "hed: " hed ", depth: " depth ", nodenum: " nodenum)
	;; nodes in iup tree are 100% sequential so iterate over nodenum
	(if (attribute obj (conc "DEPTH" nodenum)) ;; end when no more nodes
	;; 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)))))))
	    (let ((node-depth (string->number (attribute obj (conc "DEPTH" nodenum))))
		  (node-title (attribute obj (conc "TITLE" nodenum))))
	      ;; (print 0 "hed: " hed ", depth: " depth ", node-depth: " node-depth ", nodenum: " nodenum ", node-title: " node-title)
	      (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)(+ 1 nodenum)))
		  ;; this is the case where we found part of the hierarchy but not 
		  ;; all of it, i.e. the node-depth went from deep to less deep
		  (if (> depth node-depth) ;; (+ 1 node-depth))
		      #f
		      (loop hed tal depth (+ nodenum 1)))))
	    #f))))

;; top is the top node name zeroeth node VALUE=0
(define (tree-add-node obj top nodelst)
  (if (not (attribute obj "TITLE0"))
      (attribute-set! obj "ADDBRANCH0" top))
  (cond
   ((not (string=? top (attribute obj "TITLE0")))
    (print "ERROR: top name " top " doesn't match " (attribute obj "TITLE0")))
   ((null? nodelst))
   (else
    (let loop ((hed      (car nodelst))
	       (tal      (cdr nodelst))
	       (depth    1)
	       (pathl    (list top)))
      ;; Because the tree dialog changes node numbers when
      ;; nodes are added or removed we must look up nodes
      ;; each and every time. 0 is the top node so default
      ;; to that.
      (let* ((newpath    (append pathl (list hed)))
	       (parentnode (tree-find-node obj pathl))
	       (nodenum    (tree-find-node obj newpath)))
	  ;; (print "newpath: " newpath ", nodenum " nodenum ", hed: " hed ", depth: " depth ", parentnode: " parentnode ", pathl: " pathl)
	  ;; Add the branch under lastnode if not found
	  (if (not nodenum)
	      (begin
		(attribute-set! obj (conc "ADDBRANCH" parentnode) hed)
		(if (null? tal)
		    #t
		    ;; reset to top
		    (loop (car nodelst)(cdr nodelst) 1 (list top)))) 
	      (if (null? tal) ;; if null here then this path has already been added
		  #t
		  ;; (if nodenum
		  (loop (car tal)(cdr tal)(+ depth 1) newpath)))))))) ;;  (if nodenum nodenum lastnode)))))))
	      ;; 	  (loop hed tal depth pathl lastnode)))))))

(test #f 0  (tree-find-node t '("Figures")))
(test #f 1  (tree-find-node t '("Figures" "Other")))
(test #f #f (tree-find-node t '("Figures" "Other"    "equilateral")))
(test #f 3  (tree-find-node t '("Figures" "triangle" "equilateral")))
(test #f #t (tree-add-node  t "Figures" '()))
(test #f #t (tree-add-node  t "Figures" '("a" "b" "c")))
(test #f 3  (tree-find-node t '("Figures" "a" "b" "c")))
(test #f #t (tree-add-node  t "Figures" '("d" "b" "c")))
(test #f 3  (tree-find-node t '("Figures" "d" "b" "c")))
(test #f 6  (tree-find-node t '("Figures" "a" "b" "c")))
(test #f #t (tree-add-node  t "Figures" '("a" "e" "c")))
(test #f 6  (tree-find-node t '("Figures" "a" "e" "c")))
(main-loop)

Modified megatest.scm from [80fae04dd6] to [af1aafcd34].

30
31
32
33
34
35
36
37

38
39
40
41
42
43
44
30
31
32
33
34
35
36

37
38
39
40
41
42
43
44







-
+








(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "megatest-fossil-hash.scm")

(define help (conc "
Megatest, documentation at http://www.kiatoa.com/fossils/megatest
Megatest, documentation at http://chiselapp.com/user/kiatoa/repository/megatest
  version " megatest-version "
  license GPL, Copyright Matt Welland 2006-2012

Usage: megatest [options]
  -h                      : this help
  -version                : print megatest version (currently " megatest-version ")

Modified newdashboard.scm from [57ed781660] to [dd9f1af6fd].

79
80
81
82
83
84
85
86
87














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


86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106







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







    (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)

(define *data* (make-vector 6 #f))
(define-inline (dboard:data-get-runs          vec)    (vector-ref  vec 0))
(define-inline (dboard:data-get-tests         vec)    (vector-ref  vec 1))
(define-inline (dboard:data-get-runs-matrix   vec)    (vector-ref  vec 2))
(define-inline (dboard:data-get-tests-tree    vec)    (vector-ref  vec 3))
(define-inline (dboard:data-get-tree-keys     vec)    (vector-ref  vec 4))
(define-inline (dboard:data-set-runs!         vec val)(vector-set! vec 0 val))
(define-inline (dboard:data-set-tests!        vec val)(vector-set! vec 1 val))
(define-inline (dboard:data-set-runs-matrix!  vec val)(vector-set! vec 2 val))
(define-inline (dboard:data-set-tests-tree!   vec val)(vector-set! vec 3 val))
(define-inline (dboard:data-set-tree-keys!    vec val)(vector-set! vec 4 val))

(dboard:data-set-tree-keys! *data* (make-hash-table))

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

(define (message-window msg)
  (iup:show
   (iup:dialog
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
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







-
-
-












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







-
+
+
+








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

(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
  (if (null? path)
      #f ;; or 0 ????
  (let loop ((hed      (car path))
	     (tal      (cdr path))
	     (depth    0)
	     (nodenum  0)
      (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))
	;; nodes in iup tree are 100% sequential so iterate over nodenum
	(if (iup:attribute obj (conc "DEPTH" nodenum)) ;; end when no more nodes
	;; 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)))))))
	    (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)(+ 1 nodenum)))
		  ;; this is the case where we found part of the hierarchy but not 
		  ;; all of it, i.e. the node-depth went from deep to less deep
		  (if (> depth node-depth) ;; (+ 1 node-depth))
		      #f
		      (loop hed tal depth (+ nodenum 1)))))
	    #f))))

;; top is the top node name zeroeth node VALUE=0
(define (tree-add-node obj top nodelst)
  (if (not (iup:attribute obj "TITLE0"))
      (iup:attribute-set! obj "ADDBRANCH0" top))
  (cond
   ((not (string=? top (iup:attribute obj "TITLE0")))
    (print "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0")))
   ((null? nodelst))
   (else
    (let loop ((hed      (car nodelst))
	       (tal      (cdr nodelst))
	       (depth    1)
	       (pathl    (list top)))
      ;; Because the tree dialog changes node numbers when
      ;; nodes are added or removed we must look up nodes
      ;; each and every time. 0 is the top node so default
      ;; to that.
      (let* ((newpath    (append pathl (list hed)))
	     (parentnode (tree-find-node obj pathl))
	     (nodenum    (tree-find-node obj newpath)))
	;; Add the branch under lastnode if not found
	(if (not nodenum)
	    (begin
	      (iup:attribute-set! obj (conc "ADDBRANCH" parentnode) hed)
	      (if (null? tal)
		  #t
		  ;; reset to top
		  (loop (car nodelst)(cdr nodelst) 1 (list top)))) 
	    (if (null? tal) ;; if null here then this path has already been added
		#t
		(loop (car tal)(cdr tal)(+ depth 1) newpath))))))))


;; 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)
     (iup:attribute-set! tb "VALUE" "0")
     (iup:attribute-set! tb "NAME" "Runs")
     (dboard:data-set-tests-tree! *data* tb)
     tb)
   (iup:vbox
    )))
       
;; Overall runs browser
;;
(define (runs)
346
347
348
349
350
351
352
353

354
355
356
357
358
359
360
393
394
395
396
397
398
399

400
401
402
403
404
405
406
407







-
+







			   #:numlin-visible 7
			   #:click-cb (lambda (obj lin col status)
					(print "obj: " obj " lin: " lin " col: " col " status: " status)))))

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

    (set! *runs-matrix* runs-matrix)
    (dboard:data-set-runs-matrix! *data* runs-matrix)
    (iup:hbox
     (iup:frame 
      #:title "Runs browser"
      (iup:vbox
       runs-matrix)))))

;; Browse and control a single run
381
382
383
384
385
386
387

388
389
390



391
392
393
394
395
396
397
428
429
430
431
432
433
434
435



436
437
438
439
440
441
442
443
444
445







+
-
-
-
+
+
+







     (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config")
     tabtop)))

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

;; MOVE THIS INTO *data*
(define *data* (make-hash-table))
(hash-table-set! *data* "runid-to-col"    (make-hash-table))
(hash-table-set! *data* "testname-to-row" (make-hash-table))
(define *cachedata* (make-hash-table))
(hash-table-set! *cachedata* "runid-to-col"    (make-hash-table))
(hash-table-set! *cachedata* "testname-to-row" (make-hash-table))

;; TO-DO
;;  1. Make "data" hash-table hierarchial store of all displayed data
;;  2. Update synchash to understand "get-runs", "get-tests" etc.
;;  3. Add extraction of filters to synchash calls
;;
;; Mode is 'full or 'incremental for full refresh or incremental refresh
411
412
413
414
415
416
417
418
419


420
421
422
423
424
425
426
459
460
461
462
463
464
465


466
467
468
469
470
471
472
473
474







-
-
+
+







			     (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")) 
	 (runid-to-col    (hash-table-ref *cachedata* "runid-to-col"))
	 (testname-to-row (hash-table-ref *cachedata* "testname-to-row")) 
	 (colnum       1)
	 (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
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
476
477
478
479
482
483
484
485
486
487
488
489



490
491
492















493














494
495
496
497
498
499
500
501
502







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







    (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! (dboard:data-get-runs-matrix *data*)
		    (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* 
				      (conc rownum ":" colnum) col-name)
		  (hash-table-set! runid-to-col run-id (list colnum run-record))
		  ;; Here we update the tests treebox and tree keys
		    (let loop ((hed      (car key-vals))
			       (tal      (cdr key-vals))
			       (depth    0)
			       (pathl    '()))
		      (let* ((newpath (append pathl (list hed)))
			     (nodenum (tree-find-node *tests-treebox* newpath)))
			(debug:print-info 0 "nodenum: " nodenum ", newpath: " newpath)
			(if nodenum ;;
			    (if (not (null? tal)) ;; if null here then this path has already been added
				(loop (car tal)(cdr tal)(+ depth 1) newpath))
			    ;; (if (eq? depth 0)
			    (iup:attribute-set! *tests-treebox* "INSERTBRANCH" hed)
			    ;; (debug:print 0 "ERROR: Failed to add " hed " no parent matching " pathl)))))
			    )))

		  (tree-add-node (dboard:data-get-tests-tree *data*) "Runs" key-vals)

;;		      (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)
		  (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))
		       (removed-tests  (cadr test-changes))
		       (tests          (sort (map cadr (filter (lambda (testrec)
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
565
566
567
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
566
567
568
569
570
571

572
573
574
575
576
577
578
579







+
-
+



+
-
+



+
+
-
+




-
+




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









-
+







				(if (not rownum)
				    (let ((rownums (hash-table-values testname-to-row)))
				      (set! rownum (if (null? rownums)
						       1
						       (+ 1 (apply max rownums))))
				      (hash-table-set! testname-to-row fullname rownum)
				      ;; create the label
				      (iup:attribute-set! (dboard:data-get-runs-matrix *data*)
				      (iup:attribute-set! *runs-matrix* (conc rownum ":" 0) dispname)
							  (conc rownum ":" 0) dispname)
				      ))
				;; set the cell text and color
				;; (debug:print 2 "rownum:colnum=" rownum ":" colnum ", state=" status)
				(iup:attribute-set! (dboard:data-get-runs-matrix *data*)
				(iup:attribute-set! *runs-matrix* (conc rownum ":" colnum)
						    (conc rownum ":" colnum)
						    (if (string=? state "COMPLETED")
							status
							state))
				(iup:attribute-set! (dboard:data-get-runs-matrix *data*)
						    (conc "BGCOLOR" rownum ":" colnum)
				(iup:attribute-set! *runs-matrix* (conc "BGCOLOR" rownum ":" colnum) (gutils:get-color-for-state-status state status))
						    (gutils:get-color-for-state-status state status))
				))
			    tests)))
	      run-ids)

    (iup:attribute-set! *runs-matrix* "REDRAW" "ALL")
    (iup:attribute-set! (dboard:data-get-runs-matrix *data*) "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
    (dboard:data-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))