Overview
Comment: | wip |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | v1.65-try3 |
Files: | files | file ages | folders |
SHA1: |
cfaa83fc7069a9cd0ee9d930b7d2c970 |
User & Date: | matt on 2019-11-03 19:06:55 |
Other Links: | branch diff | manifest | tags |
Context
2019-11-03
| ||
19:22 | wip check-in: 792cf5fe01 user: matt tags: v1.65-try3 | |
19:06 | wip check-in: cfaa83fc70 user: matt tags: v1.65-try3 | |
16:30 | wip check-in: 3405d7b2db user: matt tags: v1.65-try3 | |
Changes
Modified dashboard-tests-inc.scm from [0f5083b517] to [cb59811621].
︙ | |||
21 22 23 24 25 26 27 28 29 30 31 32 33 34 | 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 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 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 | + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + | ;;====================================================================== ;; Test info panel ;;====================================================================== ;;====================================================================== ;; C O M M O N ;;====================================================================== ;; data for each specific tab goes here ;; (defstruct dboard:tabdat ;; runs ((allruns '()) : list) ;; list of dboard:rundat records ((allruns-by-id (make-hash-table)) : hash-table) ;; hash of run-id -> dboard:rundat records ((done-runs '()) : list) ;; list of runs already drawn ((not-done-runs '()) : list) ;; list of runs not yet drawn (header #f) ;; header for decoding the run records (keys #f) ;; keys for this run (i.e. target components) ((numruns (string->number (or (args:get-arg "-cols") (configf:lookup *configdat* "dashboard" "cols") "8"))) : number) ;; ((tot-runs 0) : number) ((last-data-update 0) : number) ;; last time the data in allruns was updated ((last-runs-update 0) : number) ;; last time we pulled the runs info to update the tree (runs-mutex (make-mutex)) ;; use to prevent parallel access to draw objects ((run-update-times (make-hash-table)) : hash-table) ;; update times indexed by run-id ((last-test-dat (make-hash-table)) : hash-table) ;; cache last tests dat by run-id ((run-db-paths (make-hash-table)) : hash-table) ;; cache the paths to the run db files ;; Runs view ((buttondat (make-hash-table)) : hash-table) ;; ((item-test-names '()) : list) ;; list of itemized tests ((run-keys (make-hash-table)) : hash-table) (runs-matrix #f) ;; used in newdashboard ((start-run-offset 0) : number) ;; left-right slider value ((start-test-offset 0) : number) ;; up-down slider value ((runs-btn-height (or (configf:lookup *configdat* "dashboard" "btn-height") "x16")) : string) ;; was 12 ((runs-btn-fontsz (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10")) : string) ;; was 8 ((runs-cell-width (or (configf:lookup *configdat* "dashboard" "cell-width") "50")) : string) ;; was 50 ((all-test-names '()) : list) ;; Canvas and drawing data (cnv #f) (cnv-obj #f) (drawing #f) ((run-start-row 0) : number) ((max-row 0) : number) ((running-layout #f) : boolean) (originx #f) (originy #f) ((layout-update-ok #t) : boolean) ((compact-layout #t) : boolean) ;; Run times layout ;; (graph-button-box #f) ;; RA => Think it is not referenced anywhere (graph-matrix #f) ((graph-matrix-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru graph name info ((graph-cell-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru matrix cell info ((graph-matrix-row 1) : number) ((graph-matrix-col 1) : number) ;; Controls used to launch runs etc. ((command "") : string) ;; for run control this is the command being built up (command-tb #f) ;; widget for the type of command; run, remove-runs etc. (test-patterns-textbox #f) ;; text box widget for editing a list of test patterns (key-listboxes #f) (key-lbs #f) run-name ;; from run name setting widget states ;; states for -state s1,s2 ... statuses ;; statuses for -status s1,s2 ... ;; Selector variables curr-run-id ;; current row to display in Run summary view prev-run-id ;; previous runid selected before current runid was selected (used in xor-two-runs runs summary mode curr-test-ids ;; used only in dcommon:run-update which is used in newdashboard ((filters-changed #t) : boolean) ;; to indicate that the user changed filters for this tab ((last-filter-str "") : string) ;; conc the target runname and testpatt for a signature of changed filters ((hide-empty-runs #f) : boolean) ((hide-not-hide #t) : boolean) ;; toggle for hide/not hide empty runs (hide-not-hide-button #f) ((searchpatts (make-hash-table)) : hash-table) ;; ((state-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATE => #t/#f for display control ((status-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATUS => #t/#f (target #f) (test-patts #f) ;; db info to file the .db files for the area (access-mode (db:get-access-mode)) ;; use cached db or not (dbdir #f) (dbfpath #f) (dbkeys #f) ((last-db-update (make-hash-table)) : hash-table) ;; last db file timestamp (monitor-db-path #f) ;; where to find monitor.db ro ;; is the database read-only? ;; tests data ((num-tests 10) : number) ;; total number of tests to show (used in the old runs display) ;; runs tree ((path-run-ids (make-hash-table)) : hash-table) ;; path (target / runname) => id (runs-tree #f) ((runs-tree-ht (make-hash-table)) : hash-table) ;; track which targets added to tree (merge functionality with path-run-ids?) ;; tab data ((view-changed #t) : boolean) ((xadj 0) : number) ;; x slider number (if using canvas) ((yadj 0) : number) ;; y slider number (if using canvas) ;; runs-summary tab state ((runs-summary-modes '((one-run . "Show One Run") (xor-two-runs . "XOR Two Runs") (xor-two-runs-hide-clean . "XOR; Hide Clean")) ) : list) ((runs-summary-mode-buttons '()) : list) ((runs-summary-mode 'one-run) : symbol) ((runs-summary-mode-change-callbacks '()) : list) (runs-summary-source-runname-label #f) (runs-summary-dest-runname-label #f) ;; runs summary view tests-tree ;; used in newdashboard ) (define *dashboard-comment-share-slot* #f) (define (message-window msg) (iup:show (iup:dialog (iup:vbox |
︙ | |||
609 610 611 612 613 614 615 | 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 | - + | (common:run-a-command cmd with-orig-env: #t)))) (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -10" #:action (lambda (obj cnum val) ;; (print "cnum=" cnum) (if (eq? cnum 13) |
︙ | |||
805 806 807 808 809 810 811 | 916 917 918 919 920 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 | + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + | (lambda (x) ;; Now start keeping the gui updated from the db (refreshdat) ;; update from the db here ;(thread-suspend! other-thread) (if *exit-started* (set! *exit-started* 'ok)))))))))) (define (colors-similar? color1 color2) (let* ((c1 (map string->number (string-split color1))) (c2 (map string->number (string-split color2))) (delta (map (lambda (a b)(abs (- a b))) c1 c2))) (null? (filter (lambda (x)(> x 3)) delta)))) ;; Display the tests as rows of boxes on the test/task pane ;; (define (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames test-records) (canvas-clear! cnv) (canvas-font-set! cnv "Helvetica, -10") (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv)) ((originx originy) (canvas-origin cnv))) ;; (print "originx: " originx " originy: " originy) ;; (canvas-origin-set! cnv 0 (- (/ sizey 2))) (if (hash-table-ref/default tests-draw-state 'first-time #t) (begin (hash-table-set! tests-draw-state 'first-time #f) (hash-table-set! tests-draw-state 'scalef 1) (hash-table-set! tests-draw-state 'tests-info (make-hash-table)) (hash-table-set! tests-draw-state 'selected-tests (make-hash-table)) ;; set these (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)) (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)) )) (define (dboard:tabdat-test-patts-use vec) (let ((val (dboard:tabdat-test-patts vec)))(if val val ""))) ;;RADT => What is the if for? ;; additional setters for dboard:data (define (dboard:tabdat-test-patts-set!-use vec val) (dboard:tabdat-test-patts-set! vec (if (equal? val "") #f val))) ;; Extract the various bits of data from tabdat and create the command line equivalent that will be displayed ;; (define (dashboard:update-run-command tabdat) (let* ((cmd-tb (dboard:tabdat-command-tb tabdat)) (cmd (dboard:tabdat-command tabdat)) (test-patt (let ((tp (dboard:tabdat-test-patts tabdat))) (if (or (not tp) (equal? tp "")) "%" tp))) (states (dboard:tabdat-states tabdat)) (statuses (dboard:tabdat-statuses tabdat)) (target (let ((targ-list (dboard:tabdat-target tabdat))) (if targ-list (string-intersperse targ-list "/") "no-target-selected"))) (run-name (dboard:tabdat-run-name tabdat)) (states-str (if (or (not states) (null? states)) "" (conc " -state " (string-intersperse states ",")))) (statuses-str (if (or (not statuses) (null? statuses)) "" (conc " -status " (string-intersperse statuses ",")))) (full-cmd "megatest")) (case (string->symbol cmd) ((run) (set! full-cmd (conc full-cmd " -run" " -testpatt " test-patt " -target " target " -runname " run-name " -clean-cache" ))) ((remove-runs) (set! full-cmd (conc full-cmd " -remove-runs -runname " run-name " -target " target " -testpatt " test-patt states-str statuses-str ))) (else (set! full-cmd " no valid command "))) (iup:attribute-set! cmd-tb "VALUE" full-cmd))) |
Modified dashboard.scm from [34910ee38e] to [e75db03c6f].
︙ | |||
248 249 250 251 252 253 254 | 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 | - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - | (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 (cons updater curr-updaters)))) |
︙ | |||
547 548 549 550 551 552 553 | 429 430 431 432 433 434 435 436 437 438 439 440 441 442 | - - - - - - | (set! i (+ i 1))) items) ;; (iup:attribute-set! lb "VALUE" (if selected-item selected-item "")) i)) (define (pad-list l n)(append l (make-list (- n (length l))))) |
︙ | |||
1276 1277 1278 1279 1280 1281 1282 | 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 | - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - | (hash-table-delete! alltgls item) (hash-table-set! alltgls item #t)) (let ((all (hash-table-keys alltgls))) (proc all))) "text-list-toggle-box")))) items)))) |
︙ |
Modified env-inc.scm from [8d8fa780e9] to [67e61aff12].
︙ | |||
65 66 67 68 69 70 71 | 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 | - - + + | (lambda (row) (let ((var (car row)) (val (cadr row))) (hash-table-set! result var (if (and (hash-table-ref/default results var #f) (assoc var paths)) ;; this var is a path and there is a previous path (let ((sep (cadr (assoc var paths)))) |
︙ |
Added gutils-inc.scm version [6b5c3b4ed6].
|
Modified http-transport-inc.scm from [7eec9fa817] to [06fb34d171].
︙ | |||
281 282 283 284 285 286 287 | 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 | - + | (debug:print-info 11 *default-log-port* "got res=" res) (if (vector? res) (if (vector-ref res 0) ;; this is the first flag or the second flag? res ;; this is the *inner* vector? seriously? why? (if (debug:debug-mode 11) (let ((call-chain (get-call-chain))) ;; note: this code also called in nmsg-transport - consider consolidating it (print-call-chain (current-error-port)) |
︙ | |||
354 355 356 357 358 359 360 | 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 | + - + - + | ;; used and to shutdown after sometime if it is not. ;; (define (http-transport:keep-running) ;; if none running or if > 20 seconds since ;; server last used then start shutdown ;; This thread waits for the server to come alive (debug:print-info 0 *default-log-port* "Starting the sync-back, keep alive thread in server") (let* ((sdat #f) |
︙ | |||
390 391 392 393 394 395 396 | 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 | - + - + | (debug:print-error 0 *default-log-port* "transport appears to have died, exiting server") (common:save-pkt `((action . died) (T . server) (pid . ,(current-process-id)) (ipaddr . ,(car sdat)) (port . ,(cadr sdat)) (msg . "Transport died?")) |
︙ |
Modified margs-inc.scm from [de57287845] to [0e96276687].
︙ | |||
28 29 30 31 32 33 34 | 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | - + | (map args:get-arg args))))) (define (args:get-arg-from ht arg . default) (if (null? default) (hash-table-ref/default ht arg #f) (hash-table-ref/default ht arg (car default)))) |
︙ |
Modified megamod.scm from [dc15039da0] to [13b90bf40e].
︙ | |||
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 164 165 166 167 168 169 170 | 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 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 | + + + + + + + + + + + + + + + + + + + + + + | ;;====================================================================== ;; L O C K I N G M E C H A N I S M S ;;====================================================================== (include "megatest-fossil-hash.scm") (include "megatest-version.scm") ;; globals (define *writes-total-delay* 0) (define *exit-started* #f) (define *tim* (iup:timer)) ;; The watchdog is to keep an eye on things like db sync etc. ;; ;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage (define *watchdog* (make-thread (lambda () (handle-exceptions exn (begin (print-call-chain) (print " message: " ((condition-property-accessor 'exn 'message) exn))) (common:watchdog))) "Watchdog thread")) (include "api-inc.scm") (include "archive-inc.scm") (include "client-inc.scm") (include "common-inc.scm") (include "configf-inc.scm") (include "db-inc.scm") (include "dcommon-inc.scm") (include "dashboard-tests-inc.scm") (include "env-inc.scm") (include "ezsteps-inc.scm") (include "gutils-inc.scm") (include "http-transport-inc.scm") (include "items-inc.scm") (include "keys-inc.scm") (include "launch-inc.scm") (include "margs-inc.scm") (include "mt-inc.scm") (include "ods-inc.scm") (include "pgdb-inc.scm") (include "portlogger-inc.scm") (include "process-inc.scm") (include "rmt-inc.scm") (include "runconfig-inc.scm") (include "runs-inc.scm") (include "server-inc.scm") (include "subrun-inc.scm") (include "tasks-inc.scm") |
︙ |
Modified megatest.scm from [0a836af179] to [0d0676efe4].
︙ | |||
472 473 474 475 476 477 478 | 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 | - - - - - - - - - - - - + - | (exit 1)))) ;; immediately set MT_TARGET if -reqtarg or -target are available ;; (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target")))) (if targ (setenv "MT_TARGET" targ))) |
︙ |
Added portlogger-inc.scm version [cfa15af2ea].