Overview
Comment: | Partial migration of *data* to a defstruct |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | v1.61 |
Files: | files | file ages | folders |
SHA1: |
75c0c4c195804f41c2dfd33ea3340ad0 |
User & Date: | mrwellan on 2016-07-01 08:41:26 |
Other Links: | branch diff | manifest | tags |
Context
2016-07-01
| ||
15:07 | Fixed silly bug check-in: 56b8241a02 user: mrwellan tags: v1.61 | |
14:59 | dashboard refactor check-in: d0aed42247 user: mrwellan tags: dashboard-refactor | |
08:41 | Partial migration of *data* to a defstruct check-in: 75c0c4c195 user: mrwellan tags: v1.61 | |
2016-06-30
| ||
23:49 | Made the LH column controls independent for each tab check-in: c4ce2f7187 user: matt tags: v1.61 | |
Changes
Modified dashboard.scm from [d24b4d7b16] to [6476fc96b8].
︙ | ︙ | |||
803 804 805 806 807 808 809 | (if (eq? tstate 0) (hash-table-delete! alltgls item) (hash-table-set! alltgls item #t)) (let ((all (hash-table-keys alltgls))) (proc all))))) items)))) | | | | | | | | | | 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 | (if (eq? tstate 0) (hash-table-delete! alltgls item) (hash-table-set! alltgls item #t)) (let ((all (hash-table-keys alltgls))) (proc all))))) items)))) ;; Extract the various bits of data from data and create the command line equivalent that will be displayed ;; (define (dashboard:update-run-command data) (let* ((cmd-tb (dboard:data-command-tb data)) (cmd (dboard:data-command data)) (test-patt (let ((tp (dboard:data-test-patts data))) (if (equal? tp "") "%" tp))) (states (dboard:data-states data)) (statuses (dboard:data-statuses data)) (target (let ((targ-list (dboard:data-target data))) (if targ-list (string-intersperse targ-list "/") "no-target-selected"))) (run-name (dboard:data-run-name data)) (states-str (if (or (not states) (null? states)) "" (conc " -state " (string-intersperse states ",")))) (statuses-str (if (or (not statuses) (null? statuses)) "" |
︙ | ︙ | |||
893 894 895 896 897 898 899 | (runlogs (make-hash-table)) (key-listboxes #f) ;; (updater-for-runs #f) (update-keyvals (lambda () (let ((targ (map (lambda (x) (iup:attribute x "VALUE")) (car (dashboard:update-target-selector key-listboxes)))) | | | | | | | | | 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 | (runlogs (make-hash-table)) (key-listboxes #f) ;; (updater-for-runs #f) (update-keyvals (lambda () (let ((targ (map (lambda (x) (iup:attribute x "VALUE")) (car (dashboard:update-target-selector key-listboxes)))) (curr-runname (dboard:data-run-name data))) (dboard:data-target-set! data targ) (if (dboard:data-updater-for-runs data) ((dboard:data-updater-for-runs data))) (if (or (not (equal? curr-runname (dboard:data-run-name data))) (equal? (dboard:data-run-name data) "")) (dboard:data-run-name-set! data curr-runname)) (dashboard:update-run-command data)))) (tests-draw-state (make-hash-table)) ;; use for keeping state of the test canvas (test-patterns-textbox #f)) (hash-table-set! tests-draw-state 'first-time #t) ;; (hash-table-set! tests-draw-state 'scalef 1) (tests:get-full-data test-names test-records '() all-tests-registry) (set! sorted-testnames (tests:sort-by-priority-and-waiton test-records)) |
︙ | ︙ | |||
932 933 934 935 936 937 938 | (dcommon:command-tests-tasks-canvas data test-records sorted-testnames tests-draw-state)) ;;(iup:frame ;; #:title "Logs" ;; To be replaced with tabs ;; (let ((logs-tb (iup:textbox #:expand "YES" ;; #:multiline "YES"))) | | | 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 | (dcommon:command-tests-tasks-canvas data test-records sorted-testnames tests-draw-state)) ;;(iup:frame ;; #:title "Logs" ;; To be replaced with tabs ;; (let ((logs-tb (iup:textbox #:expand "YES" ;; #:multiline "YES"))) ;; (dboard:data-logs-textbox-set! data logs-tb) ;; logs-tb)) ))) ;;====================================================================== ;; R U N C O N T R O L S ;;====================================================================== ;; |
︙ | ︙ | |||
958 959 960 961 962 963 964 | (runlogs (make-hash-table)) (key-listboxes #f) (updater-for-runs #f) (update-keyvals (lambda () (let ((targ (map (lambda (x) (iup:attribute x "VALUE")) (car (dashboard:update-target-selector key-listboxes)))) | | | | | | | 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 | (runlogs (make-hash-table)) (key-listboxes #f) (updater-for-runs #f) (update-keyvals (lambda () (let ((targ (map (lambda (x) (iup:attribute x "VALUE")) (car (dashboard:update-target-selector key-listboxes)))) (curr-runname (dboard:data-run-name data))) (dboard:data-target-set! data targ) (if updater-for-runs (updater-for-runs)) (if (or (not (equal? curr-runname (dboard:data-run-name data))) (equal? (dboard:data-run-name data) "")) (dboard:data-run-name-set! data curr-runname)) (dashboard:update-run-command data)))) (tests-draw-state (make-hash-table)) ;; use for keeping state of the test canvas (test-patterns-textbox #f)) (hash-table-set! tests-draw-state 'first-time #t) ;; (hash-table-set! tests-draw-state 'scalef 1) (tests:get-full-data test-names test-records '() all-tests-registry) (set! sorted-testnames (tests:sort-by-priority-and-waiton test-records)) |
︙ | ︙ | |||
995 996 997 998 999 1000 1001 | (dcommon:command-tests-tasks-canvas data test-records sorted-testnames tests-draw-state)) ;; (iup:frame ;; #:title "Logs" ;; To be replaced with tabs ;; (let ((logs-tb (iup:textbox #:expand "YES" ;; #:multiline "YES"))) | | | 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 | (dcommon:command-tests-tasks-canvas data test-records sorted-testnames tests-draw-state)) ;; (iup:frame ;; #:title "Logs" ;; To be replaced with tabs ;; (let ((logs-tb (iup:textbox #:expand "YES" ;; #:multiline "YES"))) ;; (dboard:data-logs-textbox-set! data logs-tb) ;; logs-tb)) ))) ;;====================================================================== ;; S U M M A R Y ;;====================================================================== ;; |
︙ | ︙ | |||
1164 1165 1166 1167 1168 1169 1170 | (run-name (db:get-value-by-header run-record runs-header "runname")) (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) (run-path (append key-vals (list run-name))) (existing (tree:find-node tb run-path))) (if (not (hash-table-ref/default (d:data-path-run-ids ddata) run-path #f)) (begin (hash-table-set! (d:data-run-keys ddata) run-id run-path) | | | 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 | (run-name (db:get-value-by-header run-record runs-header "runname")) (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) (run-path (append key-vals (list run-name))) (existing (tree:find-node tb run-path))) (if (not (hash-table-ref/default (d:data-path-run-ids ddata) run-path #f)) (begin (hash-table-set! (d:data-run-keys ddata) run-id run-path) ;; (iup:attribute-set! (dboard:data-runs-matrix data) ;; (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 (tree:add-node tb "Runs" run-path ;; (append key-vals (list run-name)) userdata: (conc "run-id: " run-id)) (hash-table-set! (d:data-path-run-ids ddata) run-path run-id) ;; (set! colnum (+ colnum 1)) |
︙ | ︙ | |||
1310 1311 1312 1313 1314 1315 1316 | (run-name (db:get-value-by-header run-record runs-header "runname")) (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) (run-path (append key-vals (list run-name))) (existing (tree:find-node tb run-path))) (if (not (hash-table-ref/default (d:data-path-run-ids ddata) run-path #f)) (begin (hash-table-set! (d:data-run-keys ddata) run-id run-path) | | | 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 | (run-name (db:get-value-by-header run-record runs-header "runname")) (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) (run-path (append key-vals (list run-name))) (existing (tree:find-node tb run-path))) (if (not (hash-table-ref/default (d:data-path-run-ids ddata) run-path #f)) (begin (hash-table-set! (d:data-run-keys ddata) run-id run-path) ;; (iup:attribute-set! (dboard:data-runs-matrix data) ;; (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 (tree:add-node tb "Runs" run-path ;; (append key-vals (list run-name)) userdata: (conc "run-id: " run-id)) (hash-table-set! (d:data-path-run-ids ddata) run-path run-id) ;; (set! colnum (+ colnum 1)) |
︙ | ︙ |
Modified dcommon.scm from [3faddec3ed] to [c1de7ba151].
︙ | ︙ | |||
36 37 38 39 40 41 42 | ;;====================================================================== ;; ;; A single data structure for all the data used in a dashboard. ;; Share this structure between newdashboard and dashboard with the ;; intent of converging on a single app. ;; (define *data* (make-vector 25 #f)) | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 105 106 107 108 109 110 111 112 113 114 115 116 117 | ;;====================================================================== ;; ;; A single data structure for all the data used in a dashboard. ;; Share this structure between newdashboard and dashboard with the ;; intent of converging on a single app. ;; (define *data* (make-vector 25 #f)) (define (dboard:data-runs vec) (vector-ref vec 0)) (define (dboard:data-tests vec) (vector-ref vec 1)) (define (dboard:data-runs-matrix vec) (vector-ref vec 2)) (define (dboard:data-tests-tree vec) (vector-ref vec 3)) (define (dboard:data-run-keys vec) (vector-ref vec 4)) (define (dboard:data-curr-test-ids vec) (vector-ref vec 5)) ;; (define (dboard:data-test-details vec) (vector-ref vec 6)) (define (dboard:data-path-test-ids vec) (vector-ref vec 7)) (define (dboard:data-updaters vec) (vector-ref vec 8)) (define (dboard:data-path-run-ids vec) (vector-ref vec 9)) (define (dboard:data-curr-run-id vec) (vector-ref vec 10)) (define (dboard:data-runs-tree vec) (vector-ref vec 11)) ;; For test-patts convert #f to "" (define (dboard:data-test-patts vec) (let ((val (vector-ref vec 12)))(if val val ""))) (define (dboard:data-states vec) (vector-ref vec 13)) (define (dboard:data-statuses vec) (vector-ref vec 14)) (define (dboard:data-logs-textbox vec val)(vector-ref vec 15)) (define (dboard:data-command vec) (vector-ref vec 16)) (define (dboard:data-command-tb vec) (vector-ref vec 17)) (define (dboard:data-target vec) (vector-ref vec 18)) (define (dboard:data-target-string vec) (let ((targ (dboard:data-target vec))) (if (list? targ)(string-intersperse targ "/") "no-target-specified"))) (define (dboard:data-run-name vec) (vector-ref vec 19)) (define (dboard:data-runs-listbox vec) (vector-ref vec 20)) (define (dboard:data-updater-for-runs vec) (vector-ref vec 21)) (defstruct d:data runs tests runs-matrix tests-tree run-keys curr-test-ids updaters path-run-ids curr-run-id runs-tree test-patts states statuses logs-textbox command command-tb target run-name runs-listbox) (define (dboard:data-runs-set! vec val)(vector-set! vec 0 val)) (define (dboard:data-tests-set! vec val)(vector-set! vec 1 val)) (define (dboard:data-runs-matrix-set! vec val)(vector-set! vec 2 val)) (define (dboard:data-tests-tree-set! vec val)(vector-set! vec 3 val)) (define (dboard:data-run-keys-set! vec val)(vector-set! vec 4 val)) (define (dboard:data-curr-test-ids-set! vec val)(vector-set! vec 5 val)) ;; (define (dboard:data-test-details-set! vec val)(vector-set! vec 6 val)) (define (dboard:data-path-test-ids-set! vec val)(vector-set! vec 7 val)) (define (dboard:data-updaters-set! vec val)(vector-set! vec 8 val)) (define (dboard:data-path-run-ids-set! vec val)(vector-set! vec 9 val)) (define (dboard:data-curr-run-id-set! vec val)(vector-set! vec 10 val)) (define (dboard:data-runs-tree-set! vec val)(vector-set! vec 11 val)) ;; For test-patts convert "" to #f (define (dboard:data-test-patts-set! vec val) (vector-set! vec 12 (if (equal? val "") #f val))) (define (dboard:data-states-set! vec val)(vector-set! vec 13 val)) (define (dboard:data-statuses-set! vec val)(vector-set! vec 14 val)) (define (dboard:data-logs-textbox-set! vec val)(vector-set! vec 15 val)) (define (dboard:data-command-set! vec val)(vector-set! vec 16 val)) (define (dboard:data-command-tb-set! vec val)(vector-set! vec 17 val)) (define (dboard:data-target-set! vec val)(vector-set! vec 18 val)) (define (dboard:data-run-name-set! vec val)(vector-set! vec 19 val)) (define (dboard:data-runs-listbox-set! vec val)(vector-set! vec 20 val)) (define (dboard:data-updater-for-runs-set! vec val)(vector-set! vec 21 val)) (dboard:data-run-keys-set! *data* (make-hash-table)) ;; List of test ids being viewed in various panels (dboard:data-curr-test-ids-set! *data* (make-hash-table)) ;; Look up test-ids by (key1 key2 ... testname [itempath]) (dboard:data-path-test-ids-set! *data* (make-hash-table)) ;; Look up run-ids by ?? (dboard:data-path-run-ids-set! *data* (make-hash-table)) (define (d:data-init dat) (d:data-run-keys-set! dat (make-hash-table)) (d:data-curr-test-ids-set! dat (make-hash-table)) (d:data-path-run-ids-set! dat (make-hash-table)) dat) |
︙ | ︙ | |||
156 157 158 159 160 161 162 | (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 | | | 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 | (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-curr-test-ids *data*))) ;; run-id is #f in next line to send the query to server 0 (run-changes (synchash:client-get 'db:get-runs get-runs-sig (length keypatts) data #f 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 |
︙ | ︙ | |||
204 205 206 207 208 209 210 | (for-each (lambda (run-id) (let* ((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)) keys)) (run-name (db:get-value-by-header run-record header "runname")) (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) (run-path (append key-vals (list run-name)))) | | | | | | 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 | (for-each (lambda (run-id) (let* ((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)) keys)) (run-name (db:get-value-by-header run-record header "runname")) (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) (run-path (append key-vals (list run-name)))) (hash-table-set! (dboard:data-run-keys *data*) run-id run-path) (iup:attribute-set! (dboard:data-runs-matrix *data*) (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 (tree:add-node (dboard:data-tests-tree *data*) "Runs" (append key-vals (list run-name)) userdata: (conc "run-id: " run-id)) (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* ((run-path (hash-table-ref (dboard:data-run-keys *data*) run-id)) (test-changes (hash-table-ref all-test-changes run-id)) (new-test-dat (car test-changes)) (removed-tests (cadr test-changes)) (tests (sort (map cadr (filter (lambda (testrec) (eq? run-id (db:mintest-get-run_id (cadr testrec)))) new-test-dat)) (lambda (a b) |
︙ | ︙ | |||
256 257 258 259 260 261 262 | (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)))) | | | | | | | | | | 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 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 | (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-tests-tree *data*))) (print "INFONOTE: run-path: " run-path) (tree:add-node (dboard:data-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 *default-log-port* "node-num: " node-num ", color: " color) (iup:attribute-set! tb (conc "COLOR" node-num) color)) (hash-table-set! (dboard:data-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) ;; create the label (iup:attribute-set! (dboard:data-runs-matrix *data*) (conc rownum ":" 0) dispname) )) ;; set the cell text and color ;; (debug:print 2 *default-log-port* "rownum:colnum=" rownum ":" colnum ", state=" status) (iup:attribute-set! (dboard:data-runs-matrix *data*) (conc rownum ":" colnum) (if (member state '("ARCHIVED" "COMPLETED")) status state)) (iup:attribute-set! (dboard:data-runs-matrix *data*) (conc "BGCOLOR" rownum ":" colnum) (car (gutils:get-color-for-state-status state status))) )) tests))) run-ids) (let ((updater (hash-table-ref/default (dboard:data-updaters *data*) window-id #f))) (if updater (updater (hash-table-ref/default data get-details-sig #f)))) (iup:attribute-set! (dboard:data-runs-matrix *data*) "REDRAW" "ALL") ;; (debug:print 2 *default-log-port* "run-changes: " run-changes) ;; (debug:print 2 *default-log-port* "test-changes: " test-changes) (list run-changes all-test-changes))) ;;====================================================================== ;; TESTS DATA ;;====================================================================== |
︙ | ︙ | |||
321 322 323 324 325 326 327 | (status (vector-ref hed 4)) (newitem (list test-name item-path (list test-id state status)))) (if (null? tal) (reverse (cons newitem res)) (loop (car tal)(cdr tal)(cons newitem res))))))) (define (dcommon:examine-xterm run-id test-id) | < | | | | 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 | (status (vector-ref hed 4)) (newitem (list test-name item-path (list test-id state status)))) (if (null? tal) (reverse (cons newitem res)) (loop (car tal)(cdr tal)(cons newitem res))))))) (define (dcommon:examine-xterm run-id test-id) (let* ((testdat (rmt:get-test-info-by-id run-id test-id))) (if (not testdat) (begin (debug:print 2 "ERROR: No test data found for test " test-id ", exiting") (exit 1)) (let* ((rundir (if testdat (db:test-get-rundir testdat) logfile)) (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) (xterm (lambda () (if (directory-exists? rundir) (let* ((shell (if (get-environment-variable "SHELL") (conc "-e " (get-environment-variable "SHELL")) "")) |
︙ | ︙ | |||
922 923 924 925 926 927 928 | (iup:toggle "Server" #:size "40x"))) (let ((tb (iup:textbox #:value "megatest " #:expand "HORIZONTAL" #:readonly "YES" #:font "Courier New, -12" ))) | | | | | | | | | | | | | | 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 | (iup:toggle "Server" #:size "40x"))) (let ((tb (iup:textbox #:value "megatest " #:expand "HORIZONTAL" #:readonly "YES" #:font "Courier New, -12" ))) (dboard:data-command-tb-set! data tb) tb) (iup:button "Execute" #:size "50x" #:action (lambda (obj) (let ((cmd (conc "xterm -geometry 180x20 -e \"" (iup:attribute (dboard:data-command-tb data) "VALUE") ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) (system cmd))))))) (define (dcommon:command-action-selector data) (iup:frame #:title "Set the action to take" (iup:hbox ;; (iup:label "Command to run" #:expand "HORIZONTAL" #:size "70x" #:alignment "LEFT:ACENTER") (let* ((cmds-list '("run" "remove-runs" "set-state-status" "lock-runs" "unlock-runs")) (lb (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES" #:action (lambda (obj val index lbstate) ;; (print obj " " val " " index " " lbstate) (dboard:data-command-set! data val) (dashboard:update-run-command data)))) (default-cmd (car cmds-list))) (iuplistbox-fill-list lb cmds-list selected-item: default-cmd) (dboard:data-command-set! data default-cmd) lb)))) (define (dcommon:command-runname-selector alldat data) (iup:frame #:title "Runname" (let* ((default-run-name (seconds->work-week/day (current-seconds))) (tb (iup:textbox #:expand "HORIZONTAL" #:action (lambda (obj val txt) ;; (print "obj: " obj " val: " val " unk: " unk) (dboard:data-run-name-set! data txt) ;; (iup:attribute obj "VALUE")) (dashboard:update-run-command data)) #:value (or default-run-name (dboard:data-run-name data)))) (lb (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES" #:action (lambda (obj val index lbstate) (if (not (equal? val "")) (begin (iup:attribute-set! tb "VALUE" val) (dboard:data-run-name-set! data val) (dashboard:update-run-command data)))))) (refresh-runs-list (lambda () (let* ((target (dboard:data-target-string data)) (runs-for-targ (if (d:alldat-useserver alldat) (rmt:get-runs-by-patt (d:alldat-keys alldat) "%" target #f #f #f) (db:get-runs-by-patt (d:alldat-dblocal alldat) (d:alldat-keys alldat) "%" target #f #f #f))) (runs-header (vector-ref runs-for-targ 0)) (runs-dat (vector-ref runs-for-targ 1)) (run-names (cons default-run-name (map (lambda (x) (db:get-value-by-header x runs-header "runname")) runs-dat)))) ;; (iup:attribute-set! lb "REMOVEITEM" "ALL") (iuplistbox-fill-list lb run-names selected-item: default-run-name))))) (dboard:data-updater-for-runs-set! data refresh-runs-list) (refresh-runs-list) (dboard:data-run-name-set! data default-run-name) (iup:hbox tb lb)))) (define (dcommon:command-testname-selector alldat data update-keyvals key-listboxes) (iup:frame #:title "SELECTORS" (iup:vbox ;; Text box for test patterns (iup:frame #:title "Test patterns (one per line)" (let ((tb (iup:textbox #:action (lambda (val a b) (dboard:data-test-patts-set! *data* (dboard:lines->test-patt b)) (dashboard:update-run-command data)) #:value (dboard:test-patt->lines (dboard:data-test-patts *data*)) #:expand "YES" #:size "x50" #:multiline "YES"))) (set! test-patterns-textbox tb) tb)) (iup:frame #:title "Target" |
︙ | ︙ | |||
1022 1023 1024 1025 1026 1027 1028 | ;; Text box for STATES (iup:frame #:title "States" (dashboard:text-list-toggle-box ;; Move these definitions to common and find the other useages and replace! (map cadr *common:std-states*) ;; '("COMPLETED" "RUNNING" "STUCK" "INCOMPLETE" "LAUNCHED" "REMOTEHOSTSTART" "KILLED") (lambda (all) | | | | 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 | ;; Text box for STATES (iup:frame #:title "States" (dashboard:text-list-toggle-box ;; Move these definitions to common and find the other useages and replace! (map cadr *common:std-states*) ;; '("COMPLETED" "RUNNING" "STUCK" "INCOMPLETE" "LAUNCHED" "REMOTEHOSTSTART" "KILLED") (lambda (all) (dboard:data-states-set! *data* all) (dashboard:update-run-command data)))) ;; Text box for STATES (iup:frame #:title "Statuses" (dashboard:text-list-toggle-box (map cadr *common:std-statuses*) ;; '("PASS" "FAIL" "n/a" "CHECK" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD") (lambda (all) (dboard:data-statuses-set! *data* all) (dashboard:update-run-command data)))))))) (define (dcommon:command-tests-tasks-canvas data test-records sorted-testnames tests-draw-state) (iup:frame #:title "Tests and Tasks" (let* ((updater #f) (last-xadj 0) |
︙ | ︙ | |||
1104 1105 1106 1107 1108 1109 1110 | (newpatt-list (if selected (cons test-name patterns) (delete test-name patterns))) (newpatt (string-intersperse newpatt-list "\n"))) (iup:attribute-set! obj "REDRAW" "ALL") (hash-table-set! selected-tests test-name selected) (iup:attribute-set! test-patterns-textbox "VALUE" newpatt) | | | 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 | (newpatt-list (if selected (cons test-name patterns) (delete test-name patterns))) (newpatt (string-intersperse newpatt-list "\n"))) (iup:attribute-set! obj "REDRAW" "ALL") (hash-table-set! selected-tests test-name selected) (iup:attribute-set! test-patterns-textbox "VALUE" newpatt) (dboard:data-test-patts-set! data (dboard:lines->test-patt newpatt)) (dashboard:update-run-command data) (if updater (updater last-xadj last-yadj))))))) (hash-table-keys tests-info))))))) canvas-obj))) ;;====================================================================== ;; S T E P S |
︙ | ︙ |
Modified multi-dboard.scm from [599895d711] to [604c83dc90].
︙ | ︙ | |||
387 388 389 390 391 392 393 | ;; (print "obj: " obj ", id: " id ", state: " state) (let* ((tree-path (tree:node->path obj id)) (area (car tree-path)) (areadat-path (cdr tree-path))) #f ;; (test-id (tree-path->test-id (cdr run-path)))) ;; (if test-id | | | | 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 | ;; (print "obj: " obj ", id: " id ", state: " state) (let* ((tree-path (tree:node->path obj id)) (area (car tree-path)) (areadat-path (cdr tree-path))) #f ;; (test-id (tree-path->test-id (cdr run-path)))) ;; (if test-id ;; (hash-table-set! (dboard:data-curr-test-ids *data*) ;; window-id test-id)) ;; (print "path: " (tree:node->path obj id) " test-id: " test-id)))))) ))))) ;; (iup:attribute-set! tb "VALUE" "0") ;; (iup:attribute-set! tb "NAME" "Runs") ;; (iup:attribute-set! tb "ADDEXPANDED" "NO") ;; (dboard:data-tests-tree-set! *data* tb) tb)) ;;====================================================================== ;; M A I N M A T R I X ;;====================================================================== ;; General displayer |
︙ | ︙ | |||
420 421 422 423 424 425 426 | #:numcol-visible 3 #:numlin-visible 20 #:click-cb (lambda (obj lin col status) (print "obj: " obj " lin: " lin " col: " col " status: " status " value: " (iup:attribute obj "VALUE")))))) ;; (iup:attribute-set! view-matrix "RESIZEMATRIX" "YES") (iup:attribute-set! view-matrix "WIDTH0" "100") | | | 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 | #:numcol-visible 3 #:numlin-visible 20 #:click-cb (lambda (obj lin col status) (print "obj: " obj " lin: " lin " col: " col " status: " status " value: " (iup:attribute obj "VALUE")))))) ;; (iup:attribute-set! view-matrix "RESIZEMATRIX" "YES") (iup:attribute-set! view-matrix "WIDTH0" "100") ;; (dboard:data-runs-matrix-set! *data* runs-matrix) ;; (iup:hbox ;; (iup:frame ;; #:title "Runs browser" ;; (iup:vbox view-matrix)) ;;====================================================================== |
︙ | ︙ |
Modified newdashboard.scm from [0d42f424ad] to [6cbd88e309].
︙ | ︙ | |||
259 260 261 262 263 264 265 | ;;====================================================================== ;; T E S T S ;;====================================================================== (define (tree-path->test-id path) (if (not (null? path)) | | | 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 | ;;====================================================================== ;; T E S T S ;;====================================================================== (define (tree-path->test-id path) (if (not (null? path)) (hash-table-ref/default (dboard:data-path-test-ids *data*) path #f) #f)) (define (test-panel window-id) (let* ((curr-row-num 0) (viewlog (lambda (x) (if (file-exists? logfile) ;(system (conc "firefox " logfile "&")) |
︙ | ︙ | |||
343 344 345 346 347 348 349 | #:numlin 50 #:numcol-visible 8 #:numlin-visible 8)) (updater (lambda (testdat) (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix)))) ;; Set the updater in updaters | | | 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 | #:numlin 50 #:numcol-visible 8 #:numlin-visible 8)) (updater (lambda (testdat) (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix)))) ;; Set the updater in updaters (hash-table-set! (dboard:data-updaters *data*) window-id updater) ;; (for-each (lambda (mat) ;; (iup:attribute-set! mat "0:1" "Value") ;; (iup:attribute-set! mat "0:0" "Var") (iup:attribute-set! mat "HEIGHT0" 0) (iup:attribute-set! mat "ALIGNMENT1" "ALEFT") |
︙ | ︙ | |||
445 446 447 448 449 450 451 | (let* ((tb (iup:treebox #:selection-cb (lambda (obj id state) ;; (print "obj: " obj ", id: " id ", state: " state) (let* ((run-path (tree:node->path obj id)) (test-id (tree-path->test-id (cdr run-path)))) (if test-id | | | | | | 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 | (let* ((tb (iup:treebox #:selection-cb (lambda (obj id state) ;; (print "obj: " obj ", id: " id ", state: " state) (let* ((run-path (tree:node->path obj id)) (test-id (tree-path->test-id (cdr run-path)))) (if test-id (hash-table-set! (dboard:data-curr-test-ids *data*) window-id test-id)) (print "path: " (tree:node->path obj id) " test-id: " test-id)))))) (iup:attribute-set! tb "VALUE" "0") (iup:attribute-set! tb "NAME" "Runs") ;;(iup:attribute-set! tb "ADDEXPANDED" "NO") (dboard:data-tests-tree-set! *data* tb) tb) (test-panel window-id))) ;; The function to update the fields in the test view panel (define (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix) ;; get test-id ;; then get test record (if testdat (let* ((test-id (hash-table-ref/default (dboard:data-curr-test-ids *data*) window-id #f)) (test-data (hash-table-ref/default testdat test-id #f)) (run-id (db:test-get-run_id test-data)) (targ/runname (hash-table-ref/default (dboard:data-run-keys *data*) run-id '())) (target (if (null? targ/runname) "" (string-intersperse (reverse (cdr (reverse targ/runname))) "/"))) (runname (if (null? targ/runname) "" (car (cdr targ/runname)))) (steps-dat (tests:get-compressed-steps *dbstruct-local* run-id test-id))) (if test-data |
︙ | ︙ | |||
560 561 562 563 564 565 566 | #: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") | | | 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 | #: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") (dboard:data-runs-matrix-set! *data* runs-matrix) (iup:hbox (iup:frame #:title "Runs browser" (iup:vbox runs-matrix))))) ;; Browse and control a single run |
︙ | ︙ | |||
609 610 611 612 613 614 615 | (testpatt "%") (keypatts (map (lambda (k)(list k "%")) keys)) (states '()) (statuses '()) (nextmintime (current-milliseconds)) (my-window-id *current-window-id*)) (set! *current-window-id* (+ 1 *current-window-id*)) | | | | 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 | (testpatt "%") (keypatts (map (lambda (k)(list k "%")) keys)) (states '()) (statuses '()) (nextmintime (current-milliseconds)) (my-window-id *current-window-id*)) (set! *current-window-id* (+ 1 *current-window-id*)) (dboard:data-runs-set! *data* data) ;; make this data available to the rest of the application (iup:show (main-panel my-window-id)) ;; Yes, running iup:show will pop up a new panel ;; (iup:show (main-panel my-window-id)) (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)) (let* ((starttime (current-milliseconds)) (changes (dcommon:run-update keys data runname keypatts testpatt states statuses 'full my-window-id)) (endtime (current-milliseconds))) (set! nextmintime (+ endtime (* 2 (- endtime starttime)))) (debug:print 11 *default-log-port* "CHANGE(S): " (car changes) "...")) (debug:print-info 11 *default-log-port* "Server overloaded")))))) (dboard:data-updaters-set! *data* (make-hash-table)) (newdashboard *dbstruct-local*) (iup:main-loop) |
Modified tree.scm from [1c5a9172b0] to [5c27bcda2b].
︙ | ︙ | |||
133 134 135 136 137 138 139 | #:selection-cb (lambda (obj id state) ;; (print "obj: " obj ", id: " id ", state: " state) (let* ((run-path (tree:node->path obj id)) (run-id (tree-path->run-id (cdr run-path)))) (if run-id (begin | | | 133 134 135 136 137 138 139 140 141 142 143 144 | #:selection-cb (lambda (obj id state) ;; (print "obj: " obj ", id: " id ", state: " state) (let* ((run-path (tree:node->path obj id)) (run-id (tree-path->run-id (cdr run-path)))) (if run-id (begin (dboard:data-curr-run-id-set! *data* run-id) (dashboard:update-run-summary-tab))) ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) )))) |# |