125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
|
;; 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
(define (run-update keys data runname keypatts testpatt states statuses mode window-id)
(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"))
(get-details-sig (conc (client:get-signature) " get-test-details"))
;; test-ids to get and display are indexed on window-id in curr-test-ids hash
(test-ids (hash-table-values (dboard:data-get-curr-test-ids *data*)))
(run-changes (synchash:client-get 'db:get-runs get-runs-sig (length keypatts) data runname #f #f keypatts))
(tests-detail-changes (if (not (null? test-ids))
(synchash:client-get 'db:get-test-info-by-ids get-details-sig 0 data test-ids)
'()))
;; 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 #f))
|
|
|
|
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
|
;; 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
(define (dcommon:run-update keys data runname keypatts testpatt states statuses mode window-id)
(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"))
(get-details-sig (conc (client:get-signature) " get-test-details"))
;; test-ids to get and display are indexed on window-id in curr-test-ids hash
(test-ids (hash-table-values (dboard:data-get-curr-test-ids *data*)))
(run-changes (synchash:client-get 'db:get-runs get-runs-sig (length keypatts) data runname #f #f keypatts))
(tests-detail-changes (if (not (null? test-ids))
(synchash:client-get 'db:get-test-info-by-ids get-details-sig 0 data #f test-ids)
'()))
;; 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 #f))
|
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
|
(testname (db:mintest-get-testname test))
(itempath (db:mintest-get-item_path test))
(fullname (conc testname "/" itempath))
(dispname (if (string=? itempath "") testname (conc " " itempath)))
(rownum (hash-table-ref/default testname-to-row fullname #f))
(test-path (append run-path (if (equal? itempath "")
(list testname)
(list testname itempath)))))
(tree:add-node (dboard:data-get-tests-tree *data*) "Runs"
test-path
userdata: (conc "test-id: " test-id))
(hash-table-set! (dboard:data-get-path-test-ids *data*) test-path test-id)
(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)
|
|
>
>
>
>
>
>
|
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
|
(testname (db:mintest-get-testname test))
(itempath (db:mintest-get-item_path test))
(fullname (conc testname "/" itempath))
(dispname (if (string=? itempath "") testname (conc " " itempath)))
(rownum (hash-table-ref/default testname-to-row fullname #f))
(test-path (append run-path (if (equal? itempath "")
(list testname)
(list testname itempath))))
(tb (dboard:data-get-tests-tree *data*)))
(print "INFONOTE: run-path: " run-path)
(tree:add-node (dboard:data-get-tests-tree *data*) "Runs"
test-path
userdata: (conc "test-id: " test-id))
(let ((node-num (tree:find-node tb (cons "Runs" test-path)))
(color (car (gutils:get-color-for-state-status state status))))
(debug:print 0 "node-num: " node-num ", color: " color)
(iup:attribute-set! tb (conc "COLOR" node-num) color))
(hash-table-set! (dboard:data-get-path-test-ids *data*) test-path test-id)
(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)
|
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
|
(set! dashboard:update-summary-tab updater)
(iup:attribute-set! stats-matrix "WIDTHDEF" "40")
(iup:vbox
;; (iup:label "Run statistics" #:expand "HORIZONTAL")
stats-matrix)))
(define (dcommon:servers-table)
(let* ((colnum 0)
(let ((servers (open-run-close tasks:get-all-servers tasks:open-db)))
(iup:attribute-set! servers-matrix "NUMLIN" (length servers))
;; (set! colnum 0)
;; (for-each (lambda (colname)
;; ;; (print "colnum: " colnum " colname: " colname)
;; (iup:attribute-set! servers-matrix (conc "0:" colnum) colname)
;; (set! colnum (+ 1 colnum)))
;; colnames)
|
>
|
|
|
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
|
(set! dashboard:update-summary-tab updater)
(iup:attribute-set! stats-matrix "WIDTHDEF" "40")
(iup:vbox
;; (iup:label "Run statistics" #:expand "HORIZONTAL")
stats-matrix)))
(define (dcommon:servers-table)
(let* ((tdbdat (tasks:open-db))
(colnum 0)
(rownum 0)
(servers-matrix (iup:matrix #:expand "YES"
#:numcol 7
#:numcol-visible 7
#:numlin-visible 5
))
(colnames (list "Id" "MTver" "Pid" "Host" "Interface:OutPort" "RunTime" "State" "RunId"))
(updater (lambda ()
(let ((servers (tasks:get-all-servers (db:delay-if-busy tdbdat))))
(iup:attribute-set! servers-matrix "NUMLIN" (length servers))
;; (set! colnum 0)
;; (for-each (lambda (colname)
;; ;; (print "colnum: " colnum " colname: " colname)
;; (iup:attribute-set! servers-matrix (conc "0:" colnum) colname)
;; (set! colnum (+ 1 colnum)))
;; colnames)
|
544
545
546
547
548
549
550
|
;; #:modal? #t
;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current
;; ;; #:x 'mouse
;; ;; #:y 'mouse
;; )
))))
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
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
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
|
;; #:modal? #t
;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current
;; ;; #:x 'mouse
;; ;; #:y 'mouse
;; )
))))
;;======================================================================
;; CANVAS STUFF FOR TESTS
;;======================================================================
(define (dcommon:draw-test cnv x y w h name selected)
(let* ((llx x)
(lly y)
(urx (+ x w))
(ury (+ y h)))
(canvas-text! cnv (+ llx 5)(+ lly 5) name) ;; (conc testname " (" xtorig "," ytorig ")"))
(canvas-rectangle! cnv llx urx lly ury)
(if selected (canvas-box! cnv llx (+ llx 5) lly (+ lly 5)))))
(define (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames)
(let* ((scalef (hash-table-ref/default tests-draw-state 'scalef 8))
(test-browse-xoffset (hash-table-ref tests-draw-state 'test-browse-xoffset))
(test-browse-yoffset (hash-table-ref tests-draw-state 'test-browse-yoffset))
(xtorig (+ test-browse-xoffset (* (/ sizex 2) scalef (- 0.5 xadj)))) ;; (- xadj 1))))
(ytorig (+ test-browse-yoffset (* (/ sizey 2) scalef (- yadj 0.5))))
(boxw 90) ;; default, overriden by length estimate below
(boxh 25)
(gapx 20)
(gapy 30)
(tests-hash (hash-table-ref tests-draw-state 'tests-info))
(selected-tests (hash-table-ref tests-draw-state 'selected-tests )))
(hash-table-set! tests-draw-state 'xtorig xtorig)
(hash-table-set! tests-draw-state 'ytorig ytorig)
(let ((longest-str (if (null? sorted-testnames) " " (car (sort sorted-testnames (lambda (a b)(>= (string-length a)(string-length b))))))))
(let-values (((x-max y-max) (canvas-text-size cnv longest-str)))
(if (> x-max boxw)(set! boxw (+ 10 x-max)))))
;; (print "sizex: " sizex " sizey: " sizey " font: " (canvas-font cnv) " originx: " originx " originy: " originy " xtorig: " xtorig " ytorig: " ytorig " xadj: " xadj " yadj: " yadj)
(if (not (null? sorted-testnames))
(let loop ((hed (car (reverse sorted-testnames)))
(tal (cdr (reverse sorted-testnames)))
(llx xtorig)
(lly ytorig)
(urx (+ xtorig boxw))
(ury (+ ytorig boxh)))
; (print "hed " hed " llx " llx " lly " lly " urx " urx " ury " ury)
(dcommon:draw-test cnv llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f))
;; data used by mouse click calc. keep the wacky order for now.
(hash-table-set! tests-hash hed (list llx urx (- sizey ury)(- sizey lly) lly boxw boxh))
;; (list llx lly boxw boxh)) ;; NB// Swap ury and lly
(if (not (null? tal))
;; leave a column of space to the right to list items
(let ((have-room
(if #t ;; put "auto" here where some form of auto rearanging can be done
(> (* 3 (+ boxw gapx)) (- urx xtorig))
(< urx (- sizex boxw gapx boxw))))) ;; is there room for another column?
(loop (car tal)
(cdr tal)
(if have-room (+ llx boxw gapx) xtorig) ;; have room,
(if have-room lly (+ lly boxh gapy))
(if have-room (+ urx boxw gapx) (+ xtorig boxw))
(if have-room ury (+ ury boxh gapy)))))))))
(define (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames)
(let* ((scalef (hash-table-ref/default tests-draw-state 'scalef 8))
(test-browse-xoffset (hash-table-ref tests-draw-state 'test-browse-xoffset))
(test-browse-yoffset (hash-table-ref tests-draw-state 'test-browse-yoffset))
(xtorig (+ test-browse-xoffset (* (/ sizex 2) scalef (- 0.5 xadj)))) ;; (- xadj 1))))
(ytorig (+ test-browse-yoffset (* (/ sizey 2) scalef (- yadj 0.5))))
(xdelta (- (hash-table-ref tests-draw-state 'xtorig) xtorig))
(ydelta (- (hash-table-ref tests-draw-state 'ytorig) ytorig))
(tests-hash (hash-table-ref tests-draw-state 'tests-info))
(selected-tests (hash-table-ref tests-draw-state 'selected-tests )))
(hash-table-set! tests-draw-state 'xtorig xtorig)
(hash-table-set! tests-draw-state 'ytorig ytorig)
(if (not (null? sorted-testnames))
(let loop ((hed (car (reverse sorted-testnames)))
(tal (cdr (reverse sorted-testnames))))
(let* ((tvals (hash-table-ref tests-hash hed))
(llx (+ xdelta (list-ref tvals 0)))
(lly (+ ydelta (list-ref tvals 4)))
(boxw (list-ref tvals 5))
(boxh (list-ref tvals 6))
(urx (+ llx boxw))
(ury (+ lly boxh)))
(dcommon:draw-test cnv llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f))
(hash-table-set! tests-hash hed (list llx urx (- sizey ury)(- sizey lly) lly boxw boxh))
(if (not (null? tal))
;; leave a column of space to the right to list items
(loop (car tal)
(cdr tal))))))))
;;======================================================================
;; S T E P S
;;======================================================================
;; CHECK - WAS THIS ADDED OR REMOVED? MANUAL MERGE WITH API STUFF!!!
;;
;; get a pretty table to summarize steps
;;
(define (dcommon:process-steps-table steps);; db test-id #!key (work-area #f))
;; (let ((steps (db:get-steps-for-test db test-id work-area: work-area)))
;; organise the steps for better readability
(let ((res (make-hash-table)))
(for-each
(lambda (step)
(debug:print 6 "step=" step)
(let ((record (hash-table-ref/default
res
(tdb:step-get-stepname step)
;; stepname start end status Duration Logfile
(vector (tdb:step-get-stepname step) "" "" "" "" ""))))
(debug:print 6 "record(before) = " record
"\nid: " (tdb:step-get-id step)
"\nstepname: " (tdb:step-get-stepname step)
"\nstate: " (tdb:step-get-state step)
"\nstatus: " (tdb:step-get-status step)
"\ntime: " (tdb:step-get-event_time step))
(case (string->symbol (tdb:step-get-state step))
((start)(vector-set! record 1 (tdb:step-get-event_time step))
(vector-set! record 3 (if (equal? (vector-ref record 3) "")
(tdb:step-get-status step)))
(if (> (string-length (tdb:step-get-logfile step))
0)
(vector-set! record 5 (tdb:step-get-logfile step))))
((end)
(vector-set! record 2 (any->number (tdb:step-get-event_time step)))
(vector-set! record 3 (tdb:step-get-status step))
(vector-set! record 4 (let ((startt (any->number (vector-ref record 1)))
(endt (any->number (vector-ref record 2))))
(debug:print 4 "record[1]=" (vector-ref record 1)
", startt=" startt ", endt=" endt
", get-status: " (tdb:step-get-status step))
(if (and (number? startt)(number? endt))
(seconds->hr-min-sec (- endt startt)) "-1")))
(if (> (string-length (tdb:step-get-logfile step))
0)
(vector-set! record 5 (tdb:step-get-logfile step))))
(else
(vector-set! record 2 (tdb:step-get-state step))
(vector-set! record 3 (tdb:step-get-status step))
(vector-set! record 4 (tdb:step-get-event_time step))))
(hash-table-set! res (tdb:step-get-stepname step) record)
(debug:print 6 "record(after) = " record
"\nid: " (tdb:step-get-id step)
"\nstepname: " (tdb:step-get-stepname step)
"\nstate: " (tdb:step-get-state step)
"\nstatus: " (tdb:step-get-status step)
"\ntime: " (tdb:step-get-event_time step))))
;; (else (vector-set! record 1 (tdb:step-get-event_time step)))
(sort steps (lambda (a b)
(cond
((< (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t)
((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b))
(< (tdb:step-get-id a) (tdb:step-get-id b)))
(else #f)))))
res))
(define (dcommon:get-compressed-steps dbstruct run-id test-id)
(let* ((steps-data (db:get-steps-for-test dbstruct run-id test-id))
(comprsteps (dcommon:process-steps-table steps-data))) ;; (open-run-close db:get-steps-table #f test-id work-area: work-area)))
(map (lambda (x)
;; take advantage of the \n on time->string
(vector
(vector-ref x 0)
(let ((s (vector-ref x 1)))
(if (number? s)(seconds->time-string s) s))
(let ((s (vector-ref x 2)))
(if (number? s)(seconds->time-string s) s))
(vector-ref x 3) ;; status
(vector-ref x 4)
(vector-ref x 5))) ;; time delta
(sort (hash-table-values comprsteps)
(lambda (a b)
(let ((time-a (vector-ref a 1))
(time-b (vector-ref b 1)))
(if (and (number? time-a)(number? time-b))
(if (< time-a time-b)
#t
(if (eq? time-a time-b)
(string<? (conc (vector-ref a 2))
(conc (vector-ref b 2)))
#f))
(string<? (conc time-a)(conc time-b)))))))))
(define (dcommon:populate-steps teststeps steps-matrix)
(let ((max-row 0))
(if (null? teststeps)
(iup:attribute-set! steps-matrix "CLEARVALUE" "CONTENTS")
(let loop ((hed (car teststeps))
(tal (cdr teststeps))
(rownum 1)
(colnum 1))
(if (> rownum max-row)(set! max-row rownum))
(let ((val (vector-ref hed (- colnum 1)))
(mtrx-rc (conc rownum ":" colnum)))
(iup:attribute-set! steps-matrix mtrx-rc (if val (conc val) ""))
(if (< colnum 6)
(loop hed tal rownum (+ colnum 1))
(if (not (null? tal))
(loop (car tal)(cdr tal)(+ rownum 1) 1))))))
(if (> max-row 0)
(begin
;; we are going to speculatively clear rows until we find a row that is already cleared
(let loop ((rownum (+ max-row 1))
(colnum 0)
(deleted #f))
;; (debug:print-info 0 "cleaning " rownum ":" colnum)
(let* ((next-row (if (eq? colnum 6) (+ rownum 1) rownum))
(next-col (if (eq? colnum 6) 1 (+ colnum 1)))
(mtrx-rc (conc rownum ":" colnum))
(curr-val (iup:attribute steps-matrix mtrx-rc)))
;; (debug:print-info 0 "cleaning " rownum ":" colnum " currval= " curr-val)
(if (and (string? curr-val)
(not (equal? curr-val "")))
(begin
(iup:attribute-set! steps-matrix mtrx-rc "")
(loop next-row next-col #t))
(if (eq? colnum 6) ;; not done, didn't get a full blank row
(if deleted (loop next-row next-col #f)) ;; exit on this not met
(loop next-row next-col deleted)))))
(iup:attribute-set! steps-matrix "REDRAW" "ALL")))))
|