︙ | | | ︙ | |
118
119
120
121
122
123
124
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
152
153
154
155
156
157
158
|
please-update: #t
update-mutex: (make-mutex)
updaters: (make-hash-table)
updating: #f
hide-not-hide-tabs: #f
))
(define (dboard:common-get-tabdat commondat #!key (tab-num #f))
(hash-table-ref/default
(dboard:commondat-tabdats commondat)
(or tab-num (dboard:commondat-curr-tab-num commondat))
#f))
(define (dboard:common-set-tabdat! commondat tabnum tabdat)
(hash-table-set!
(dboard:commondat-tabdats commondat)
tabnum
tabdat))
;; gets and calls updater based on curr-tab-num
(define (dboard:common-run-curr-updaters commondat #!key (tab-num #f))
(if (dboard:common-get-tabdat commondat tab-num: tab-num) ;; only update if there is a tabdat
(let* ((tnum (or tab-num (dboard:commondat-curr-tab-num commondat)))
(updaters (hash-table-ref/default (dboard:commondat-updaters commondat)
tnum
'())))
(debug:print 4 *default-log-port* "Found these updaters: " updaters " for tab-num: " tnum)
(for-each
(lambda (updater)
;; (debug:print 3 *default-log-port* "Running " updater)
(updater))
updaters))))
;; if tab-num passed in then use it, otherwise look in commondat at curr-tab-num
;;
(define (dboard:commondat-add-updater commondat updater #!key (tab-num #f))
(let* ((tnum (or tab-num
(dboard:commondat-curr-tab-num commondat)))
(curr-updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '())))
(hash-table-set! (dboard:commondat-updaters commondat)
tnum
|
>
>
|
>
>
|
|
>
|
118
119
120
121
122
123
124
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
152
153
154
155
156
157
158
159
160
161
162
163
|
please-update: #t
update-mutex: (make-mutex)
updaters: (make-hash-table)
updating: #f
hide-not-hide-tabs: #f
))
;; RA => returns the tabdat stored at hashkey passed in commondat-tabdats table (e.g. 0 gives summary)
;;
(define (dboard:common-get-tabdat commondat #!key (tab-num #f))
(hash-table-ref/default
(dboard:commondat-tabdats commondat)
(or tab-num (dboard:commondat-curr-tab-num commondat)) ;; tab-num value is curr-tab-num value in passed commondat
#f))
;; RA => sets the tabdat passed to the hashkey at commondat:tabdats hash table
;;
(define (dboard:common-set-tabdat! commondat tabnum tabdat)
(hash-table-set!
(dboard:commondat-tabdats commondat)
tabnum
tabdat))
;; gets and calls updater list based on curr-tab-num
(define (dboard:common-run-curr-updaters commondat #!key (tab-num #f))
(if (dboard:common-get-tabdat commondat tab-num: tab-num) ;; only update if there is a tabdat
(let* ((tnum (or tab-num (dboard:commondat-curr-tab-num commondat)))
(updaters (hash-table-ref/default (dboard:commondat-updaters commondat)
tnum
'())))
(debug:print 4 *default-log-port* "Found these updaters: " updaters " for tab-num: " tnum)
(for-each ;; perform the function calls for the complete updaters list
(lambda (updater)
;; (debug:print 3 *default-log-port* "Running " updater)
(updater))
updaters))))
;; if tab-num passed in then use it, otherwise look in commondat at curr-tab-num
;; adds the updater passed in the updaters list at that hashkey
;;
(define (dboard:commondat-add-updater commondat updater #!key (tab-num #f))
(let* ((tnum (or tab-num
(dboard:commondat-curr-tab-num commondat)))
(curr-updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '())))
(hash-table-set! (dboard:commondat-updaters commondat)
tnum
|
︙ | | | ︙ | |
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
|
(take-right (dboard:tabdat-allruns tabdat) numruns)
(pad-list (dboard:tabdat-allruns tabdat) numruns)))
(lftcol (dboard:uidat-get-lftcol uidat))
(tableheader (dboard:uidat-get-header uidat))
(table (dboard:uidat-get-runsvec uidat))
(coln 0)
(all-test-names (make-hash-table)))
;; create a concise list of test names
;;
(for-each
(lambda (rundat)
(if rundat
(let* ((testdats (dboard:rundat-tests rundat))
(testnames (map test:test-get-fullname (hash-table-values testdats))))
|
<
|
785
786
787
788
789
790
791
792
793
794
795
796
797
798
|
(take-right (dboard:tabdat-allruns tabdat) numruns)
(pad-list (dboard:tabdat-allruns tabdat) numruns)))
(lftcol (dboard:uidat-get-lftcol uidat))
(tableheader (dboard:uidat-get-header uidat))
(table (dboard:uidat-get-runsvec uidat))
(coln 0)
(all-test-names (make-hash-table)))
;; create a concise list of test names
;;
(for-each
(lambda (rundat)
(if rundat
(let* ((testdats (dboard:rundat-tests rundat))
(testnames (map test:test-get-fullname (hash-table-values testdats))))
|
︙ | | | ︙ | |
882
883
884
885
886
887
888
889
890
891
892
893
894
895
|
(color (car (gutils:get-color-for-state-status teststate teststatus)))
(curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR"))
(curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE")))
(if (not (equal? curr-color color))
(iup:attribute-set! button "BGCOLOR" color))
(if (not (equal? curr-title buttontxt))
(iup:attribute-set! button "TITLE" buttontxt))
(vector-set! buttondat 0 run-id)
(vector-set! buttondat 1 color)
(vector-set! buttondat 2 buttontxt)
(vector-set! buttondat 3 testdat)
(vector-set! buttondat 4 run-key)))
(set! rown (+ rown 1))))
(dboard:tabdat-all-test-names tabdat)))
|
>
|
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
|
(color (car (gutils:get-color-for-state-status teststate teststatus)))
(curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR"))
(curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE")))
(if (not (equal? curr-color color))
(iup:attribute-set! button "BGCOLOR" color))
(if (not (equal? curr-title buttontxt))
(iup:attribute-set! button "TITLE" buttontxt))
;;(print "RA => testdat " testdat " teststate " teststate " teststatus " teststatus " buttondat " buttondat " curr-color " curr-color " curr-title " curr-title "buttontxt" buttontxt " title " curr-title )
(vector-set! buttondat 0 run-id)
(vector-set! buttondat 1 color)
(vector-set! buttondat 2 buttontxt)
(vector-set! buttondat 3 testdat)
(vector-set! buttondat 4 run-key)))
(set! rown (+ rown 1))))
(dboard:tabdat-all-test-names tabdat)))
|
︙ | | | ︙ | |
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
|
(iup:menu-item
"Clean Complete Run"
#:action
(lambda (obj)
(common:run-a-command
(conc "megatest -remove-runs -target " target
" -runname " runname
" -testpatt % "))))))
(iup:menu-item
"Test"
(iup:menu
(iup:menu-item
(conc "Rerun " test-name)
#:action
(lambda (obj)
|
|
>
>
>
>
>
>
>
>
>
|
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
|
(iup:menu-item
"Clean Complete Run"
#:action
(lambda (obj)
(common:run-a-command
(conc "megatest -remove-runs -target " target
" -runname " runname
" -testpatt % "))))
(iup:menu-item ;; RADT => itemize this run lists before merging with v1.61
"Kill Complete Run"
#:action
(lambda (obj)
(common:run-a-command
(conc "megatest -set-state-status KILLREQ,n/a -target " target
" -runname " runname
" -testpatt % "
" -state RUNNING,REMOTEHOSTSTART,LAUNCHED"))))))
(iup:menu-item
"Test"
(iup:menu
(iup:menu-item
(conc "Rerun " test-name)
#:action
(lambda (obj)
|
︙ | | | ︙ | |
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
|
" " tconfig " &")))
(system cmd))))
))))
(define (make-dashboard-buttons commondat) ;; runs-sum-dat new-view-dat)
(let* ((stats-dat (dboard:tabdat-make-data))
(runs-dat (dboard:tabdat-make-data))
(onerun-dat (dboard:tabdat-make-data))
(runcontrols-dat (dboard:tabdat-make-data))
(runtimes-dat (dboard:tabdat-make-data))
(nruns (dboard:tabdat-numruns runs-dat))
(ntests (dboard:tabdat-num-tests runs-dat))
(keynames (dboard:tabdat-dbkeys runs-dat))
(nkeys (length keynames))
(runsvec (make-vector nruns))
|
|
|
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
|
" " tconfig " &")))
(system cmd))))
))))
(define (make-dashboard-buttons commondat) ;; runs-sum-dat new-view-dat)
(let* ((stats-dat (dboard:tabdat-make-data))
(runs-dat (dboard:tabdat-make-data))
(onerun-dat (dboard:tabdat-make-data)) ;; name for run-summary structure
(runcontrols-dat (dboard:tabdat-make-data))
(runtimes-dat (dboard:tabdat-make-data))
(nruns (dboard:tabdat-numruns runs-dat))
(ntests (dboard:tabdat-num-tests runs-dat))
(keynames (dboard:tabdat-dbkeys runs-dat))
(nkeys (length keynames))
(runsvec (make-vector nruns))
|
︙ | | | ︙ | |
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
|
recalc))
;; point inside line
;;
(define-inline (dashboard:px-between px lx1 lx2)
(and (< lx1 px)(> lx2 px)))
(define (dashboard:summary-tab-updater commondat tab-num)
(if dashboard:update-summary-tab (dashboard:update-summary-tab)))
;; can a bar be placed in row "rownum" covering x1 to x2 without overlapping with existing
;; bars? Use num-rows to check that a block will fit from rownum to (+ rownum num-rows)
;;
(define (dashboard:row-collision rowhash rownum x1 x2 #!key (num-rows #f))
(let ((lastrow (if num-rows (+ rownum num-rows) rownum)))
|
>
>
|
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
|
recalc))
;; point inside line
;;
(define-inline (dashboard:px-between px lx1 lx2)
(and (< lx1 px)(> lx2 px)))
;;Not reference anywhere
;;
(define (dashboard:summary-tab-updater commondat tab-num)
(if dashboard:update-summary-tab (dashboard:update-summary-tab)))
;; can a bar be placed in row "rownum" covering x1 to x2 without overlapping with existing
;; bars? Use num-rows to check that a block will fit from rownum to (+ rownum num-rows)
;;
(define (dashboard:row-collision rowhash rownum x1 x2 #!key (num-rows #f))
(let ((lastrow (if num-rows (+ rownum num-rows) rownum)))
|
︙ | | | ︙ | |
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
|
(if (dboard:tabdat-layout-update-ok tabdat)
(runloop (car runtal)(cdr runtal) (+ run-num 1) newdoneruns)
(escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat)
))))))))) ;; new-run-start-row
)))
(debug:print 2 *default-log-port* "no tabdat for run-times-tab-updater"))))
(define (dashboard:runs-tab-updater commondat tab-num)
(debug:catch-and-dump
(lambda ()
(let* ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))
(dbkeys (dboard:tabdat-dbkeys tabdat)))
(update-rundat tabdat
(hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%")
(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* ((dbkeys (dboard:tabdat-dbkeys tabdat)))
;; (print "dbkeys: " dbkeys)
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
|
(if (dboard:tabdat-layout-update-ok tabdat)
(runloop (car runtal)(cdr runtal) (+ run-num 1) newdoneruns)
(escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat)
))))))))) ;; new-run-start-row
)))
(debug:print 2 *default-log-port* "no tabdat for run-times-tab-updater"))))
(define (tabdat-values tabdat)
(let ((allruns (dboard:tabdat-allruns tabdat))
(allruns-by-id (dboard:tabdat-allruns-by-id tabdat))
(done-runs (dboard:tabdat-done-runs tabdat))
(not-done-runs (dboard:tabdat-not-done-runs tabdat))
(header (dboard:tabdat-header tabdat))
(keys (dboard:tabdat-keys tabdat))
(numruns (dboard:tabdat-numruns tabdat))
(tot-runs (dboard:tabdat-tot-runs tabdat))
(last-data-update (dboard:tabdat-last-data-update tabdat))
(runs-mutex (dboard:tabdat-runs-mutex tabdat))
(run-update-times (dboard:tabdat-run-update-times tabdat))
(last-test-dat (dboard:tabdat-last-test-dat tabdat))
(run-db-paths (dboard:tabdat-run-db-paths tabdat))
(buttondat (dboard:tabdat-buttondat tabdat))
(item-test-names (dboard:tabdat-item-test-names tabdat))
(run-keys (dboard:tabdat-run-keys tabdat))
(start-run-offset (dboard:tabdat-start-run-offset tabdat))
(start-test-offset (dboard:tabdat-start-test-offset tabdat))
(runs-btn-height (dboard:tabdat-runs-btn-height tabdat))
(all-test-names (dboard:tabdat-all-test-names tabdat))
(cnv (dboard:tabdat-cnv tabdat))
(command (dboard:tabdat-command tabdat))
(run-name (dboard:tabdat-run-name tabdat))
(states (dboard:tabdat-states tabdat))
(statuses (dboard:tabdat-statuses tabdat))
(curr-run-id (dboard:tabdat-curr-run-id tabdat))
(curr-test-ids (dboard:tabdat-curr-test-ids tabdat))
(state-ignore-hash (dboard:tabdat-state-ignore-hash tabdat))
(test-patts (dboard:tabdat-test-patts tabdat))
(target (dboard:tabdat-target tabdat))
(dbdir (dboard:tabdat-dbdir tabdat))
(monitor-db-path (dboard:tabdat-monitor-db-path tabdat))
(path-run-ids (dboard:tabdat-path-run-ids tabdat)))
(print "allruns is : " allruns)
(print "allruns-by-id is : " allruns-by-id)
(print "done-runs is : " done-runs)
(print "not-done-runs is : " not-done-runs)
(print "header is : " header )
(print "keys is : " keys)
(print "numruns is : " numruns)
(print "tot-runs is : " tot-runs)
(print "last-data-update is : " last-data-update)
(print "runs-mutex is : " runs-mutex)
(print "run-update-times is : " run-update-times)
(print "last-test-dat is : " last-test-dat)
(print "run-db-paths is : " run-db-paths)
(print "buttondat is : " buttondat)
(print "item-test-names is : " item-test-names)
(print "run-keys is : " run-keys)
(print "start-run-offset is : " start-run-offset)
(print "start-test-offset is : " start-test-offset)
(print "runs-btn-height is : " runs-btn-height)
(print "all-test-names is : " all-test-names)
(print "cnv is : " cnv)
(print "command is : " command)
(print "run-name is : " run-name)
(print "states is : " states)
(print "statuses is : " statuses)
(print "curr-run-id is : " curr-run-id)
(print "curr-test-ids is : " curr-test-ids)
(print "state-ignore-hash is : " state-ignore-hash)
(print "test-patts is : " test-patts)
(print "target is : " target)
(print "dbdir is : " dbdir)
(print "monitor-db-path is : " monitor-db-path)
(print "path-run-ids is : " path-run-ids)))
(define (dashboard:runs-tab-updater commondat tab-num)
(debug:catch-and-dump
(lambda ()
(let* ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))
(dbkeys (dboard:tabdat-dbkeys tabdat)))
;;(print "RA => calling runs-tab-updater with commondat " commondat " tab-num " tab-num)
(tabdat-values tabdat) ;;RA added
(update-rundat tabdat
(hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%")
(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* ((dbkeys (dboard:tabdat-dbkeys tabdat)))
;; (print "dbkeys: " dbkeys)
|
︙ | | | ︙ | |
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
|
(let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f)))
(if val (set! res (cons (list key val) res))))))
dbkeys)
res))))
;; (debug:print 0 *default-log-port* "fres: " fres)
fres)))
(let ((uidat (dboard:commondat-uidat commondat)))
(update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat)))
))
"dashboard:runs-tab-updater"))
;; ((2)
;; (dashboard:update-run-summary-tab))
;; ((3)
|
>
|
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
|
(let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f)))
(if val (set! res (cons (list key val) res))))))
dbkeys)
res))))
;; (debug:print 0 *default-log-port* "fres: " fres)
fres)))
(let ((uidat (dboard:commondat-uidat commondat)))
;;(print "RA => Calling update-buttons with tabdat : " tabdat " uidat " uidat)
(update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat)))
))
"dashboard:runs-tab-updater"))
;; ((2)
;; (dashboard:update-run-summary-tab))
;; ((3)
|
︙ | | | ︙ | |
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
|
(define (main)
(if (not (args:get-arg "-skip-version-check"))(common:exit-on-version-changed))
(let* ((commondat (dboard:commondat-make)))
;; Move this stuff to db.scm? I'm not sure that is the right thing to do...
(cond
((args:get-arg "-test") ;; run-id,test-id
(let* ((dat (let ((d (map string->number (string-split (args:get-arg "-test") ","))))
(if (> (length d) 1)
d
(list #f #f))))
(run-id (car dat))
(test-id (cadr dat)))
(if (and (number? run-id)
(number? test-id)
(>= test-id 0))
(examine-test run-id test-id)
(begin
(debug:print 3 *default-log-port* "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test"))
(exit 1)))))
;; ((args:get-arg "-guimonitor")
;; (gui-monitor (dboard:tabdat-dblocal tabdat)))
(else
(dboard:commondat-uidat-set! commondat (make-dashboard-buttons commondat)) ;; (dboard:tabdat-dblocal data)
|
|
|
|
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
|
(define (main)
(if (not (args:get-arg "-skip-version-check"))(common:exit-on-version-changed))
(let* ((commondat (dboard:commondat-make)))
;; Move this stuff to db.scm? I'm not sure that is the right thing to do...
(cond
((args:get-arg "-test") ;; run-id,test-id
(let* ((dat (let ((d (map string->number (string-split (args:get-arg "-test") ",")))) ;; RADT couldn't find string->number, though it works
(if (> (length d) 1)
d
(list #f #f))))
(run-id (car dat))
(test-id (cadr dat)))
(if (and (number? run-id)
(number? test-id)
(>= test-id 0))
(dashboard-tests:examine-test run-id test-id)
(begin
(debug:print 3 *default-log-port* "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test"))
(exit 1)))))
;; ((args:get-arg "-guimonitor")
;; (gui-monitor (dboard:tabdat-dblocal tabdat)))
(else
(dboard:commondat-uidat-set! commondat (make-dashboard-buttons commondat)) ;; (dboard:tabdat-dblocal data)
|
︙ | | | ︙ | |