Changes In Branch v1.64-areas-dashboard Through [d654343818] Excluding Merge-Ins
This is equivalent to a diff from 2890f3b693 to d654343818
2017-11-17
| ||
16:02 | Merged in d6543 check-in: 0f21dbf014 user: mrwellan tags: areas-work-merge (unpublished) | |
2017-08-28
| ||
11:47 | Merged v1.64 into areas-dashboard branch. check-in: 1f5e744ec1 user: matt tags: v1.64-areas-dashboard | |
2017-08-22
| ||
20:56 | Added usage to plot-code. Removed defunct switch -use-db-cache from dashboard. check-in: d654343818 user: matt tags: v1.64-areas-dashboard | |
2017-08-21
| ||
18:10 | Fixed plot-code.scm to work when compiled. check-in: da673f0c80 user: mrwellan tags: v1.64-areas-dashboard | |
2017-08-14
| ||
16:36 | For teamcity it is necessary to emit a testFinished message even when the test is marked testFailed. check-in: 99afad6671 user: mrwellan tags: v1.64 | |
2017-08-08
| ||
22:08 | Bringing v1.64-dashboard-tests up to date with latest changes from v1.64 check-in: d1470b8c93 user: matt tags: v1.64-areas-dashboard | |
21:45 | Merged v1.64 into v1.65, ready for next phase check-in: 82bd7da1b3 user: matt tags: v1.65 | |
16:59 | Use process-pid for flowId for teamcity, fall back to testname check-in: 2890f3b693 user: mrwellan tags: v1.64 | |
13:36 | Adjusted date format to match TeamCity requirements check-in: ee77e3a1b4 user: mrwellan tags: v1.64 | |
Modified Makefile from [01ab7d1240] to [32f21cf39e].
1 2 3 4 5 6 7 8 9 10 11 12 13 | # make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)' # rm <files>.o ; make install CSCOPTS='-profile' ; ... ; chicken-profile | less PREFIX=$(PWD) CSCOPTS= INSTALL=install SRCFILES = common.scm items.scm launch.scm \ ods.scm runconfig.scm server.scm configf.scm \ db.scm keys.scm margs.scm megatest-version.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ http-transport.scm filedb.scm \ client.scm daemon.scm mt.scm \ ezsteps.scm lock-queue.scm sdb.scm \ | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)' # rm <files>.o ; make install CSCOPTS='-profile' ; ... ; chicken-profile | less PREFIX=$(PWD) CSCOPTS= INSTALL=install SRCFILES = common.scm items.scm launch.scm \ ods.scm runconfig.scm server.scm configf.scm \ db.scm keys.scm margs.scm megatest-version.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ http-transport.scm filedb.scm \ client.scm daemon.scm mt.scm \ ezsteps.scm lock-queue.scm sdb.scm \ rmt.scm mrmt.scm api.scm tdb.scm rpc-transport.scm \ portlogger.scm archive.scm env.scm diff-report.scm cgisetup/models/pgdb.scm # Eggs to install (straightforward ones) EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \ dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \ json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \ spiffy-directory-listing ssax sxml-serializer sxml-modifications iup canvas-draw sqlite3 |
︙ | ︙ | |||
42 43 44 45 46 47 48 | #all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut ndboard all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut mtest: $(OFILES) readline-fix.scm megatest.o csc $(CSCOPTS) $(OFILES) megatest.o -o mtest | | | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 | #all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut ndboard all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut mtest: $(OFILES) readline-fix.scm megatest.o csc $(CSCOPTS) $(OFILES) megatest.o -o mtest dboard : $(OFILES) $(GOFILES) dashboard.scm dashboard-areas.scm csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) -o dboard ndboard : newdashboard.scm $(OFILES) $(GOFILES) csc $(CSCOPTS) $(OFILES) $(GOFILES) newdashboard.scm -o ndboard mtut: $(OFILES) mtut.scm csc $(CSCOPTS) $(OFILES) mtut.scm -o mtut |
︙ | ︙ |
Modified common.scm from [071499421b] to [eee64ce859].
1 2 3 4 5 6 7 8 9 10 11 | ;;====================================================================== ;; Copyright 2006-2012, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== | | | < | | | | < > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | ;;====================================================================== ;; Copyright 2006-2012, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== (use srfi-1 data-structures posix regex-case (prefix base64 base64:) format dot-locking csv-xml z3 ;; sql-de-lite hostinfo md5 message-digest typed-records directory-utils stack matchable regex posix (srfi 18) extras ;; tcp (prefix nanomsg nmsg:) (prefix sqlite3 sqlite3:) ) (declare (unit common)) (include "common_records.scm") ;; (require-library margs) ;; (include "margs.scm") |
︙ | ︙ | |||
98 99 100 101 102 103 104 | ;; res)))) ;; A hash table that can be accessed by #{scheme ...} calls in ;; config files. Allows communicating between confgs ;; (define *user-hash-data* (make-hash-table)) | | | 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 | ;; res)))) ;; A hash table that can be accessed by #{scheme ...} calls in ;; config files. Allows communicating between confgs ;; (define *user-hash-data* (make-hash-table)) ;; (define *db-keys* #f) (define *configinfo* #f) ;; raw results from setup, includes toppath and table from megatest.config (define *runconfigdat* #f) ;; run configs data (define *configdat* #f) ;; megatest.config data (define *configstatus* #f) ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done (define *toppath* #f) (define *already-seen-runconfig-info* #f) |
︙ | ︙ | |||
132 133 134 135 136 137 138 | (define *db-sync-in-progress* #f) ;; if there is a sync in progress do not try to start another (define *db-multi-sync-mutex* (make-mutex)) ;; protect access to *db-sync-in-progress*, *db-last-sync* ;; task db (define *task-db* #f) ;; (vector db path-to-db) (define *db-access-allowed* #t) ;; flag to allow access (define *db-access-mutex* (make-mutex)) (define *db-transaction-mutex* (make-mutex)) | | | 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 | (define *db-sync-in-progress* #f) ;; if there is a sync in progress do not try to start another (define *db-multi-sync-mutex* (make-mutex)) ;; protect access to *db-sync-in-progress*, *db-last-sync* ;; task db (define *task-db* #f) ;; (vector db path-to-db) (define *db-access-allowed* #t) ;; flag to allow access (define *db-access-mutex* (make-mutex)) (define *db-transaction-mutex* (make-mutex)) ;; (define *db-cache-path* #f) (define *db-with-db-mutex* (make-mutex)) (define *db-api-call-time* (make-hash-table)) ;; hash of command => (list of times) ;; no sync db (define *no-sync-db* #f) ;; SERVER (define *my-client-signature* #f) |
︙ | ︙ | |||
634 635 636 637 638 639 640 | (getenv "MT_TESTSUITE_NAME") (if (string? *toppath* ) (pathname-file *toppath*) #f))) ;; (pathname-file (current-directory))))) (define common:get-area-name common:get-testsuite-name) | > > > | | | > > | | | | | | | | | | | | > | | | 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 | (getenv "MT_TESTSUITE_NAME") (if (string? *toppath* ) (pathname-file *toppath*) #f))) ;; (pathname-file (current-directory))))) (define common:get-area-name common:get-testsuite-name) ;; WARNING: This code falls back to using the global Megatest ;; variable *toppath* ;; (define (common:get-db-tmp-area dbstruct) (if (and dbstruct (dbr:dbstruct-tmpdb-path dbstruct)) ;; *db-cache-path* (dbr:dbstruct-tmpdb-path) ;; *db-cache-path* (let ((toppath (or (and dbstruct (dbr:dbstruct-area-path dbstruct)) *toppath*)) (tsname (or (and dbstruct (dbr:dbstruct-area-name dbstruct))(common:get-testsuite-name)))) (if toppath ;; common:get-create-writeable-dir (handle-exceptions exn (begin (debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir) (exit 1)) (let ((dbpath (common:get-create-writeable-dir (list (conc "/tmp/" (current-user-name) "/megatest_localdb/" tsname "/" (string-translate toppath "/" ".")))))) ;; #t)))) ;; (set! *db-cache-path* dbpath) (if dbstruct (dbr:dbstruct-tmpdb-path-set! dbstruct dbpath)) dbpath)) #f)))) (define (common:get-area-path-signature) (message-digest-string (md5-primitive) *toppath*)) (define (common:get-signature str) (message-digest-string (md5-primitive) str)) |
︙ | ︙ | |||
962 963 964 965 966 967 968 | (define (common:false-on-exception thunk #!key (message #f)) (handle-exceptions exn (begin (if message (debug:print-info 0 *default-log-port* message)) #f) (thunk) )) | | | > > > | < | | > > > | < | 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 | (define (common:false-on-exception thunk #!key (message #f)) (handle-exceptions exn (begin (if message (debug:print-info 0 *default-log-port* message)) #f) (thunk) )) (define (common:file-exists? path-string #!key (quiet-mode #f)) ;; this avoids stack dumps in the case where ;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg: system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q... (common:false-on-exception (lambda () (file-exists? path-string)) message: (if quiet-mode #f (conc "Unable to access path: " path-string)))) (define (common:directory-exists? path-string #!key (quiet-mode #f)) ;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg: system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q... (common:false-on-exception (lambda () (directory-exists? path-string)) message: (if quiet-mode #f (conc "Unable to access path: " path-string)))) ;; does the directory exist and do we have write access? ;; ;; returns the directory or #f ;; (define (common:directory-writable? path-string) (handle-exceptions |
︙ | ︙ | |||
1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 | #f)))))) (at-home (or (equal? homehost currhost) (equal? homehost bestadrs)))) (set! *home-host* (cons homehost at-home)) (mutex-unlock! *homehost-mutex*) *home-host*)))) ;; am I on the homehost? ;; (define (common:on-homehost?) (let ((hh (common:get-homehost))) (if hh (cdr hh) #f))) ;; do we honor the caches of the config files? ;; (define (common:use-cache?) (let ((res #t)) ;; priority by order of evaluation (if *configdat* ;; sillyness here. can't use setup/use-cache to know if we can use the cached files! (if (equal? (configf:lookup *configdat* "setup" "use-cache") "no") | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 | #f)))))) (at-home (or (equal? homehost currhost) (equal? homehost bestadrs)))) (set! *home-host* (cons homehost at-home)) (mutex-unlock! *homehost-mutex*) *home-host*)))) ;; get homehost info for a given area - but only if .homehost file already exists (define (common:minimal-get-homehost toppath) (let ((hh-file (conc toppath "/.homehost"))) (if (common:file-exists? hh-file quiet-mode: #t) (with-input-from-file hh-file read-line) #f))) ;; are we on the given host? (define (common:on-host? hh) (let* ((currhost (get-host-name)) (bestadrs (server:get-best-guess-address currhost))) (or (equal? hh currhost) (equal? hh bestadrs)))) ;; am I on the homehost? ;; (define (common:on-homehost?) (let ((hh (common:get-homehost))) (if hh (cdr hh) #f))) ;; minimal loading of megatest.config ;; (define (common:simple-setup toppath #!key (cfgf-ovrd #f)) (let* ((mtconfigf (or cfgf-ovrd "megatest.config")) (mtconfdat (find-and-read-config mtconfigf ;; environ-patt: "env-override" given-toppath: toppath ;; pathenvvar: "MT_RUN_AREA_HOME" )) (mtconf (if mtconfdat (car mtconfdat) #f))) (if mtconf (configf:section-var-set! mtconf "dyndat" "toppath" toppath)) mtconfdat)) ;; do we honor the caches of the config files? ;; (define (common:use-cache?) (let ((res #t)) ;; priority by order of evaluation (if *configdat* ;; sillyness here. can't use setup/use-cache to know if we can use the cached files! (if (equal? (configf:lookup *configdat* "setup" "use-cache") "no") |
︙ | ︙ | |||
2288 2289 2290 2291 2292 2293 2294 | fallback-launcher (loop (car tal)(cdr tal))))))) ;; no match, try again (if (null? tal) fallback-launcher (loop (car tal)(cdr tal)))))))) fallback-launcher))) | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 | fallback-launcher (loop (car tal)(cdr tal))))))) ;; no match, try again (if (null? tal) fallback-launcher (loop (car tal)(cdr tal)))))))) fallback-launcher))) ;;====================================================================== ;; NMSG AND NEW API ;;====================================================================== ;; nm based server ;; (define (nm:start-server dbconn #!key (given-host-name #f)) (let* ((srvdat (start-raw-server given-host-name: given-host-name)) (host-name (srvdat-host srvdat)) (soc (srvdat-soc srvdat))) ;; start the queue processor (save for second round of development) ;; ;; (thread-start! (queue-processory dbconn) "Queue processor") ;; msg is an alist ;; 'r host:port <== where to return the data ;; 'p params <== data to apply the command to ;; 'e j|s|l <== encoding of the params. default is s (sexp), if not specified is assumed to be default ;; 'c command <== look up the function to call using this key ;; (let loop ((msg-in (nn-recv soc))) (if (not (equal? msg-in "quit")) (let* ((dat (decode msg-in)) (host-port (alist-ref 'r dat)) ;; this is for the reverse req rep where the server is a client of the original client (params (alist-ref 'p dat)) (command (let ((c (alist-ref 'c dat)))(if c (string->symbol c) #f))) (all-good (and host-port params command (hash-table-exists? *commands* command)))) (if all-good (let ((cmddat (make-qitem command: command host-port: host-port params: params))) (queue-push cmddat) ;; put request into the queue (nn-send soc "queued")) ;; reply with "queued" (print "ERROR: BAD request " dat)) (loop (nn-recv soc))))) (nn-close soc))) ;;====================================================================== ;; D A S H B O A R D U S E R V I E W S ;;====================================================================== ;; first read ~/views.config if it exists, then read $MTRAH/views.config if it exists ;; (define (common:load-views-config) (let* ((view-cfgdat (make-hash-table)) (home-cfgfile (conc (get-environment-variable "HOME") "/.mtviews.config")) (mthome-cfgfile (conc *toppath* "/.mtviews.config"))) (if (common:file-exists? mthome-cfgfile) (read-config mthome-cfgfile view-cfgdat #t)) ;; we load the home dir file AFTER the MTRAH file so the user can clobber settings when running the dashboard in read-only areas (if (common:file-exists? home-cfgfile) (read-config home-cfgfile view-cfgdat #t)) view-cfgdat)) ;;====================================================================== ;; H I E R A R C H I C A L H A S H T A B L E S ;;====================================================================== ;; Every element including top element is a vector: ;; <vector subhash value> (define (hh:make-hh #!key (ht #f)(value #f)) (vector (or ht (make-hash-table)) value)) ;; used internally (define-inline (hh:set-ht! hh ht) (vector-set! hh 0 ht)) (define-inline (hh:get-ht hh) (vector-ref hh 0)) (define-inline (hh:set-value! hh value) (vector-set! hh 1 value)) (define-inline (hh:get-value hh value) (vector-ref hh 1)) ;; given a hierarchial hash and some keys look up the value ... ;; (define (hh:get-value hh . keys) (if (null? keys) (vector-ref hh 1) ;; we have reached the end of the line, return the value sought (let ((sub-ht (hh:get-ht hh))) (if sub-ht ;; yes, there is more hierarchy (let ((sub-hh (hash-table-ref/default sub-ht (car keys) #f))) (if sub-hh (apply hh:get-value sub-hh (cdr keys)) #f)) #f)))) (define (hh:get-subhash hh . keys) (if (null? keys) (vector-ref hh 0) ;; we have reached the end of the line, return the value sought (let ((sub-ht (hh:get-ht hh))) (if sub-ht ;; yes, there is more hierarchy (let ((sub-hh (hash-table-ref/default sub-ht (car keys) #f))) (if sub-hh (apply hh:get-subhash sub-hh (cdr keys)) #f)) #f)))) ;; given a hierarchial hash, a value and some keys, add needed hierarcy and insert the value ;; (define (hh:set! hh value . keys) (if (null? keys) (hh:set-value! hh value) ;; we have reached the end of the line, store the value (let ((sub-ht (hh:get-ht hh))) (if sub-ht ;; yes, there is more hierarchy (let ((sub-hh (hash-table-ref/default sub-ht (car keys) #f))) (if (not sub-hh) ;; we'll need to add the next level of hierarchy (let ((new-sub-hh (hh:make-hh))) (hash-table-set! sub-ht (car keys) new-sub-hh) (apply hh:set! new-sub-hh value (cdr keys))) (apply hh:set! sub-hh value (cdr keys)))) ;; call the sub-hierhash with remaining keys (begin (hh:set-ht! hh (make-hash-table)) (apply hh:set! hh value keys)))))) ;; given a hierarchial hash and some keys, return the keys for that hash level ;; (define (hh:get-keys hh . keys) (let ((ht (apply hh:get-subhash hh keys))) (if ht (hash-table-keys ht) '()))) |
Added dashboard-areas.scm version [ac01c869cc].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 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 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 193 194 195 196 197 198 199 200 201 202 203 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 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 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 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 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 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 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 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 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 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 773 774 775 776 777 778 779 | ;;====================================================================== ;; AREAS ;;====================================================================== (define (dashboard:areas-summary-updater commondat tabdat tb cell-lookup run-matrix) ;; maps data from tabdat view-dat to the matrix ;; if input databases have changed, refresh view-dat ;; if filters have changed, refresh view-dat from input databases ;; if pivots have changed, refresh view-dat from input databases (let* ((runs-hash (dashboard:areas-get-runs-hash tabdat)) (runs-header '("contour_name" "release" "iteration" "testsuite_mode" "id" "runname" "state" "status" "owner" "event_time")) (tree-path (dboard:tabdat-tree-path tabdat))) (dboard:areas-update-tree tabdat runs-hash runs-header tb) (print "Tree path: " tree-path) (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES") ;; (if (> max-col (string->number (iup:attribute run-matrix "NUMCOL"))) (iup:attribute-set! run-matrix "NUMCOL" 10) ;; max-col )) ;; (let ((effective-max-row (if (< max-row max-visible) max-visible max-row))) ;; (if (> effective-max-row (string->number (iup:attribute run-matrix "NUMLIN"))) (iup:attribute-set! run-matrix "NUMLIN" 10) ;; effective-max-row ))) (iup:attribute-set! run-matrix "1:1" (conc tree-path)) (iup:attribute-set! run-matrix "REDRAW" "ALL"))) ;; (dashboard:areas-do-update-rundat tabdat) ;; ) ;; (dboard:areas-summary-control-panel-updater tabdat) ;; (let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat)) ;; (runs-dat (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) ;; (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records ;; (runs (vector-ref runs-dat 1)) ;; (run-id (dboard:tabdat-curr-run-id tabdat)) ;; (runs-hash (dashboard:areas-get-runs-hash tabdat)) ;; ;; (runs-hash (let ((ht (make-hash-table))) ;; ;; (for-each (lambda (run) ;; ;; (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) ;; ;; runs) ;; ;; ht)) ;; ) ;; (if (dashboard:areas-database-changed? commondat tabdat context-key: 'runs-summary-tree) ;; (dboard:areas-update-tree tabdat runs-hash runs-header tb)) ;; (if run-id ;; (let* ((matrix-content ;; (case (dboard:tabdat-runs-summary-mode tabdat) ;; ((one-run) (dashboard:areas-run-id->tests-mindat run-id tabdat runs-hash)) ;; ((xor-two-runs) (dashboard:areas-runs-summary-xor-matrix-content tabdat runs-hash)) ;; ((xor-two-runs-hide-clean) (dashboard:areas-runs-summary-xor-matrix-content tabdat runs-hash hide-clean: #t)) ;; (else (dashboard:areas-run-id->tests-mindat run-id tabdat runs-hash))))) ;; (when matrix-content ;; (let* ((indices (common:sparse-list-generate-index matrix-content)) ;; proc: set-cell)) ;; (row-indices (cadr indices)) ;; (col-indices (car indices)) ;; (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) ;; (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices)))) ;; (max-visible (max (- (dboard:tabdat-num-tests tabdat) 15) 3)) ;; (dboard:tabdat-num-tests tabdat) is proportional to the size of the window ;; (numrows 1) ;; (numcols 1) ;; (changed #f) ;; ) ;; ;; (dboard:tabdat-filters-changed-set! tabdat #f) ;; (let loop ((pass-num 0) ;; (changed #f)) ;; (if (eq? pass-num 1) ;; (begin ;; big reset ;; (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS ;; (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") ;; (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES"))) ;; ;; (if (> max-col (string->number (iup:attribute run-matrix "NUMCOL"))) ;; (iup:attribute-set! run-matrix "NUMCOL" max-col )) ;; ;; (let ((effective-max-row (if (< max-row max-visible) max-visible max-row))) ;; (if (> effective-max-row (string->number (iup:attribute run-matrix "NUMLIN"))) ;; (iup:attribute-set! run-matrix "NUMLIN" effective-max-row ))) ;; ;; ;; Row labels ;; (for-each (lambda (ind) ;; (let* ((name (car ind)) ;; (num (cadr ind)) ;; (key (conc num ":0"))) ;; (if (not (equal? (iup:attribute run-matrix key) name)) ;; (begin ;; (set! changed #t) ;; (iup:attribute-set! run-matrix key name))))) ;; row-indices) ;; ;; (print "row-indices: " row-indices " col-indices: " col-indices) ;; (if (and (eq? pass-num 0) changed) ;; (loop 1 #t)) ;; force second pass ;; ;; ;; Cell contents ;; (for-each (lambda (entry) ;; ;; (print "entry: " entry) ;; (let* ((row-name (cadr entry)) ;; (col-name (car entry)) ;; (valuedat (caddr entry)) ;; (test-id (list-ref valuedat 0)) ;; (test-name row-name) ;; (list-ref valuedat 1)) ;; (item-path col-name) ;; (list-ref valuedat 2)) ;; (state (list-ref valuedat 1)) ;; (status (list-ref valuedat 2)) ;; (value (gutils:get-color-for-state-status state status)) ;; (row-num (cadr (assoc row-name row-indices))) ;; (col-num (cadr (assoc col-name col-indices))) ;; (key (conc row-num ":" col-num))) ;; (hash-table-set! cell-lookup key test-id) ;; (if (not (equal? (iup:attribute run-matrix key) (cadr value))) ;; (begin ;; (set! changed #t) ;; (iup:attribute-set! run-matrix key (cadr value)) ;; (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value)))))) ;; matrix-content) ;; ;; ;; Col labels - do after setting Cell contents so they are accounted for in the size calc. ;; ;; (for-each (lambda (ind) ;; (let* ((name (car ind)) ;; (num (cadr ind)) ;; (key (conc "0:" num))) ;; (if (not (equal? (iup:attribute run-matrix key) name)) ;; (begin ;; (set! changed #t) ;; (iup:attribute-set! run-matrix key name) ;; (if (<= num max-col) ;; (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num))))))) ;; col-indices) ;; ;; (if (and (eq? pass-num 0) changed) ;; (loop 1 #t)) ;; force second pass due to column labels changing ;; ;; ;; (debug:print 0 *default-log-port* "runs-summary-updater, changed: " changed " pass-num: " pass-num) ;; ;; (print "runs-summary-updater, changed: " changed " pass-num: " pass-num) ;; (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL"))))))))) (define (dboard:areas-make-matrix commondat tabdat ) (iup:matrix #:expand "YES" #:click-cb (lambda (obj lin col status) (debug:catch-and-dump (lambda () ;; Bummer - we dont have the global get/set api mapped in chicken ;; (let* ((modkeys (iup:global "MODKEYSTATE"))) ;; (BB> "modkeys="modkeys)) (debug:print-info 13 *default-log-port* "click-cb: obj="obj" lin="lin" col="col" status="status) ;; status is corrupted on Brandon's home machine. will have to wait until after shutdown to see if it is still broken in PDX SLES (let* ((toolpath (car (argv))) (key (conc lin ":" col)) (test-id (hash-table-ref/default cell-lookup key -1)) (run-id (dboard:tabdat-curr-run-id tabdat)) (run-info (mrmt:get-run-info run-id)) (target (mrmt:get-target run-id)) (runname (db:get-value-by-header (db:get-rows run-info) (db:get-header run-info) "runname")) (test-info (mrmt:get-test-info-by-id run-id test-id)) (test-name (db:test-get-testname test-info)) (testpatt (let ((tlast (mrmt:tasks-get-last target runname))) (if tlast (let ((tpatt (tasks:task-get-testpatt tlast))) (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017 "%" tpatt)) "%"))) (item-path (db:test-get-item-path (mrmt:get-test-info-by-id run-id test-id))) (item-test-path (conc test-name "/" (if (equal? item-path "") "%" item-path))) (status-chars (char-set->list (string->char-set status))) (testpanel-cmd (conc toolpath " -test " (dboard:tabdat-curr-run-id tabdat) "," test-id " &"))) (debug:print-info 13 *default-log-port* "status-chars=["status-chars"] status=["status"]") (cond ((member #\1 status-chars) ;; 1 is left mouse button (system testpanel-cmd)) ((member #\2 status-chars) ;; 2 is middle mouse button (debug:print-info 13 *default-log-port* "mmb- test-name="test-name" testpatt="testpatt) (iup:show (dashboard:areas-popup-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu #:x 'mouse #:y 'mouse #:modal? "NO") ) (else (debug:print-info 13 *default-log-port* "unhandled status in run-summary-click-cb. Doing right click action. (status is corrupted on Brandon's ubuntu host - bad/buggy iup install??" ) (iup:show (dashboard:areas-popup-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu #:x 'mouse #:y 'mouse #:modal? "NO") )))) "runs-summary-click-callback")))) ;; This is the Areas Summary tab ;; (define (dashboard:areas-summary commondat tabdat #!key (tab-num #f)) (let* ((update-mutex (dboard:commondat-update-mutex commondat)) (tb (iup:treebox #:value 0 #:name "Areas" #:expand "YES" #:addexpanded "YES" #:selection-cb (lambda (obj id state) (debug:catch-and-dump (lambda () ;; (print "obj: " obj ", id: " id ", state: " state) (let* ((prev-tree-path (dboard:tabdat-tree-path tabdat)) (tree-path (tree:node->path obj id)) ;; Need to get the path construction from the pivot data but for now assume: ;; Area Target Runname ;;; ADD STUFF HERE .... ) (if (not (equal? prev-tree-path tree-path)) (dboard:tabdat-view-changed tabdat)) (dboard:tabdat-tree-path-set! tabdat tree-path))) ;; (run-id (tree-path->run-id tabdat (cdr run-path)))) ;; (if (number? run-id) ;; (begin ;; (dboard:tabdat-prev-run-id-set! ;; tabdat ;; (dboard:tabdat-curr-run-id tabdat)) ;; ;; (dboard:tabdat-curr-run-id-set! tabdat run-id) ;; (dboard:tabdat-layout-update-ok-set! tabdat #f) ;; ;; (dashboard:update-run-summary-tab) ;; ) ;; ;; (debug:print-error 0 *default-log-port* "tree-path->run-id returned non-number " run-id) ;; ))) "selection-cb in areas-summary") ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) ))) (cell-lookup (make-hash-table)) (areas-matrix (dboard:areas-make-matrix commondat tabdat)) (areas-summary-updater (lambda () ;; maps data from tabdat view-dat to the matrix ;; if input databases have changed, refresh view-dat ;; if filters have changed, refresh view-dat from input databases ;; if pivots have changed, refresh view-dat from input databases (mutex-lock! update-mutex) (if (or ;; (dashboard:areas-database-changed? commondat tabdat context-key: 'runs-summary-updater) (dboard:tabdat-view-changed tabdat)) (debug:catch-and-dump (lambda () ;; check that areas-matrix is initialized before calling the updater (if areas-matrix (dashboard:areas-summary-updater commondat tabdat tb cell-lookup areas-matrix))) "dashboard:areas-summary-updater") ) (mutex-unlock! update-mutex))) (runs-summary-control-panel (dashboard:areas-summary-control-panel tabdat))) (dboard:commondat-add-updater commondat areas-summary-updater tab-num: tab-num) (dboard:tabdat-runs-tree-set! tabdat tb) (iup:vbox (iup:split #:value 200 tb areas-matrix) (dboard:make-controls commondat tabdat extra-widget: runs-summary-control-panel)))) ;; this calls dboard:get-tests-for-run-duplicate for each run ;; ;; create a virtual table of all the tests ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; (define (dboard:areas-update-rundat tabdat runnamepatt numruns testnamepatt keypatts) (let* ((access-mode (dboard:tabdat-access-mode tabdat)) (keys (dboard:tabdat-keys tabdat)) (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2)) (allruns (mrmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) ;;(allruns-tree (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) (allruns-tree (mrmt:get-runs-by-patt keys "%" #f #f #f #f 0)) ;; last-runs-update));;'("id" "runname") (header (db:get-header allruns)) (runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected (runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs (start-time (current-seconds)) (runs-hash (let ((ht (make-hash-table))) (for-each (lambda (run) (hash-table-set! ht (db:get-value-by-header run header "id") run)) runs-tree) ;; (vector-ref runs-dat 1)) ht)) (tb (dboard:tabdat-runs-tree tabdat))) (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) (dboard:tabdat-header-set! tabdat header) ;; ;; trim runs to only those that are changing often here ;; (if (null? runs) (begin (dboard:tabdat-allruns-set! tabdat '()) (dboard:tabdat-all-test-names-set! tabdat '()) (dboard:tabdat-item-test-names-set! tabdat '()) (hash-table-clear! (dboard:tabdat-allruns-by-id tabdat))) (let loop ((run (car runs)) (tal (cdr runs)) (res '()) (maxtests 0)) (let* ((run-id (db:get-value-by-header run header "id")) (run-struct (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)) ;; (last-update (if run-struct (dboard:rundat-last-update run-struct) 0)) (key-vals (mrmt:get-key-vals run-id)) (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate ;; dboard:get-tests-for-run-duplicate - returns a hash table ;; (dboard:get-tests-dat tabdat run-id last-update)) (all-test-ids (hash-table-keys tests-ht)) (num-tests (length all-test-ids))) ;; (print "run-struct: " run-struct) ;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat) ;; (tests (bubble-up tmptests priority: bubble-type)) ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively. ;; (debug:print 0 *default-log-port* "Getting data for run " run-id " with key-vals=" key-vals) ;; Not sure this is needed? (let* ((newmaxtests (max num-tests maxtests)) ;; (last-update (- (current-seconds) 10)) (run-struct (or run-struct (dboard:rundat-make-init run: run tests: tests-ht key-vals: key-vals))) (new-res (if (null? all-test-ids) res (delete-duplicates (cons run-struct res) (lambda (a b) (eq? (db:get-value-by-header (dboard:rundat-run a) header "id") (db:get-value-by-header (dboard:rundat-run b) header "id")))))) (elapsed-time (- (current-seconds) start-time))) (if (null? all-test-ids) (hash-table-delete! (dboard:tabdat-allruns-by-id tabdat) run-id) (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct)) (if (or (null? tal) (> elapsed-time 2)) ;; stop loading data after 5 seconds, on the next call more data *should* be loaded since get-tests-for-run uses last update (begin (when (> elapsed-time 2) (debug:print 0 *default-log-port* "NOTE: updates are taking a long time, " elapsed-time "s elapsed.") (let* ((old-val (iup:attribute *tim* "TIME")) (new-val (number->string (inexact->exact (floor (* 2 (string->number old-val))))))) (debug:print 0 *default-log-port* "NOTE: increasing poll interval from "old-val" to "new-val) (iup:attribute-set! *tim* "TIME" new-val)) ) (dboard:tabdat-allruns-set! tabdat new-res) maxtests) (if (> (dboard:rundat-run-data-offset run-struct) 0) (loop run tal new-res newmaxtests) ;; not done getting data for this run (loop (car tal)(cdr tal) new-res newmaxtests))))))) (dboard:tabdat-filters-changed-set! tabdat #f) (dboard:areas-update-tree tabdat runs-hash header tb))) ;; runs update-rundat using the various filters from the gui ;; (define (dashboard:areas-do-update-rundat tabdat) (dboard:areas-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" "%/%") ;; generate key patterns from the target stored in tabdat (let* ((dbkeys (dboard:tabdat-dbkeys tabdat))) (let ((fres (if (dboard:tabdat-target tabdat) (let ((ptparts (append (dboard:tabdat-target tabdat)(make-list (length dbkeys) "%")))) (map (lambda (k v)(list k v)) dbkeys ptparts)) (let ((res '())) (for-each (lambda (key) (if (not (equal? key "runname")) (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f))) (if val (set! res (cons (list key val) res)))))) dbkeys) res)))) fres)))) (define (dashboard:areas-get-runs-hash tabdat) (let* ((access-mode (dboard:tabdat-access-mode tabdat)) (last-runs-update 0);;(dboard:tabdat-last-runs-update tabdat)) (runs-dat (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (runs (vector-ref runs-dat 1)) (run-id (dboard:tabdat-curr-run-id tabdat)) (runs-hash (let ((ht (make-hash-table))) (for-each (lambda (run) (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) runs) ht))) runs-hash)) ;; DOES NOT WORK RELIABLY WITH /tmp WAL mode files. Timestamps only change when the db ;; is closed (I think). If db dir starts with /tmp always return true ;; (define (dashboard:areas-database-changed? commondat tabdat #!key (context-key 'default)) (let* ((run-update-time (current-seconds)) (dbdir (dboard:tabdat-dbdir tabdat)) (modtime (dashboard:areas-get-youngest-run-db-mod-time dbdir)) (recalc (dashboard:areas-recalc modtime (dboard:commondat-please-update commondat) (dboard:get-last-db-update tabdat context-key)))) ;; (dboard:tabdat-last-db-update tabdat)))) (if recalc (dboard:set-last-db-update! tabdat context-key run-update-time)) (dboard:commondat-please-update-set! commondat #f) recalc)) ;; open the area dbs, given list of areas that are "cared about" ;; areas: '( (area_name . path) ... ) ;; NOT necessarily the section [areas] from megatest.config ;; (define (dboard:areas-open-areas commondat tabdat areas) (let ((areas-ht (dboard:commondat-areas commondat))) (for-each (lambda (area-dat) (db:dashboard-open-db areas (car area-dat)(cdr area-dat))) areas))) (define (dboard:areas-update-tree tabdat runs-hash runs-header tb) (let* ((tree-path (dboard:tabdat-tree-path tabdat)) ;; (access-mode (dboard:tabdat-access-mode tabdat)) ;; (run-ids (sort (filter number? (hash-table-keys runs-hash)) ;; (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 runs-header "event_time")) ;; (time-b (db:get-value-by-header record-b runs-header "event_time"))) ;; (< time-a time-b))))) ;; (changed #f) ;; (last-runs-update (dboard:tabdat-last-runs-update tabdat)) ;; (runs-dat (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f 0)) ;; last-runs-update)) ;; (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records ;; (runs (vector-ref runs-dat 1)) ;; (new-run-ids (map (lambda (run) ;; (db:get-value-by-header run runs-header "id")) ;; runs)) (areas (configf:get-section *configdat* "areas"))) (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) (for-each (lambda (area) (let ((run-path (list area))) (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f)) (begin (tree:add-node tb "Areas" run-path) (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path 0))))) (map car areas)) ;; here the local area ;;(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 runs-header key)) ;; (dboard:tabdat-keys tabdat))) ;; (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 (cons "local " (append key-vals (list run-name))))) ;; (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f)) ;; ;; (let ((existing (tree:find-node tb run-path))) ;; ;; (if (not existing) ;; (begin ;; (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path) ;; ;; (iup:attribute-set! (dboard:tabdat-runs-matrix tabdat) ;; ;; (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 "Areas" run-path) ;; (append key-vals (list run-name)) ;; ;; userdata: (conc "run-id: " run-id)))) ;; (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id) ;; ;; (set! colnum (+ colnum 1)) ;; )))) ;; (append new-run-ids run-ids)))) ;; for-each run-id )) (define (dashboard:areas-run-id->tests-mindat run-id tabdat runs-hash) (let* ((run (hash-table-ref/default runs-hash run-id #f)) (key-vals (mrmt:get-key-vals run-id)) (testnamepatt (or (dboard:tabdat-test-patts tabdat) "%/%")) (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) (tests-dat (dashboard:tests-ht->tests-dat tests-ht)) (tests-mindat (dcommon:minimize-test-data tests-dat))) ;; reduces data for display (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) (hash-table-set! (dboard:tabdat-last-test-dat tabdat) run-id tests-dat) (hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- (current-seconds) 10)) (when (not run) (debug:print-info 13 *default-log-port* "ERROR: NO RUN FOR RUN-ID run-id="run-id) (debug:print-info 13 *default-log-port* "runs-hash-> " (hash-table->alist runs-hash)) ) tests-mindat)) (define (dashboard:areas-runs-summary-xor-matrix-content tabdat runs-hash #!key (hide-clean #f)) (let* ((src-run-id (dboard:tabdat-prev-run-id tabdat)) (dest-run-id (dboard:tabdat-curr-run-id tabdat))) (if (and src-run-id dest-run-id) (dcommon:xor-tests-mindat (dashboard:run-id->tests-mindat src-run-id tabdat runs-hash) (dashboard:run-id->tests-mindat dest-run-id tabdat runs-hash) hide-clean: hide-clean) #f))) (define (dashboard:areas-popup-menu run-id test-id target runname test-name testpatt item-test-path test-info) (iup:menu (iup:menu-item "Test Control Panel" #:action (lambda (obj) (let* ((toolpath (car (argv))) (testpanel-cmd (conc toolpath " -test " run-id "," test-id " &"))) (system testpanel-cmd) ))) (iup:menu-item (conc "View Log " item-test-path) #:action (lambda (obj) (let* ((rundir (db:test-get-rundir test-info)) (logf (db:test-get-final_logf test-info)) (fullfile (conc rundir "/" logf))) (if (common:file-exists? fullfile) (dcommon:run-html-viewer fullfile) (message-window (conc "file " fullfile " not found."))))) ) (let* ((steps (tests:get-compressed-steps run-id test-id)) ;; #<stepname start end status Duration Logfile Comment id> (rundir (db:test-get-rundir test-info))) (iup:menu-item "Step logs" (apply iup:menu (map (lambda (step) (let ((stepname (vector-ref step 0)) (logfile (vector-ref step 5)) (status (vector-ref step 3))) (iup:menu-item (conc stepname "/" (if (string=? logfile "") "no log!" logfile) " (" status ")") #:action (lambda (obj) (let ((fullfile (conc rundir "/" logfile))) (if (common:file-exists? fullfile) (dcommon:run-html-viewer fullfile) (message-window (conc "file " fullfile " not found")))))))) steps)))) (iup:menu-item (conc "Rerun " item-test-path) #:action (lambda (obj) (common:run-a-command (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target " -runname " runname " -testpatt " item-test-path " -preclean -clean-cache")))) (iup:menu-item "Start xterm" #:action (lambda (obj) (dcommon:examine-xterm run-id test-id))) (iup:menu-item (conc "Kill " item-test-path) #:action (lambda (obj) ;; (mrmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f) (common:run-a-command (conc "megatest -set-state-status KILLREQ,n/a -target " target " -runname " runname " -testpatt " item-test-path " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED")))) (iup:menu-item "Run" (iup:menu (iup:menu-item (conc "Rerun " testpatt) #:action (lambda (obj) ;; (print " run-id: " run-id " test-id: " test-id " target: " target " runname: " runname " test-name: " test-name " testpatt: " testpatt "item-path : " item-path) (common:run-a-command (conc "megatest -run -target " target " -runname " runname " -testpatt " testpatt " -preclean -clean-cache") ))) (iup:menu-item "Rerun Complete Run" #:action (lambda (obj) (common:run-a-command (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target " -runname " runname " -testpatt % " " -preclean -clean-cache")))) (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 "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,NOT_STARTED")))) (iup:menu-item "Delete Run Data" #:action (lambda (obj) (common:run-a-command (conc "megatest -remove-runs -target " target " -runname " runname " -testpatt % " " -keep-records")))))) (iup:menu-item "Test" (iup:menu (iup:menu-item (conc "Rerun " item-test-path) #:action (lambda (obj) (common:run-a-command (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target " -runname " runname " -testpatt " item-test-path " -preclean -clean-cache")))) (iup:menu-item (conc "Kill " item-test-path) #:action (lambda (obj) ;; (mrmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f) (common:run-a-command (conc "megatest -set-state-status KILLREQ,n/a -target " target " -runname " runname " -testpatt " item-test-path " -state RUNNING,REMOTEHOSTSTART,LAUNCHED")))) (iup:menu-item (conc "Delete data : " item-test-path) #:action (lambda (obj) (common:run-a-command (conc "megatest -remove-runs -target " target " -runname " runname " -testpatt " item-test-path " -keep-records")))) (iup:menu-item (conc "Clean "item-test-path) #:action (lambda (obj) (common:run-a-command (conc "megatest -remove-runs -target " target " -runname " runname " -testpatt " item-test-path)))) (iup:menu-item "Start xterm" #:action (lambda (obj) (dcommon:examine-xterm run-id test-id))) ;;(let* ((cmd (conc (car (argv)) " -xterm " run-id "," test-id "&"))) ;; (system cmd)))) (iup:menu-item "Edit testconfig" #:action (lambda (obj) (let* ((all-tests (tests:get-all)) (editor-rx (or (configf:lookup *configdat* "setup" "editor-regex") "\\b(vim?|nano|pico)\\b")) (editor (or (configf:lookup *configdat* "setup" "editor") (get-environment-variable "VISUAL") (get-environment-variable "EDITOR") "vi")) (tconfig (conc (hash-table-ref all-tests test-name) "/testconfig")) (cmd (conc (if (string-search editor-rx editor) (conc "xterm -e " editor) editor) " " tconfig " &"))) (system cmd)))) )))) (define (dashboard:areas-get-youngest-run-db-mod-time dbdir) (handle-exceptions exn (begin (debug:print 2 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn) " db-dir="dbdir) (current-seconds)) ;; something went wrong - just print an error and return current-seconds (common:max (map (lambda (filen) (file-modification-time filen)) (glob (conc dbdir "/*.db*")))))) (define (dashboard:areas-recalc modtime please-update-buttons last-db-update-time) (or please-update-buttons (and ;; (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) ;; can't use this - it needs to be tab specific (> modtime (- last-db-update-time 3)) ;; add three seconds of margin (> (current-seconds)(+ last-db-update-time 1))))) ;; setup buttons and callbacks to switch between modes in runs summary tab ;; (define (dashboard:areas-summary-control-panel tabdat) (let* ((summary-buttons ;; build buttons (map (lambda (mode-item) (let* ((this-mode (car mode-item)) (this-mode-label (cdr mode-item))) (iup:button this-mode-label #:action (lambda (obj) (debug:catch-and-dump (lambda () (dboard:tabdat-runs-summary-mode-set! tabdat this-mode) (dboard:areas-summary-control-panel-updater tabdat)) "runs summary control panel updater"))))) (dboard:tabdat-runs-summary-modes tabdat))) (summary-buttons-hbox (apply iup:hbox summary-buttons)) (xor-runname-labels-hbox (iup:hbox (let ((temp-label (iup:label "" #:size "125x15" #:fontsize "10" ))) (dboard:tabdat-runs-summary-source-runname-label-set! tabdat temp-label) temp-label ) (let ((temp-label (iup:label "" #:size "125x15" #:fontsize "10"))) (dboard:tabdat-runs-summary-dest-runname-label-set! tabdat temp-label) temp-label)))) (dboard:tabdat-runs-summary-mode-buttons-set! tabdat summary-buttons) ;; maybe wrap in a frame (let ((res (iup:vbox summary-buttons-hbox xor-runname-labels-hbox ))) (dboard:areas-summary-control-panel-updater tabdat) res ))) (define (dboard:areas-summary-control-panel-updater tabdat) (dboard:areas-summary-xor-labels-updater tabdat) (dboard:areas-summary-buttons-updater tabdat)) (define (dboard:areas-summary-xor-labels-updater tabdat) (let ((source-runname-label (dboard:tabdat-runs-summary-source-runname-label tabdat)) (dest-runname-label (dboard:tabdat-runs-summary-dest-runname-label tabdat)) (mode (dboard:tabdat-runs-summary-mode tabdat))) (when (and source-runname-label dest-runname-label) (case mode ((xor-two-runs xor-two-runs-hide-clean) (let* ((curr-run-id (dboard:tabdat-curr-run-id tabdat)) (prev-run-id (dboard:tabdat-prev-run-id tabdat)) (curr-runname (if curr-run-id (mrmt:get-run-name-from-id curr-run-id) "None")) (prev-runname (if prev-run-id (mrmt:get-run-name-from-id prev-run-id) "None"))) (iup:attribute-set! source-runname-label "TITLE" (conc " SRC: "prev-runname" ")) (iup:attribute-set! dest-runname-label "TITLE" (conc "DEST: "curr-runname" ")))) (else (iup:attribute-set! source-runname-label "TITLE" "") (iup:attribute-set! dest-runname-label "TITLE" "")))))) (define (dboard:areas-summary-buttons-updater tabdat) (let loop ((buttons-left (dboard:tabdat-runs-summary-mode-buttons tabdat)) (modes-left (dboard:tabdat-runs-summary-modes tabdat))) (if (or (null? buttons-left) (null? modes-left)) #t (let* ((this-button (car buttons-left)) (mode-item (car modes-left)) (this-mode (car mode-item)) (sel-color "180 100 100") (nonsel-color "170 170 170") (current-mode (dboard:tabdat-runs-summary-mode tabdat))) (if (eq? this-mode current-mode) (iup:attribute-set! this-button "BGCOLOR" sel-color) (iup:attribute-set! this-button "BGCOLOR" nonsel-color)) (loop (cdr buttons-left) (cdr modes-left)))))) |
Modified dashboard.scm from [bc58b4cb6e] to [7bc58d3172].
︙ | ︙ | |||
20 21 22 23 24 25 26 | (use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors) ;; defstruct (import (prefix sqlite3 sqlite3:)) (declare (uses common)) (declare (uses margs)) (declare (uses keys)) (declare (uses items)) | | > | < | 20 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 | (use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors) ;; defstruct (import (prefix sqlite3 sqlite3:)) (declare (uses common)) (declare (uses margs)) (declare (uses keys)) (declare (uses items)) ;; (declare (uses db)) (declare (uses configf)) (declare (uses process)) (declare (uses launch)) (declare (uses runs)) (declare (uses dashboard-tests)) (declare (uses dashboard-guimonitor)) (declare (uses tree)) (declare (uses dcommon)) (declare (uses vg)) ;; (declare (uses dashboard-main)) (declare (uses megatest-version)) (declare (uses mrmt)) ;; (declare (uses mt)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") (include "task_records.scm") (include "megatest-fossil-hash.scm") (include "vg_records.scm") (define help (conc "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " license GPL, Copyright (C) Matt Welland 2012-2016 Usage: dashboard [options] -h : this help -test run-id,test-id : control test identified by testid -skip-version-check : skip the version check Misc -rows R : set number of rows -cols C : set number of columns ")) ;; -server host:port : connect to host:port instead of db access |
︙ | ︙ | |||
80 81 82 83 84 85 86 | ) (list "-h" "-use-server" "-guimonitor" "-main" "-v" "-q" | | | | | | | | | > > | > > | | | | | | | > > | < < < < < < < < < < | 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 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 | ) (list "-h" "-use-server" "-guimonitor" "-main" "-v" "-q" ;; "-use-db-cache" "-skip-version-check" "-repl" "-rh5.11" ;; fix to allow running on rh5.11 ) args:arg-hash 0)) (if (not (null? remargs)) (begin (print "Unrecognised arguments: " (string-intersperse remargs " ")) (exit))) (if (args:get-arg "-h") (begin (print help) (exit))) ;; TODO: Move this inside (main) ;; ;; (if (not (launch:setup)) ;; (begin ;; (print "Failed to find megatest.config, exiting") ;; (exit 1))) ;; deal with RH 5.11 gtk lib or iup lib missing detachbox feature ;; first check for the switch ;; (if (or (args:get-arg "-rh5.11") (configf:lookup *configdat* "dashboard" "no-detachbox")) (set! iup:detachbox iup:vbox)) ;; (if (not (common:on-homehost?)) ;; (begin ;; (debug:print 0 *default-log-port* "WARNING: Current policy requires running dashboard on homehost: " (common:get-homehost)))) ;; RA => Might require revert for filters ;; create a watch dog to move changes from lt/.db/*.db to megatest.db ;; ;;;(if (file-write-access? (conc *toppath* "/megatest.db")) ;;(debug:print-info 13 *default-log-port* "Before common:watchdog spawn") ;; (thread-start! (make-thread common:watchdog "Watchdog thread")) ;;(debug:print-info 13 *default-log-port* "After common:watchdog spawn") ;; (if (not (args:get-arg "-use-db-cache")) ;; (begin ;; (debug:print-info 0 *default-log-port* "Forcing db-cache mode due to read-only access to megatest.db") ;; (hash-table-set! args:arg-hash "-use-db-cache" #t)));;;) ;;) ;; data common to all tabs goes here ;; (defstruct dboard:commondat ((curr-tab-num 0) : number) please-update (tabdats (make-hash-table)) (update-mutex (make-mutex)) (updaters (make-hash-table)) (updating #f) uidat ;; needs to move to tabdat at some time (hide-not-hide-tabs #f) (current-area-path #f) ;; the area of the path where the dashboard was started, if it is a megatest area (areas (make-hash-table)) ;; area-name ==> dbstruct ;; (area-dbs #f) ;; use db:dashboard-open-db to add areas to the areas hash ) ;; 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)) (let* ((tnum (or tab-num (dboard:commondat-curr-tab-num commondat) 0)) ;; tab-num value is curr-tab-num value in passed commondat |
︙ | ︙ | |||
306 307 308 309 310 311 312 | ;; 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) | < | > | > > > | 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 | ;; 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) ;; Areas summary view (tree-path '()) (pivots #f) (filters #f) (view-dat (hh:make-hh)) ;; hierarchial hash of the data to view ) ;; register tabdat with BBpp ;; this is used by BBpp (Brandon's pretty printer) to convert dboard:tabdat into a composition of lists that pp will handle (hash-table-set! *BBpp_custom_expanders_list* TABDAT: (cons dboard:tabdat? (lambda (tabdat-item) |
︙ | ︙ | |||
340 341 342 343 344 345 346 | (define (dboard:tabdat-make-data) (let ((dat (make-dboard:tabdat))) (dboard:setup-tabdat dat) (dboard:setup-num-rows dat) dat)) (define (dboard:setup-tabdat tabdat) | | | | > | > | | | 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 | (define (dboard:tabdat-make-data) (let ((dat (make-dboard:tabdat))) (dboard:setup-tabdat dat) (dboard:setup-num-rows dat) dat)) (define (dboard:setup-tabdat tabdat) ;; (dboard:tabdat-dbdir-set! tabdat (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) ;; (dboard:tabdat-dbfpath-set! tabdat (db:dbfile-path)) ;; (dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db")) ;; HACK ALERT: this is a hack, please fix. (if #f (dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat)))) (print "FIXME on line 350")) (dboard:tabdat-keys-set! tabdat (mrmt:get-keys)) (dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname"))) (dboard:tabdat-tot-runs-set! tabdat (mrmt:get-num-runs "%")) ) ;; RADT => Matrix defstruct addition (defstruct dboard:graph-dat ((id #f) : string) ((color #f) : vector) ((flag #t) : boolean) |
︙ | ︙ | |||
375 376 377 378 379 380 381 | (define (dboard:runsdat-make-init) (make-dboard:runsdat runs-index: (make-hash-table) tests-index: (make-hash-table) matrix-dat: (make-sparse-array))) | | | 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 | (define (dboard:runsdat-make-init) (make-dboard:runsdat runs-index: (make-hash-table) tests-index: (make-hash-table) matrix-dat: (make-sparse-array))) ;; used to keep the rundata from mrmt:get-tests-for-run ;; in sync. ;; (defstruct dboard:rundat run tests-drawn ;; list of id's already drawn on screen tests-notdrawn ;; list of id's NOT already drawn rowsused ;; hash of lists covering what areas used - replace with quadtree |
︙ | ︙ | |||
575 576 577 578 579 580 581 | db-pth))) (db-mod-time (common:lazy-sqlite-db-modification-time db-path)) (db-modified (>= db-mod-time last-db-time)) (multi-get (> (dboard:rundat-run-data-offset run-dat) 0)) ;; multi-get in progress (tmptests (if (or do-not-use-db-file-timestamps (dboard:tabdat-filters-changed tabdat) db-modified) | | | 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 | db-pth))) (db-mod-time (common:lazy-sqlite-db-modification-time db-path)) (db-modified (>= db-mod-time last-db-time)) (multi-get (> (dboard:rundat-run-data-offset run-dat) 0)) ;; multi-get in progress (tmptests (if (or do-not-use-db-file-timestamps (dboard:tabdat-filters-changed tabdat) db-modified) (mrmt:get-tests-for-run run-id testnamepatt states statuses ;; run-id testpatt states statuses (dboard:rundat-run-data-offset run-dat) ;; query offset num-to-get (dboard:tabdat-hide-not-hide tabdat) ;; no-in sort-by ;; sort-by sort-order ;; sort-order #f ;; 'shortlist ;; qrytype last-update ;; last-update |
︙ | ︙ | |||
649 650 651 652 653 654 655 | ;; this calls dboard:get-tests-for-run-duplicate for each run ;; ;; create a virtual table of all the tests ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; (define (update-rundat tabdat runnamepatt numruns testnamepatt keypatts) (let* ((access-mode (dboard:tabdat-access-mode tabdat)) | | | | | | 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 | ;; this calls dboard:get-tests-for-run-duplicate for each run ;; ;; create a virtual table of all the tests ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; (define (update-rundat tabdat runnamepatt numruns testnamepatt keypatts) (let* ((access-mode (dboard:tabdat-access-mode tabdat)) (keys (mrmt:get-keys)) (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2)) (allruns (mrmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) ;;(allruns-tree (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) (allruns-tree (mrmt:get-runs-by-patt keys "%" #f #f #f #f last-runs-update)) ;;'("id" "runname") (header (db:get-header allruns)) (runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected (runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs (start-time (current-seconds)) (runs-hash (let ((ht (make-hash-table))) (for-each (lambda (run) (hash-table-set! ht (db:get-value-by-header run header "id") run)) |
︙ | ︙ | |||
684 685 686 687 688 689 690 | (let loop ((run (car runs)) (tal (cdr runs)) (res '()) (maxtests 0)) (let* ((run-id (db:get-value-by-header run header "id")) (run-struct (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)) (last-update (if run-struct (dboard:rundat-last-update run-struct) 0)) | | | 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 | (let loop ((run (car runs)) (tal (cdr runs)) (res '()) (maxtests 0)) (let* ((run-id (db:get-value-by-header run header "id")) (run-struct (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)) (last-update (if run-struct (dboard:rundat-last-update run-struct) 0)) (key-vals (mrmt:get-key-vals run-id)) (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate ;; dboard:get-tests-for-run-duplicate - returns a hash table ;; (dboard:get-tests-dat tabdat run-id last-update)) (all-test-ids (hash-table-keys tests-ht)) (num-tests (length all-test-ids))) ;; (print "run-struct: " run-struct) |
︙ | ︙ | |||
728 729 730 731 732 733 734 | ;; this calls dboard:get-tests-for-run-duplicate for each run ;; ;; create a virtual table of all the tests ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; (define (dboard:update-rundat tabdat runnamepatt numruns testnamepatt keypatts) (let* ((access-mode (dboard:tabdat-access-mode tabdat)) | | | | | | 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 | ;; this calls dboard:get-tests-for-run-duplicate for each run ;; ;; create a virtual table of all the tests ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; (define (dboard:update-rundat tabdat runnamepatt numruns testnamepatt keypatts) (let* ((access-mode (dboard:tabdat-access-mode tabdat)) (keys (dboard:tabdat-keys tabdat)) ;; (db:dispatch-query access-mode mrmt:get-keys db:get-keys))) (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2)) (allruns (mrmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) ;;(allruns-tree (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) (allruns-tree (mrmt:get-runs-by-patt keys "%" #f #f #f #f 0)) ;; last-runs-update));;'("id" "runname") (header (db:get-header allruns)) (runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected (runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs (start-time (current-seconds)) (runs-hash (let ((ht (make-hash-table))) (for-each (lambda (run) (hash-table-set! ht (db:get-value-by-header run header "id") run)) |
︙ | ︙ | |||
761 762 763 764 765 766 767 | (let loop ((run (car runs)) (tal (cdr runs)) (res '()) (maxtests 0)) (let* ((run-id (db:get-value-by-header run header "id")) (run-struct (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)) ;; (last-update (if run-struct (dboard:rundat-last-update run-struct) 0)) | | | 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 | (let loop ((run (car runs)) (tal (cdr runs)) (res '()) (maxtests 0)) (let* ((run-id (db:get-value-by-header run header "id")) (run-struct (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)) ;; (last-update (if run-struct (dboard:rundat-last-update run-struct) 0)) (key-vals (mrmt:get-key-vals run-id)) (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate ;; dboard:get-tests-for-run-duplicate - returns a hash table ;; (dboard:get-tests-dat tabdat run-id last-update)) (all-test-ids (hash-table-keys tests-ht)) (num-tests (length all-test-ids))) ;; (print "run-struct: " run-struct) |
︙ | ︙ | |||
1153 1154 1155 1156 1157 1158 1159 | (let ((newval (car values))) (iup:attribute-set! lb "VALUE" newval) newval)))))) (define (dashboard:update-target-selector tabdat #!key (action-proc #f)) (let* ((runconf-targs (common:get-runconfig-targets)) (key-lbs (dboard:tabdat-key-listboxes tabdat)) | | | 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 | (let ((newval (car values))) (iup:attribute-set! lb "VALUE" newval) newval)))))) (define (dashboard:update-target-selector tabdat #!key (action-proc #f)) (let* ((runconf-targs (common:get-runconfig-targets)) (key-lbs (dboard:tabdat-key-listboxes tabdat)) (db-target-dat (mrmt:get-targets)) (header (vector-ref db-target-dat 0)) (db-targets (vector-ref db-target-dat 1)) (munge-target (lambda (x) ;; create a target vector from a string. Pad with na if needed. (list->vector (take (append (string-split x "/") (make-list (length header) "na")) (length header))))) |
︙ | ︙ | |||
1326 1327 1328 1329 1330 1331 1332 | (dashboard:update-run-command tabdat))) ;; used by run-controls ;; (define (dashboard:update-tree-selector tabdat #!key (action-proc #f)) (let* ((tb (dboard:tabdat-runs-tree tabdat)) (runconf-targs (common:get-runconfig-targets)) | | | 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 | (dashboard:update-run-command tabdat))) ;; used by run-controls ;; (define (dashboard:update-tree-selector tabdat #!key (action-proc #f)) (let* ((tb (dboard:tabdat-runs-tree tabdat)) (runconf-targs (common:get-runconfig-targets)) (db-target-dat (mrmt:get-targets)) (runs-tree-ht (dboard:tabdat-runs-tree-ht tabdat)) (header (vector-ref db-target-dat 0)) (db-targets (vector-ref db-target-dat 1)) (munge-target (lambda (x) ;; create a target vector from a string. Pad with na if needed. (take (append (string-split x "/") (make-list (length header) "na")) (length header)))) |
︙ | ︙ | |||
1634 1635 1636 1637 1638 1639 1640 | (define (tree-path->run-id tabdat path) (if (not (null? path)) (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) path #f) #f)) ;; (define (dboard:get-tests-dat tabdat run-id last-update) ;; (let* ((access-mode (dboard:tabdat-access-mode tabdat)) | | | 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 | (define (tree-path->run-id tabdat path) (if (not (null? path)) (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) path #f) #f)) ;; (define (dboard:get-tests-dat tabdat run-id last-update) ;; (let* ((access-mode (dboard:tabdat-access-mode tabdat)) ;; (tdat (if run-id (db:dispatch-query access-mode mrmt:get-tests-for-run db:get-tests-for-run ;; run-id ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") ;; (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)) ;; '() ;; (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)) ;; '() ;; #f #f ;; offset limit ;; (dboard:tabdat-hide-not-hide tabdat) ;; not-in ;; #f #f ;; sort-by sort-order |
︙ | ︙ | |||
1675 1676 1677 1678 1679 1680 1681 | (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 runs-header "event_time")) (time-b (db:get-value-by-header record-b runs-header "event_time"))) (< time-a time-b))))) (changed #f) | | | | 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 | (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 runs-header "event_time")) (time-b (db:get-value-by-header record-b runs-header "event_time"))) (< time-a time-b))))) (changed #f) (last-runs-update (dboard:tabdat-last-runs-update tabdat))) ;; (runs-dat (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))) (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) (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 runs-header key)) (dboard:tabdat-keys tabdat))) (run-name (db:get-value-by-header run-record runs-header "runname")) (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) |
︙ | ︙ | |||
1719 1720 1721 1722 1723 1724 1725 | ((> 0 (string-compare3 a-test-name b-test-name)) #f) ((< 0 (string-compare3 a-item-path b-item-path)) #t) (else #f))))))) (define (dashboard:run-id->tests-mindat run-id tabdat runs-hash) (let* ((run (hash-table-ref/default runs-hash run-id #f)) | | | 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 | ((> 0 (string-compare3 a-test-name b-test-name)) #f) ((< 0 (string-compare3 a-item-path b-item-path)) #t) (else #f))))))) (define (dashboard:run-id->tests-mindat run-id tabdat runs-hash) (let* ((run (hash-table-ref/default runs-hash run-id #f)) (key-vals (mrmt:get-key-vals run-id)) (testnamepatt (or (dboard:tabdat-test-patts tabdat) "%/%")) (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) (tests-dat (dashboard:tests-ht->tests-dat tests-ht)) (tests-mindat (dcommon:minimize-test-data tests-dat))) ;; reduces data for display (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) (hash-table-set! (dboard:tabdat-last-test-dat tabdat) run-id tests-dat) (hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- (current-seconds) 10)) |
︙ | ︙ | |||
1747 1748 1749 1750 1751 1752 1753 | hide-clean: hide-clean) #f))) (define (dashboard:get-runs-hash tabdat) (let* ((access-mode (dboard:tabdat-access-mode tabdat)) (last-runs-update 0);;(dboard:tabdat-last-runs-update tabdat)) | | | | 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 | hide-clean: hide-clean) #f))) (define (dashboard:get-runs-hash tabdat) (let* ((access-mode (dboard:tabdat-access-mode tabdat)) (last-runs-update 0);;(dboard:tabdat-last-runs-update tabdat)) (runs-dat (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (runs (vector-ref runs-dat 1)) (run-id (dboard:tabdat-curr-run-id tabdat)) (runs-hash (let ((ht (make-hash-table))) (for-each (lambda (run) (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) runs) ht))) runs-hash)) (define (dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix) ;; (if (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-rundat) (dashboard:do-update-rundat tabdat) ;; ) (dboard:runs-summary-control-panel-updater tabdat) (let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat)) (runs-dat (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (runs (vector-ref runs-dat 1)) (run-id (dboard:tabdat-curr-run-id tabdat)) (runs-hash (dashboard:get-runs-hash tabdat)) ;; (runs-hash (let ((ht (make-hash-table))) ;; (for-each (lambda (run) ;; (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) |
︙ | ︙ | |||
1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 | (if (and (eq? pass-num 0) changed) (loop 1 #t)) ;; force second pass due to column labels changing ;; (debug:print 0 *default-log-port* "runs-summary-updater, changed: " changed " pass-num: " pass-num) ;; (print "runs-summary-updater, changed: " changed " pass-num: " pass-num) (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL"))))))))) ;;====================================================================== ;; S U M M A R Y ;;====================================================================== ;; ;; General info about the run(s) and megatest area (define (dashboard:summary commondat tabdat #!key (tab-num #f)) | > | 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 | (if (and (eq? pass-num 0) changed) (loop 1 #t)) ;; force second pass due to column labels changing ;; (debug:print 0 *default-log-port* "runs-summary-updater, changed: " changed " pass-num: " pass-num) ;; (print "runs-summary-updater, changed: " changed " pass-num: " pass-num) (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL"))))))))) ;;====================================================================== ;; S U M M A R Y ;;====================================================================== ;; ;; General info about the run(s) and megatest area (define (dashboard:summary commondat tabdat #!key (tab-num #f)) |
︙ | ︙ | |||
1996 1997 1998 1999 2000 2001 2002 | (mode (dboard:tabdat-runs-summary-mode tabdat))) (when (and source-runname-label dest-runname-label) (case mode ((xor-two-runs xor-two-runs-hide-clean) (let* ((curr-run-id (dboard:tabdat-curr-run-id tabdat)) (prev-run-id (dboard:tabdat-prev-run-id tabdat)) (curr-runname (if curr-run-id | | | | 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 | (mode (dboard:tabdat-runs-summary-mode tabdat))) (when (and source-runname-label dest-runname-label) (case mode ((xor-two-runs xor-two-runs-hide-clean) (let* ((curr-run-id (dboard:tabdat-curr-run-id tabdat)) (prev-run-id (dboard:tabdat-prev-run-id tabdat)) (curr-runname (if curr-run-id (mrmt:get-run-name-from-id curr-run-id) "None")) (prev-runname (if prev-run-id (mrmt:get-run-name-from-id prev-run-id) "None"))) (iup:attribute-set! source-runname-label "TITLE" (conc " SRC: "prev-runname" ")) (iup:attribute-set! dest-runname-label "TITLE" (conc "DEST: "curr-runname" ")))) (else (iup:attribute-set! source-runname-label "TITLE" "") (iup:attribute-set! dest-runname-label "TITLE" "")))))) |
︙ | ︙ | |||
2048 2049 2050 2051 2052 2053 2054 | (dboard:tabdat-runs-summary-mode-buttons-set! tabdat summary-buttons) ;; maybe wrap in a frame (let ((res (iup:vbox summary-buttons-hbox xor-runname-labels-hbox ))) (dboard:runs-summary-control-panel-updater tabdat) res ))) | < < | 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 | (dboard:tabdat-runs-summary-mode-buttons-set! tabdat summary-buttons) ;; maybe wrap in a frame (let ((res (iup:vbox summary-buttons-hbox xor-runname-labels-hbox ))) (dboard:runs-summary-control-panel-updater tabdat) res ))) ;;====================================================================== ;; R U N ;;====================================================================== ;; ;; display and manage a single run at a time |
︙ | ︙ | |||
2107 2108 2109 2110 2111 2112 2113 | (debug:print-info 13 *default-log-port* "click-cb: obj="obj" lin="lin" col="col" status="status) ;; status is corrupted on Brandon's home machine. will have to wait until after shutdown to see if it is still broken in PDX SLES (let* ((toolpath (car (argv))) (key (conc lin ":" col)) (test-id (hash-table-ref/default cell-lookup key -1)) (run-id (dboard:tabdat-curr-run-id tabdat)) | | | | | | | 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 | (debug:print-info 13 *default-log-port* "click-cb: obj="obj" lin="lin" col="col" status="status) ;; status is corrupted on Brandon's home machine. will have to wait until after shutdown to see if it is still broken in PDX SLES (let* ((toolpath (car (argv))) (key (conc lin ":" col)) (test-id (hash-table-ref/default cell-lookup key -1)) (run-id (dboard:tabdat-curr-run-id tabdat)) (run-info (mrmt:get-run-info run-id)) (target (mrmt:get-target run-id)) (runname (db:get-value-by-header (db:get-rows run-info) (db:get-header run-info) "runname")) (test-info (mrmt:get-test-info-by-id run-id test-id)) (test-name (db:test-get-testname test-info)) (testpatt (let ((tlast (mrmt:tasks-get-last target runname))) (if tlast (let ((tpatt (tasks:task-get-testpatt tlast))) (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017 "%" tpatt)) "%"))) (item-path (db:test-get-item-path (mrmt:get-test-info-by-id run-id test-id))) (item-test-path (conc test-name "/" (if (equal? item-path "") "%" item-path))) (status-chars (char-set->list (string->char-set status))) (testpanel-cmd (conc toolpath " -test " (dboard:tabdat-curr-run-id tabdat) "," test-id " &"))) (debug:print-info 13 *default-log-port* "status-chars=["status-chars"] status=["status"]") (cond |
︙ | ︙ | |||
2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 | (dboard:tabdat-runs-tree-set! tabdat tb) (iup:vbox (iup:split #:value 200 tb run-matrix) (dboard:make-controls commondat tabdat extra-widget: runs-summary-control-panel)))) ;;====================================================================== ;; R U N S ;;====================================================================== (define (dboard:squarify toggles size) (let loop ((hed (car toggles)) | > > | 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 | (dboard:tabdat-runs-tree-set! tabdat tb) (iup:vbox (iup:split #:value 200 tb run-matrix) (dboard:make-controls commondat tabdat extra-widget: runs-summary-control-panel)))) (include "dashboard-areas.scm") ;;====================================================================== ;; R U N S ;;====================================================================== (define (dboard:squarify toggles size) (let loop ((hed (car toggles)) |
︙ | ︙ | |||
2332 2333 2334 2335 2336 2337 2338 | (if (eq? val 1) (hash-table-set! (dboard:tabdat-state-ignore-hash tabdat) state #t) (hash-table-delete! (dboard:tabdat-state-ignore-hash tabdat) state)) (set-bg-on-filter commondat tabdat)))) (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED"))) (num-toggle-cols (inexact->exact (round (/ (max (length status-toggles)(length state-toggles)) 3))))) (iup:vbox | > > | | | | | | | | | | | | | | | > > > > > > > > > > > | 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 | (if (eq? val 1) (hash-table-set! (dboard:tabdat-state-ignore-hash tabdat) state #t) (hash-table-delete! (dboard:tabdat-state-ignore-hash tabdat) state)) (set-bg-on-filter commondat tabdat)))) (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED"))) (num-toggle-cols (inexact->exact (round (/ (max (length status-toggles)(length state-toggles)) 3))))) (iup:vbox (let ((filter-pivot (iup:tabs (iup:hbox (iup:frame #:title "states" (apply iup:hbox (map (lambda (colgrp) (apply iup:vbox colgrp)) (dboard:squarify state-toggles 3)))) (iup:frame #:title "statuses" (apply iup:hbox (map (lambda (colgrp) (apply iup:vbox colgrp)) (dboard:squarify status-toggles 3))))) (iup:hbox (iup:frame #:title "Rows" (iup:button "Rows pivot")) (iup:frame #:title "Cols" (iup:button "Cols pivot")))))) (iup:attribute-set! filter-pivot "TABTITLE0" "Filters") (iup:attribute-set! filter-pivot "TABTITLE1" "Pivots ") filter-pivot) ;; ;; (iup:frame ;; #:title "state/status filter" ;; (iup:vbox ;; (apply ;; iup:hbox ;; (map |
︙ | ︙ | |||
2439 2440 2441 2442 2443 2444 2445 | (lambda (obj) (dcommon:examine-xterm run-id test-id))) (iup:menu-item (conc "Kill " item-test-path) #:action (lambda (obj) | | | 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 | (lambda (obj) (dcommon:examine-xterm run-id test-id))) (iup:menu-item (conc "Kill " item-test-path) #:action (lambda (obj) ;; (mrmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f) (common:run-a-command (conc "megatest -set-state-status KILLREQ,n/a -target " target " -runname " runname " -testpatt " item-test-path " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED")))) |
︙ | ︙ | |||
2512 2513 2514 2515 2516 2517 2518 | " -runname " runname " -testpatt " item-test-path " -preclean -clean-cache")))) (iup:menu-item (conc "Kill " item-test-path) #:action (lambda (obj) | | | 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 | " -runname " runname " -testpatt " item-test-path " -preclean -clean-cache")))) (iup:menu-item (conc "Kill " item-test-path) #:action (lambda (obj) ;; (mrmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f) (common:run-a-command (conc "megatest -set-state-status KILLREQ,n/a -target " target " -runname " runname " -testpatt " item-test-path " -state RUNNING,REMOTEHOSTSTART,LAUNCHED")))) (iup:menu-item (conc "Delete data : " item-test-path) |
︙ | ︙ | |||
2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 | (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)) (header (make-vector nruns)) (lftcol (make-vector ntests)) | > | 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 | (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)) (areas-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)) (header (make-vector nruns)) (lftcol (make-vector ntests)) |
︙ | ︙ | |||
2680 2681 2682 2683 2684 2685 2686 | ;; (print "pressed= " pressed " x= " x " y= " y " rem=" rem " btn=" btn " string? " (string? btn)) (if (substring-index "3" btn) (if (eq? pressed 1) (let* ((toolpath (car (argv))) (buttndat (hash-table-ref (dboard:tabdat-buttondat runs-dat) button-key)) (test-id (db:test-get-id (vector-ref buttndat 3))) (run-id (db:test-get-run_id (vector-ref buttndat 3))) | | | | | | | 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 | ;; (print "pressed= " pressed " x= " x " y= " y " rem=" rem " btn=" btn " string? " (string? btn)) (if (substring-index "3" btn) (if (eq? pressed 1) (let* ((toolpath (car (argv))) (buttndat (hash-table-ref (dboard:tabdat-buttondat runs-dat) button-key)) (test-id (db:test-get-id (vector-ref buttndat 3))) (run-id (db:test-get-run_id (vector-ref buttndat 3))) (run-info (mrmt:get-run-info run-id)) (target (mrmt:get-target run-id)) (runname (db:get-value-by-header (db:get-rows run-info) (db:get-header run-info) "runname")) (test-info (mrmt:get-test-info-by-id run-id test-id)) (test-name (db:test-get-testname test-info)) (testpatt (let ((tlast (mrmt:tasks-get-last target runname))) (if tlast (let ((tpatt (tasks:task-get-testpatt tlast))) (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017 "%" tpatt)) "%"))) (item-path (db:test-get-item-path (mrmt:get-test-info-by-id run-id test-id))) (item-test-path (conc test-name "/" (if (equal? item-path "") "%" item-path)))) (iup:show (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu #:x 'mouse #:y 'mouse #:modal? "NO") |
︙ | ︙ | |||
2739 2740 2741 2742 2743 2744 2745 | (apply iup:hbox (reverse hdrlst)) (apply iup:hbox (reverse bdylst)) (dashboard:runs-horizontal-slider runs-dat)))) controls )) (views-cfgdat (common:load-views-config)) (additional-tabnames '()) | | | 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 | (apply iup:hbox (reverse hdrlst)) (apply iup:hbox (reverse bdylst)) (dashboard:runs-horizontal-slider runs-dat)))) controls )) (views-cfgdat (common:load-views-config)) (additional-tabnames '()) (tab-start-num 6) ;; DON'T FORGET TO UPDATE THIS WHEN CHANGING THE STANDARD TABS BELOW ;; (data (dboard:tabdat-init (make-d:data))) (additional-views ;; process views-dat (let ((tab-num tab-start-num) (result '())) (for-each (lambda (view-name) (debug:print 0 *default-log-port* "Adding view " view-name) |
︙ | ︙ | |||
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 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 | (dashboard:summary commondat stats-dat tab-num: 0) runs-view (dashboard:runs-summary commondat onerun-dat tab-num: 2) ;; (dashboard:new-view db data new-view-dat tab-num: 3) (dashboard:run-controls commondat runcontrols-dat tab-num: 3) (dashboard:run-times commondat runtimes-dat tab-num: 4) ;; (dashboard:runs-summary commondat onerun-dat tab-num: 4) additional-views))) ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) (iup:attribute-set! tabs "TABTITLE0" "Summary") (iup:attribute-set! tabs "TABTITLE1" "Runs") (iup:attribute-set! tabs "TABTITLE2" "Run Summary") (iup:attribute-set! tabs "TABTITLE3" "Run Control") (iup:attribute-set! tabs "TABTITLE4" "Run Times") ;; (iup:attribute-set! tabs "TABTITLE3" "New View") ;; (iup:attribute-set! tabs "TABTITLE4" "Run Control") ;; set the tab names for user added tabs (for-each (lambda (tab-info) (iup:attribute-set! tabs (conc "TABTITLE" (car tab-info)) (cdr tab-info))) additional-tabnames) (iup:attribute-set! tabs "BGCOLOR" "190 190 190") ;; make the iup tabs object available (for changing color for example) (dboard:commondat-hide-not-hide-tabs-set! commondat tabs) ;; now set up the tabdat lookup (dboard:common-set-tabdat! commondat 0 stats-dat) (dboard:common-set-tabdat! commondat 1 runs-dat) (dboard:common-set-tabdat! commondat 2 onerun-dat) (dboard:common-set-tabdat! commondat 3 runcontrols-dat) (dboard:common-set-tabdat! commondat 4 runtimes-dat) (iup:vbox tabs ;; controls )))) (vector keycol lftcol header runsvec))) | > > > | 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 | (dashboard:summary commondat stats-dat tab-num: 0) runs-view (dashboard:runs-summary commondat onerun-dat tab-num: 2) ;; (dashboard:new-view db data new-view-dat tab-num: 3) (dashboard:run-controls commondat runcontrols-dat tab-num: 3) (dashboard:run-times commondat runtimes-dat tab-num: 4) ;; (dashboard:runs-summary commondat onerun-dat tab-num: 4) (dashboard:areas-summary commondat areas-dat tab-num: 5) additional-views))) ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) (iup:attribute-set! tabs "TABTITLE0" "Summary") (iup:attribute-set! tabs "TABTITLE1" "Runs") (iup:attribute-set! tabs "TABTITLE2" "Run Summary") (iup:attribute-set! tabs "TABTITLE3" "Run Control") (iup:attribute-set! tabs "TABTITLE4" "Run Times") (iup:attribute-set! tabs "TABTITLE5" "Areas Summary") ;; (iup:attribute-set! tabs "TABTITLE3" "New View") ;; (iup:attribute-set! tabs "TABTITLE4" "Run Control") ;; set the tab names for user added tabs (for-each (lambda (tab-info) (iup:attribute-set! tabs (conc "TABTITLE" (car tab-info)) (cdr tab-info))) additional-tabnames) (iup:attribute-set! tabs "BGCOLOR" "190 190 190") ;; make the iup tabs object available (for changing color for example) (dboard:commondat-hide-not-hide-tabs-set! commondat tabs) ;; now set up the tabdat lookup (dboard:common-set-tabdat! commondat 0 stats-dat) (dboard:common-set-tabdat! commondat 1 runs-dat) (dboard:common-set-tabdat! commondat 2 onerun-dat) (dboard:common-set-tabdat! commondat 3 runcontrols-dat) (dboard:common-set-tabdat! commondat 4 runtimes-dat) (dboard:common-set-tabdat! commondat 5 areas-dat) (iup:vbox tabs ;; controls )))) (vector keycol lftcol header runsvec))) |
︙ | ︙ | |||
2983 2984 2985 2986 2987 2988 2989 | (db:test-get-event_time (hash-table-ref testsdat (car b)))))))))) ;; run times tab data updater ;; (define (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num) (let* ((access-mode (dboard:tabdat-access-mode tabdat)) (last-runs-update (dboard:tabdat-last-runs-update tabdat)) | | | 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 | (db:test-get-event_time (hash-table-ref testsdat (car b)))))))))) ;; run times tab data updater ;; (define (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num) (let* ((access-mode (dboard:tabdat-access-mode tabdat)) (last-runs-update (dboard:tabdat-last-runs-update tabdat)) (runs-dat (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (runs-hash (let ((ht (make-hash-table))) (for-each (lambda (run) (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) (vector-ref runs-dat 1)) ht)) (run-ids (sort (filter number? (hash-table-keys runs-hash)) |
︙ | ︙ | |||
3568 3569 3570 3571 3572 3573 3574 | "dashboard:runs-tab-updater")) ;;====================================================================== ;; The heavy lifting starts here ;;====================================================================== (define (main) | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 | "dashboard:runs-tab-updater")) ;;====================================================================== ;; The heavy lifting starts here ;;====================================================================== (define (main) ;; (let* ((areas (make-hash-table))) ;; mtdb-path (conc *toppath* "/megatest.db"))) ;; ;; (if (and (common:file-exists? mtdb-path) ;; (file-write-access? mtdb-path)) ;; (if (not (args:get-arg "-skip-version-check")) ;; (common:exit-on-version-changed))) (let* ((commondat (make-dboard:commondat))) ;; 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)) (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:commondat-curr-tab-num-set! commondat 0) (dboard:commondat-add-updater commondat (lambda () (dashboard:runs-tab-updater commondat 1)) tab-num: 1) (iup:callback-set! *tim* "ACTION_CB" (lambda (time-obj) (let ((update-is-running #f)) (mutex-lock! (dboard:commondat-update-mutex commondat)) (set! update-is-running (dboard:commondat-updating commondat)) (if (not update-is-running) (dboard:commondat-updating-set! commondat #t)) (mutex-unlock! (dboard:commondat-update-mutex commondat)) (if (not update-is-running) ;; we know that the update was not running and we now have a lock on doing an update (begin (dboard:common-run-curr-updaters commondat) ;; (dashboard:run-update commondat) (mutex-lock! (dboard:commondat-update-mutex commondat)) (dboard:commondat-updating-set! commondat #f) (mutex-unlock! (dboard:commondat-update-mutex commondat))) )) 1)))) (let ((th1 (make-thread (lambda () (thread-sleep! 1) (dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab ) "update buttons once")) (th2 (make-thread iup:main-loop "Main loop"))) (thread-start! th2) (thread-join! th2)))) ;; ease debugging by loading ~/.dashboardrc (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) (if (common:file-exists? debugcontrolf) (load debugcontrolf))) (if (args:get-arg "-repl") (repl) (main)) |
Modified db.scm from [144a083df6] to [79424c46a4].
︙ | ︙ | |||
47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 | (tmpdb #f) (dbstack #f) ;; stack for tmp db handles, do not initialize with a stack (mtdb #f) (refndb #f) (homehost #f) ;; not used yet (on-homehost #f) ;; not used yet (read-only #f) ) ;; goal is to converge on one struct for an area but for now it is too confusing ;; record for keeping state,status and count for doing roll-ups in ;; iterated tests ;; (defstruct dbr:counts (state #f) (status #f) (count 0)) ;;====================================================================== ;; SQLITE3 HELPERS ;;====================================================================== (define (db:general-sqlite-error-dump exn stmt . params) (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) ;; RADT ... how does this work? | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (tmpdb #f) (dbstack #f) ;; stack for tmp db handles, do not initialize with a stack (mtdb #f) (refndb #f) (homehost #f) ;; not used yet (on-homehost #f) ;; not used yet (read-only #f) (configdat #f) (keys #f) (area-path #f) (area-name #f) (tmpdb-path #f) ) ;; goal is to converge on one struct for an area but for now it is too confusing ;; record for keeping state,status and count for doing roll-ups in ;; iterated tests ;; (defstruct dbr:counts (state #f) (status #f) (count 0)) ;;====================================================================== ;; DASHBOARD DIRECT INTERFACE ;;====================================================================== ;; return dbstruct with: ;; read-only - flag ;; tmpdb - local to this machine, all reads to this ;; mtdb - full db from mtrah ;; no-sync-db - ;; on-homehost - enable reading from other users /tmp db if files are readable ;; ;; areas is hash of area_names => dbstruct, the dashboard-open-db will register the dbstruct in that hash ;; ;; NOTE: This returns the tmpdb path/handle pair. ;; NOTE: This does do a sync (the db:open-db proc only does an initial sync if called with do-sync: #t ;; NOTE: Longer term consider replacing db:open-db with this ;; ;; NOTE: loose ends!! ;; db:open-db -> not properly using tmpdb path ;; common:get-db-tmp-area -> using *toppath* and common:get-testsuite-area ;; (define (db:dashboard-open-db areas area-name area-path) ;; 0. check for already existing dbstruct in areas hash, return it if found ;; 1. do minimal read of megatest.config, store configdat, keys in dbstruct ;; 2. get homehost ;; 3. create /tmp db area (if needed) ;; 4. sync data to /tmp db (or update if exists) ;; 5. return dbstruct (if (hash-table-exists? areas area-name) (hash-table-ref areas area-name) (if (common:file-exists? (conc area-path "/megatest.config") quiet-mode: #t) (let* ((homehost (common:minimal-get-homehost area-path)) (on-hh (common:on-host? homehost)) (mtconfig (common:simple-setup area-path)) ;; returns ( configdat toppath configfile configf-name ) (dbstruct (make-dbr:dbstruct area-path: area-path homehost: homehost configdat: (car mtconfig))) (tmpdb (db:open-db dbstruct area-path: area-path do-sync: #t))) (hash-table-set! areas area-name dbstruct) tmpdb) (begin (debug:print-info 0 *default-log-port* "attempt to open megatest.db in " area-path " but no megatest.config found.") #f)))) ;; sync all the areas listed in area-paths ;; (define (db:dashboard-sync-dbs areas area-paths) #f) ;; close all area db's ;; (define (db:dashboard-close-dbs areas) #f) ;;====================================================================== ;; SQLITE3 HELPERS ;;====================================================================== (define (db:general-sqlite-error-dump exn stmt . params) (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) ;; RADT ... how does this work? |
︙ | ︙ | |||
85 86 87 88 89 90 91 | (begin (debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port)) default))) (apply sqlite3:first-result db stmt params))) ;; Get/open a database | < | | < < | | 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 | (begin (debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port)) default))) (apply sqlite3:first-result db stmt params))) ;; Get/open a database ;; ;; should always return ( dbh . path-to-db ) ;; (define (db:get-db dbstruct) ;; run-id) (if (stack? (dbr:dbstruct-dbstack dbstruct)) (if (stack-empty? (dbr:dbstruct-dbstack dbstruct)) (let ((newdb (db:open-megatest-db path: (dbr:dbstruct-area-path dbstruct)))) ;; (db:dbfile-path)))) ;; (stack-push! (dbr:dbstruct-dbstack dbstruct) newdb) newdb) (stack-pop! (dbr:dbstruct-dbstack dbstruct))) (db:open-db dbstruct))) ;; ;; legacy handling of structure for managing db's. Refactor this into dbr:? (define (db:dbdat-get-db dbdat) |
︙ | ︙ | |||
296 297 298 299 300 301 302 | ;; (dbr:dbstruct-inuse-set! dbstruct #t) ;; (dbr:dbstruct-olddb-set! dbstruct olddb) ;; ;;; (mutex-unlock! *rundb-mutex*) ;;; why did we need a mutex on opening db's? ;; (db:sync-tables db:sync-tests-only *megatest-db* db) ;; db)) ;; This routine creates the db if not already present. It is only called if the db is not already opened | | | > > > > | | | | 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 | ;; (dbr:dbstruct-inuse-set! dbstruct #t) ;; (dbr:dbstruct-olddb-set! dbstruct olddb) ;; ;;; (mutex-unlock! *rundb-mutex*) ;;; why did we need a mutex on opening db's? ;; (db:sync-tables db:sync-tests-only *megatest-db* db) ;; db)) ;; This routine creates the db if not already present. It is only called if the db is not already opened ;; ALWAYS returns ( dbh . path-to-db ) (define (db:open-db dbstruct #!key (area-path #f)(do-sync #t)) ;; TODO: actually use areapath (let ((tmpdb-stack (dbr:dbstruct-dbstack dbstruct))) ;; RA => Returns the first reference in dbstruct (if (stack? tmpdb-stack) (db:get-db tmpdb-stack) ;; get previously opened db (will create new db handle if all in the stack are already used (let* ((toppath (or area-path (dbr:dbstruct-area-path dbstruct) *toppath*)) (dbpath (or (dbr:dbstruct-tmpdb-path dbstruct) (db:dbfile-path dbstruct))) ;; path to tmp db area (dbexists (common:file-exists? dbpath)) (tmpdbfname (conc dbpath "/megatest.db")) (dbfexists (common:file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db"))) (mtdbexists (common:file-exists? (conc toppath "/megatest.db"))) (mtdb (db:open-megatest-db path: area-path)) (mtdbpath (db:dbdat-get-path mtdb)) (tmpdb (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db)) (refndb (db:open-megatest-db path: dbpath name: "megatest_ref.db")) (write-access (file-write-access? mtdbpath)) (mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time mtdbpath) #f)) (tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f)) (modtimedelta (and mtdbmodtime tmpdbmodtime (- mtdbmodtime tmpdbmodtime)))) |
︙ | ︙ | |||
1865 1866 1867 1868 1869 1870 1871 | (sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var)))) ;;====================================================================== ;; no-sync.db - small bits of data to be shared between servers ;;====================================================================== (define (db:open-no-sync-db) | | | 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 | (sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var)))) ;;====================================================================== ;; no-sync.db - small bits of data to be shared between servers ;;====================================================================== (define (db:open-no-sync-db) (let* ((dbpath (db:dbfile-path #f)) (dbname (conc dbpath "/no-sync.db")) (db-exists (common:file-exists? dbname)) (db (sqlite3:open-database dbname))) (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) (if (not db-exists) (begin (sqlite3:execute db "PRAGMA synchronous = 0;") |
︙ | ︙ | |||
1945 1946 1947 1948 1949 1950 1951 | ;; re-read the db over and over again for the keys since they never ;; change ;; why get the keys from the db? why not get from the *configdat* ;; using keys:config-get-fields? (define (db:get-keys dbstruct) | > | | | 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 | ;; re-read the db over and over again for the keys since they never ;; change ;; why get the keys from the db? why not get from the *configdat* ;; using keys:config-get-fields? (define (db:get-keys dbstruct) (if (dbr:dbstruct-keys dbstruct) (dbr:dbstruct-keys dbstruct) (let ((res '())) (db:with-db dbstruct #f #f (lambda (db) (sqlite3:for-each-row (lambda (key) (set! res (cons key res))) db "SELECT fieldname FROM keys ORDER BY id DESC;"))) (dbr:dbstruct-keys-set! dbstruct res) res))) ;; look up values in a header/data structure (define (db:get-value-by-header row header field) (if (or (null? header) (not row)) #f (let loop ((hed (car header)) |
︙ | ︙ | |||
2114 2115 2116 2117 2118 2119 2120 | ))) (debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) (vector header res))) ;; TODO: Switch this to use max(update_time) from each run db? Then if using a server there is no disk traffic (using inmem db) ;; (define (db:get-changed-run-ids since-time) | | | 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 | ))) (debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) (vector header res))) ;; TODO: Switch this to use max(update_time) from each run db? Then if using a server there is no disk traffic (using inmem db) ;; (define (db:get-changed-run-ids since-time) (let* ((dbdir (db:dbfile-path #f)) ;; (configf:lookup *configdat* "setup" "dbdir")) (alldbs (glob (conc dbdir "/[0-9]*.db"))) (changed (filter (lambda (dbfile) (> (file-modification-time dbfile) since-time)) alldbs))) (delete-duplicates (map (lambda (dbfile) (let* ((res (string-match ".*\\/(\\d)*\\.db" dbfile))) |
︙ | ︙ |
Modified dcommon.scm from [4a0cb449c5] to [23b1ce87bd].
︙ | ︙ | |||
16 17 18 19 20 21 22 | (import canvas-draw-iup) (use regex typed-records matchable) (declare (unit dcommon)) (declare (uses megatest-version)) (declare (uses gutils)) | | > | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | (import canvas-draw-iup) (use regex typed-records matchable) (declare (unit dcommon)) (declare (uses megatest-version)) (declare (uses gutils)) ;; (declare (uses db)) (declare (uses mrmt)) ;; (declare (uses synchash)) (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") (include "run_records.scm") |
︙ | ︙ | |||
425 426 427 428 429 430 431 | (equal? "CLEAN" (list-ref (list-ref item 2) 1)))) res) res)))) (define (dcommon:examine-xterm run-id test-id) | | | 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 | (equal? "CLEAN" (list-ref (list-ref item 2) 1)))) res) res)))) (define (dcommon:examine-xterm run-id test-id) (let* ((testdat (mrmt: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) |
︙ | ︙ | |||
542 543 544 545 546 547 548 | general-matrix)) (define (dcommon:run-stats commondat tabdat #!key (tab-num #f)) (let* ((stats-matrix (iup:matrix expand: "YES")) (changed #f) (stats-updater (lambda () (if (dashboard:database-changed? commondat tabdat context-key: 'run-stats) | | | 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 | general-matrix)) (define (dcommon:run-stats commondat tabdat #!key (tab-num #f)) (let* ((stats-matrix (iup:matrix expand: "YES")) (changed #f) (stats-updater (lambda () (if (dashboard:database-changed? commondat tabdat context-key: 'run-stats) (let* ((run-stats (mrmt:get-run-stats)) (indices (common:sparse-list-generate-index run-stats)) ;; proc: set-cell)) (row-indices (car indices)) (col-indices (cadr indices)) (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices)))) (max-visible (max (- (dboard:tabdat-num-tests tabdat) 15) 3)) |
︙ | ︙ | |||
1088 1089 1090 1091 1092 1093 1094 | (iup:attribute-set! tb "VALUE" val) (dboard:tabdat-run-name-set! tabdat val) (dashboard:update-run-command tabdat)))) "command-runname-selector lb action")))) (refresh-runs-list (lambda () (if (dashboard:database-changed? commondat tabdat context-key: 'runname-selector-runs-list) (let* (;; (target (dboard:tabdat-target-string tabdat)) | | | 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 | (iup:attribute-set! tb "VALUE" val) (dboard:tabdat-run-name-set! tabdat val) (dashboard:update-run-command tabdat)))) "command-runname-selector lb action")))) (refresh-runs-list (lambda () (if (dashboard:database-changed? commondat tabdat context-key: 'runname-selector-runs-list) (let* (;; (target (dboard:tabdat-target-string tabdat)) (runs-for-targ (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f 0)) (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)))) ;; (print "DEBUGINFO: run-names=" run-names) |
︙ | ︙ |
Modified megatest.config from [cab7834174] to [a8d97f813e].
1 2 | ## commented out due to a bug in v1.6501 in mtutil | | | | | > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | ## commented out due to a bug in v1.6501 in mtutil [fields] a text b text c text [setup] pktsdirs /tmp/pkts /some/other/source [areas] # path=path-to-area;targtrans=script_to_transform_target local path=. fullrun path=tests/fullrun # targtrans is name of scheme proc stored in .mtutil.scm, which lives in PWD where mtutil is run # ext-tests path=ext-tests; targtrans=prefix-contour; ext path=ext-tests [contours] # mode-patt/tag-expr |
︙ | ︙ |
Added mrmt.scm version [715ed41acd].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 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 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 193 194 195 196 197 198 199 200 201 202 203 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 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 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 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 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 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 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 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 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 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 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 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 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 | ;;====================================================================== ;; Copyright 2006-2017, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== (use format typed-records) ;; RADT => purpose of json format?? (declare (unit mrmt)) (declare (uses api)) ;; (declare (uses tdb)) (declare (uses http-transport)) ;;(declare (uses nmsg-transport)) (include "common_records.scm") ;; ;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!! ;; ;; generate entries for ~/.megatestrc with the following ;; ;; grep define ../rmt.scm | grep mrmt: |perl -pi -e 's/\(define\s+\((\S+)\W.*$/\1/'|sort -u ;;====================================================================== ;; S U P P O R T F U N C T I O N S ;;====================================================================== ;; if a server is either running or in the process of starting call client:setup ;; else return #f to let the calling proc know that there is no server available ;; (define (mrmt:get-connection-info areapath #!key (area-dat #f)) ;; TODO: push areapath down. (let* ((runremote (or area-dat *runremote*)) (cinfo (if (remote? runremote) (remote-conndat runremote) #f))) (if cinfo cinfo (if (server:check-if-running areapath) (client:setup areapath) #f)))) (define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id ;; RA => e.g. usage (mrmt:send-receive 'get-var #f (list varname)) ;; (define (mrmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected ;;DOT digraph megatest_state_status { ;;DOT ranksep=0; ;;DOT // rankdir=LR; ;;DOT node [shape="box"]; ;;DOT "mrmt:send-receive" -> MUTEXLOCK; ;;DOT { edge [style=invis];"case 1" -> "case 2" -> "case 3" -> "case 4" -> "case 5" -> "case 6" -> "case 7" -> "case 8" -> "case 9" -> "case 10" -> "case 11"; } ;; do all the prep locked under the rmt-mutex (mutex-lock! *rmt-mutex*) ;; 1. check if server is started IFF cmd is a write OR if we are not on the homehost, store in runremote ;; 2. check the age of the connections. refresh the connection if it is older than timeout-20 seconds. ;; 3. do the query, if on homehost use local access ;; (let* ((start-time (current-seconds)) ;; snapshot time so all use cases get same value (areapath *toppath*);; TODO - resolve from dbstruct to be compatible with multiple areas (runremote (or area-dat *runremote*)) (readonly-mode (if (and runremote (remote-ro-mode-checked runremote)) (remote-ro-mode runremote) (let* ((dbfile (conc *toppath* "/megatest.db")) (ro-mode (not (file-write-access? dbfile)))) ;; TODO: use dbstruct or runremote to figure this out in future (if runremote (begin (remote-ro-mode-set! runremote ro-mode) (remote-ro-mode-checked-set! runremote #t) ro-mode) ro-mode))))) ;; DOT INIT_RUNREMOTE; // leaving off - doesn't really add to the clarity ;; DOT MUTEXLOCK -> INIT_RUNREMOTE [label="no remote?"]; ;; DOT INIT_RUNREMOTE -> MUTEXLOCK; ;; ensure we have a record for our connection for given area (if (not runremote) ;; can remove this one. should never get here. (begin (set! *runremote* (make-remote)) (set! runremote *runremote*))) ;; new runremote will come from this on next iteration ;; DOT SET_HOMEHOST; // leaving off - doesn't really add to the clarity ;; DOT MUTEXLOCK -> SET_HOMEHOST [label="no homehost?"]; ;; DOT SET_HOMEHOST -> MUTEXLOCK; ;; ensure we have a homehost record (if (not (pair? (remote-hh-dat runremote))) ;; not on homehost (thread-sleep! 0.1) ;; since we shouldn't get here, delay a little (remote-hh-dat-set! runremote (common:get-homehost))) ;;(print "BB> readonly-mode is "readonly-mode" dbfile is "dbfile) (cond ;;DOT EXIT; ;;DOT MUTEXLOCK -> EXIT [label="> 15 attempts"]; {rank=same "case 1" "EXIT" } ;; give up if more than 15 attempts ((> attemptnum 15) (debug:print 0 *default-log-port* "ERROR: 15 tries to start/connect to server. Giving up.") (exit 1)) ;;DOT CASE2 [label="local\nreadonly\nquery"]; ;;DOT MUTEXLOCK -> CASE2; {rank=same "case 2" CASE2} ;;DOT CASE2 -> "mrmt:open-qry-close-locally"; ;; readonly mode, read request- handle it - case 2 ((and readonly-mode (member cmd api:read-only-queries)) (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "mrmt:send-receive, case 2") (mrmt:open-qry-close-locally cmd 0 params) ) ;;DOT CASE3 [label="write in\nread-only mode"]; ;;DOT MUTEXLOCK -> CASE3 [label="readonly\nmode?"]; {rank=same "case 3" CASE3} ;;DOT CASE3 -> "#f"; ;; readonly mode, write request. Do nothing, return #f (readonly-mode (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "mrmt:send-receive, case 3") (debug:print 0 *default-log-port* "WARNING: write transaction requested on a readonly area. cmd="cmd" params="params) #f) ;; This block was for pre-emptively resetting the connection if there had been no communication for some time. ;; I don't think it adds any value. If the server is not there, just fail and start a new connection. ;; also, the expire-time calculation might not be correct. We want, time-since-last-server-access > (server:get-timeout) ;; ;;DOT CASE4 [label="reset\nconnection"]; ;;DOT MUTEXLOCK -> CASE4 [label="have connection,\nlast_access > expire_time"]; {rank=same "case 4" CASE4} ;;DOT CASE4 -> "mrmt:send-receive"; ;; reset the connection if it has been unused too long ((and runremote (remote-conndat runremote) (> (current-seconds) ;; if it has been more than server-timeout seconds since last contact, close this connection and start a new on (+ (http-transport:server-dat-get-last-access (remote-conndat runremote)) (remote-server-timeout runremote)))) (debug:print-info 0 *default-log-port* "Connection to " (remote-server-url runremote) " expired due to no accesses, forcing new connection.") (http-transport:close-connections area-dat: runremote) (remote-conndat-set! runremote #f) ;; invalidate the connection, thus forcing a new connection. (mutex-unlock! *rmt-mutex*) (mrmt:send-receive cmd rid params attemptnum: attemptnum)) ;;DOT CASE5 [label="local\nread"]; ;;DOT MUTEXLOCK -> CASE5 [label="server not required,\non homehost,\nread-only query"]; {rank=same "case 5" CASE5}; ;;DOT CASE5 -> "mrmt:open-qry-close-locally"; ;; on homehost and this is a read ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required (cdr (remote-hh-dat runremote)) ;; on homehost (member cmd api:read-only-queries)) ;; this is a read (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "mrmt:send-receive, case 5") (mrmt:open-qry-close-locally cmd 0 params)) ;;DOT CASE6 [label="init\nremote"]; ;;DOT MUTEXLOCK -> CASE6 [label="on homehost,\nwrite query,\nhave server,\ncan't reach it"]; {rank=same "case 6" CASE6}; ;;DOT CASE6 -> "mrmt:send-receive"; ;; on homehost and this is a write, we already have a server, but server has died ((and (cdr (remote-hh-dat runremote)) ;; on homehost (not (member cmd api:read-only-queries)) ;; this is a write (remote-server-url runremote) ;; have a server (not (server:ping (remote-server-url runremote)))) ;; server has died. NOTE: this is not a cheap call! Need better approach. (set! *runremote* (make-remote)) (remote-force-server-set! runremote (common:force-server?)) (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "mrmt:send-receive, case 6") (mrmt:send-receive cmd rid params attemptnum: attemptnum)) ;;DOT CASE7 [label="homehost\nwrite"]; ;;DOT MUTEXLOCK -> CASE7 [label="server not required,\non homehost,\na write,\nhave a server"]; {rank=same "case 7" CASE7}; ;;DOT CASE7 -> "mrmt:open-qry-close-locally"; ;; on homehost and this is a write, we already have a server ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required (cdr (remote-hh-dat runremote)) ;; on homehost (not (member cmd api:read-only-queries)) ;; this is a write (remote-server-url runremote)) ;; have a server (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "mrmt:send-receive, case 4.1") (mrmt:open-qry-close-locally cmd 0 params)) ;;DOT CASE8 [label="force\nserver"]; ;;DOT MUTEXLOCK -> CASE8 [label="server not required,\nhave homehost info,\nno connection yet,\nnot a read-only query"]; {rank=same "case 8" CASE8}; ;;DOT CASE8 -> "mrmt:open-qry-close-locally"; ;; on homehost, no server contact made and this is a write, passively start a server ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required (cdr (remote-hh-dat runremote)) ;; have homehost (not (remote-server-url runremote)) ;; no connection yet (not (member cmd api:read-only-queries))) ;; not a read-only query (debug:print-info 12 *default-log-port* "mrmt:send-receive, case 8") (let ((server-url (server:check-if-running *toppath*))) ;; (server:read-dotserver->url *toppath*))) ;; (server:check-if-running *toppath*))) ;; Do NOT want to run server:check-if-running - very expensive to do for every write call (if server-url (remote-server-url-set! runremote server-url) ;; the string can be consumed by the client setup if needed (if (common:force-server?) (server:start-and-wait *toppath*) (server:kind-run *toppath*)))) (remote-force-server-set! runremote (common:force-server?)) (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "mrmt:send-receive, case 8.1") (mrmt:open-qry-close-locally cmd 0 params)) ;;DOT CASE9 [label="force server\nnot on homehost"]; ;;DOT MUTEXLOCK -> CASE9 [label="no connection\nand either require server\nor not on homehost"]; {rank=same "case 9" CASE9}; ;;DOT CASE9 -> "start\nserver" -> "mrmt:send-receive"; ((or (and (remote-force-server runremote) ;; we are forcing a server and don't yet have a connection to one (not (remote-conndat runremote))) (and (not (cdr (remote-hh-dat runremote))) ;; not on a homehost (not (remote-conndat runremote)))) ;; and no connection (debug:print-info 12 *default-log-port* "mrmt:send-receive, case 9, hh-dat: " (remote-hh-dat runremote) " conndat: " (remote-conndat runremote)) (mutex-unlock! *rmt-mutex*) (if (not (server:check-if-running *toppath*)) ;; who knows, maybe one has started up? (server:start-and-wait *toppath*)) (remote-conndat-set! runremote (mrmt:get-connection-info *toppath*)) ;; calls client:setup which calls client:setup-http (mrmt:send-receive cmd rid params attemptnum: attemptnum)) ;; TODO: add back-off timeout as ;;DOT CASE10 [label="on homehost"]; ;;DOT MUTEXLOCK -> CASE10 [label="server not required,\non homehost"]; {rank=same "case 10" CASE10}; ;;DOT CASE10 -> "mrmt:open-qry-close-locally"; ;; all set up if get this far, dispatch the query ((and (not (remote-force-server runremote)) (cdr (remote-hh-dat runremote))) ;; we are on homehost (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "mrmt:send-receive, case 10") (mrmt:open-qry-close-locally cmd (if rid rid 0) params)) ;;DOT CASE11 [label="send_receive"]; ;;DOT MUTEXLOCK -> CASE11 [label="else"]; {rank=same "case 11" CASE11}; ;;DOT CASE11 -> "mrmt:send-receive" [label="call failed"]; ;;DOT CASE11 -> "RESULT" [label="call succeeded"]; ;; not on homehost, do server query (else ;; (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "mrmt:send-receive, case 9") ;; (mutex-lock! *rmt-mutex*) (let* ((conninfo (remote-conndat runremote)) (dat (case (remote-transport runremote) ((http) (condition-case ;; handling here has caused a lot of problems. However it is needed to deal with attemtped communication to servers that have gone away (http-transport:client-api-send-receive 0 conninfo cmd params) ((commfail)(vector #f "communications fail")) ((exn)(vector #f "other fail" (print-call-chain))))) (else (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport runremote) " not supported") (exit)))) (success (if (vector? dat) (vector-ref dat 0) #f)) (res (if (vector? dat) (vector-ref dat 1) #f))) (if (and (vector? conninfo) (< 5 (vector-length conninfo))) (http-transport:server-dat-update-last-access conninfo) ;; refresh access time (begin (debug:print 0 *default-log-port* "INFO: Should not get here! conninfo=" conninfo) (set! conninfo #f) (remote-conndat-set! *runremote* #f) (http-transport:close-connections area-dat: runremote))) ;; (mutex-unlock! *rmt-mutex*) (debug:print-info 13 *default-log-port* "mrmt:send-receive, case 9. conninfo=" conninfo " dat=" dat " runremote = " runremote) (mutex-unlock! *rmt-mutex*) (if success ;; success only tells us that the transport was successful, have to examine the data to see if there was a detected issue at the other end (if (and (vector? res) (eq? (vector-length res) 2) (eq? (vector-ref res 1) 'overloaded)) ;; since we are looking at the data to carry the error we'll use a fairly obtuse combo to minimise the chances of some sort of collision. ;; this is the case where the returned data is bad or the server is overloaded and we want ;; to ease off the queries (let ((wait-delay (+ attemptnum (* attemptnum 10)))) (debug:print 0 *default-log-port* "WARNING: server is overloaded. Delaying " wait-delay " seconds and trying call again.") (mutex-lock! *rmt-mutex*) (http-transport:close-connections area-dat: runremote) (set! *runremote* #f) ;; force starting over (mutex-unlock! *rmt-mutex*) (thread-sleep! wait-delay) (mrmt:send-receive cmd rid params attemptnum: (+ attemptnum 1))) res) ;; All good, return res (begin (debug:print 0 *default-log-port* "WARNING: communication failed. Trying again, try num: " attemptnum) (mutex-lock! *rmt-mutex*) (remote-conndat-set! runremote #f) (http-transport:close-connections area-dat: runremote) (remote-server-url-set! runremote #f) (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "mrmt:send-receive, case 9.1") ;; (if (not (server:check-if-running *toppath*)) ;; (server:start-and-wait *toppath*)) (mrmt:send-receive cmd rid params attemptnum: (+ attemptnum 1))))))))) ;;DOT } ;; (define (mrmt:update-db-stats run-id rawcmd params duration) ;; (mutex-lock! *db-stats-mutex*) ;; (handle-exceptions ;; exn ;; (begin ;; (debug:print 0 *default-log-port* "WARNING: stats collection failed in update-db-stats") ;; (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) ;; (print "exn=" (condition->list exn)) ;; #f) ;; if this fails we don't care, it is just stats ;; (let* ((cmd (conc "run-id=" run-id " " (if (eq? rawcmd 'general-call) (car params) rawcmd))) ;; (stat-vec (hash-table-ref/default *db-stats* cmd #f))) ;; (if (not (vector? stat-vec)) ;; (let ((newvec (vector 0 0))) ;; (hash-table-set! *db-stats* cmd newvec) ;; (set! stat-vec newvec))) ;; (vector-set! stat-vec 0 (+ (vector-ref stat-vec 0) 1)) ;; (vector-set! stat-vec 1 (+ (vector-ref stat-vec 1) duration)))) ;; (mutex-unlock! *db-stats-mutex*)) (define (mrmt:print-db-stats) (let ((fmtstr "~40a~7-d~9-d~20,2-f")) ;; "~20,2-f" (debug:print 18 *default-log-port* "DB Stats\n========") (debug:print 18 *default-log-port* (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg")) (for-each (lambda (cmd) (let ((cmd-dat (hash-table-ref *db-stats* cmd))) (debug:print 18 *default-log-port* (format #f fmtstr cmd (vector-ref cmd-dat 0) (vector-ref cmd-dat 1) (/ (vector-ref cmd-dat 1)(vector-ref cmd-dat 0)))))) (sort (hash-table-keys *db-stats*) (lambda (a b) (> (vector-ref (hash-table-ref *db-stats* a) 0) (vector-ref (hash-table-ref *db-stats* b) 0))))))) (define (mrmt:get-max-query-average run-id) (mutex-lock! *db-stats-mutex*) (let* ((runkey (conc "run-id=" run-id " ")) (cmds (filter (lambda (x) (substring-index runkey x)) (hash-table-keys *db-stats*))) (res (if (null? cmds) (cons 'none 0) (let loop ((cmd (car cmds)) (tal (cdr cmds)) (max-cmd (car cmds)) (res 0)) (let* ((cmd-dat (hash-table-ref *db-stats* cmd)) (tot (vector-ref cmd-dat 0)) (curravg (/ (vector-ref cmd-dat 1) (vector-ref cmd-dat 0))) ;; count is never zero by construction (currmax (max res curravg)) (newmax-cmd (if (> curravg res) cmd max-cmd))) (if (null? tal) (if (> tot 10) (cons newmax-cmd currmax) (cons 'none 0)) (loop (car tal)(cdr tal) newmax-cmd currmax))))))) (mutex-unlock! *db-stats-mutex*) res)) (define (mrmt:open-qry-close-locally cmd run-id params #!key (remretries 5)) (let* ((qry-is-write (not (member cmd api:read-only-queries))) (db-file-path (db:dbfile-path #f)) ;; 0)) (dbstruct-local (db:setup #t)) ;; make-dbr:dbstruct path: dbdir local: #t))) (read-only (not (file-write-access? db-file-path))) (start (current-milliseconds)) (resdat (if (not (and read-only qry-is-write)) (let ((v (api:execute-requests dbstruct-local (vector (symbol->string cmd) params)))) (handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong.. exn ;; This is an attempt to detect that situation and recover gracefully (begin (debug:print0 *default-log-port* "ERROR: bad data from server " v " message: " ((condition-property-accessor 'exn 'message) exn)) (vector #t '())) ;; should always get a vector but if something goes wrong return a dummy (if (and (vector? v) (> (vector-length v) 1)) (let ((newvec (vector (vector-ref v 0)(vector-ref v 1)))) newvec) ;; by copying the vector while inside the error handler we should force the detection of a corrupted record (vector #t '())))) ;; we could also check that the returned types are valid (vector #t '()))) (success (vector-ref resdat 0)) (res (vector-ref resdat 1)) (duration (- (current-milliseconds) start))) (if (and read-only qry-is-write) (debug:print 0 *default-log-port* "ERROR: attempt to write to read-only database ignored. cmd=" cmd)) (if (not success) (if (> remretries 0) (begin (debug:print-error 0 *default-log-port* "local query failed. Trying again.") (thread-sleep! (/ (random 5000) 1000)) ;; some random delay (mrmt:open-qry-close-locally cmd run-id params remretries: (- remretries 1))) (begin (debug:print-error 0 *default-log-port* "too many retries in mrmt:open-qry-close-locally, giving up") #f)) (begin ;; (mrmt:update-db-stats run-id cmd params duration) ;; mark this run as dirty if this was a write, the watchdog is responsible for syncing it (if qry-is-write (let ((start-time (current-seconds))) (mutex-lock! *db-multi-sync-mutex*) / (set! *db-last-access* start-time) ;; THIS IS PROBABLY USELESS? (we are on a client) (mutex-unlock! *db-multi-sync-mutex*))))) res)) (define (mrmt:send-receive-no-auto-client-setup connection-info cmd run-id params) (let* ((run-id (if run-id run-id 0)) (res (handle-exceptions exn #f (http-transport:client-api-send-receive run-id connection-info cmd params)))) (if (and res (vector-ref res 0)) (vector-ref res 1) ;;; YES!! THIS IS CORRECT!! CHANGE IT HERE, THEN CHANGE mrmt:send-receive ALSO!!! #f))) ;; ;; Wrap json library for strings (why the ports crap in the first place?) ;; (define (mrmt:dat->json-str dat) ;; (with-output-to-string ;; (lambda () ;; (json-write dat)))) ;; ;; (define (mrmt:json-str->dat json-str) ;; (with-input-from-string json-str ;; (lambda () ;; (json-read)))) ;;====================================================================== ;; ;; A C T U A L A P I C A L L S ;; ;;====================================================================== ;;====================================================================== ;; S E R V E R ;;====================================================================== (define (mrmt:kill-server run-id) (mrmt:send-receive 'kill-server run-id (list run-id))) (define (mrmt:start-server run-id) (mrmt:send-receive 'start-server 0 (list run-id))) ;;====================================================================== ;; M I S C ;;====================================================================== (define (mrmt:login run-id) (mrmt:send-receive 'login run-id (list *toppath* megatest-version *my-client-signature*))) ;; This login does no retries under the hood - it acts a bit like a ping. ;; Deprecated for nmsg-transport. ;; (define (mrmt:login-no-auto-client-setup connection-info) (case *transport-type* ;; run-id of 0 is just a placeholder ((http)(mrmt:send-receive-no-auto-client-setup connection-info 'login 0 (list *toppath* megatest-version *my-client-signature*))) ;;((nmsg)(nmsg-transport:client-api-send-receive run-id connection-info 'login (list *toppath* megatest-version run-id *my-client-signature*))) )) ;; hand off a call to one of the db:queries statements ;; added run-id to make looking up the correct db possible ;; (define (mrmt:general-call stmtname run-id . params) (mrmt:send-receive 'general-call run-id (append (list stmtname run-id) params))) ;; given a hostname, return a pair of cpu load and update time representing latest intelligence from tests running on that host (define (mrmt:get-latest-host-load hostname) (mrmt:send-receive 'get-latest-host-load 0 (list hostname))) ;; (define (mrmt:sync-inmem->db run-id) ;; (mrmt:send-receive 'sync-inmem->db run-id '())) (define (mrmt:sdb-qry qry val run-id) ;; add caching if qry is 'getid or 'getstr (mrmt:send-receive 'sdb-qry run-id (list qry val))) ;; NOT COMPLETED (define (mrmt:runtests user run-id testpatt params) (mrmt:send-receive 'runtests run-id testpatt)) (define (mrmt:get-changed-record-ids since-time) (mrmt:send-receive 'get-changed-record-ids #f (list since-time)) ) ;;====================================================================== ;; T E S T M E T A ;;====================================================================== (define (mrmt:get-tests-tags) (mrmt:send-receive 'get-tests-tags #f '())) ;;====================================================================== ;; K E Y S ;;====================================================================== ;; These require run-id because the values come from the run! ;; (define (mrmt:get-key-val-pairs run-id) (mrmt:send-receive 'get-key-val-pairs run-id (list run-id))) (define (mrmt:get-keys) ;; (if *db-keys* *db-keys* (let ((res (mrmt:send-receive 'get-keys #f '()))) ;; (set! *db-keys* res) res)) ;; ) (define (mrmt:get-keys-write) ;; dummy query to force server start (let ((res (mrmt:send-receive 'get-keys-write #f '()))) ;; (set! *db-keys* res) res)) ;; we don't reuse run-id's (except possibly *after* a db cleanup) so it is safe ;; to cache the resuls in a hash ;; (define (mrmt:get-key-vals run-id) (or (hash-table-ref/default *keyvals* run-id #f) (let ((res (mrmt:send-receive 'get-key-vals #f (list run-id)))) (hash-table-set! *keyvals* run-id res) res))) (define (mrmt:get-targets) (mrmt:send-receive 'get-targets #f '())) (define (mrmt:get-target run-id) (mrmt:send-receive 'get-target run-id (list run-id))) ;;====================================================================== ;; T E S T S ;;====================================================================== ;; Just some syntatic sugar (define (mrmt:register-test run-id test-name item-path) (mrmt:general-call 'register-test run-id run-id test-name item-path)) (define (mrmt:get-test-id run-id testname item-path) (mrmt:send-receive 'get-test-id run-id (list run-id testname item-path))) ;; run-id is NOT used ;; (define (mrmt:get-test-info-by-id run-id test-id) (if (number? test-id) (mrmt:send-receive 'get-test-info-by-id run-id (list run-id test-id)) (begin (debug:print 0 *default-log-port* "WARNING: Bad data handed to mrmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id) (print-call-chain (current-error-port)) #f))) (define (mrmt:test-get-rundir-from-test-id run-id test-id) (mrmt:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id))) (define (mrmt:open-test-db-by-test-id run-id test-id #!key (work-area #f)) (let* ((test-path (if (string? work-area) work-area (mrmt:test-get-rundir-from-test-id run-id test-id)))) (debug:print 3 *default-log-port* "TEST PATH: " test-path) (open-test-db test-path))) ;; WARNING: This currently bypasses the transaction wrapped writes system (define (mrmt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment) (mrmt:send-receive 'test-set-state-status-by-id run-id (list run-id test-id newstate newstatus newcomment))) (define (mrmt:set-tests-state-status run-id testnames currstate currstatus newstate newstatus) (mrmt:send-receive 'set-tests-state-status run-id (list run-id testnames currstate currstatus newstate newstatus))) (define (mrmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode) ;; (if (number? run-id) (mrmt:send-receive 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode))) ;; (begin ;; (debug:print-error 0 *default-log-port* "mrmt:get-tests-for-run called with bad run-id=" run-id) ;; (print-call-chain (current-error-port)) ;; '()))) ;; get stuff via synchash (define (mrmt:synchash-get run-id proc synckey keynum params) (mrmt:send-receive 'synchash-get run-id (list run-id proc synckey keynum params))) ;; IDEA: Threadify these - they spend a lot of time waiting ... ;; (define (mrmt:get-tests-for-runs-mindata run-ids testpatt states status not-in) (let ((multi-run-mutex (make-mutex)) (run-id-list (if run-ids run-ids (mrmt:get-all-run-ids))) (result '())) (if (null? run-id-list) '() (let loop ((hed (car run-id-list)) (tal (cdr run-id-list)) (threads '())) (if (> (length threads) 5) (loop hed tal (filter (lambda (th)(not (member (thread-state th) '(terminated dead)))) threads)) (let* ((newthread (make-thread (lambda () (let ((res (mrmt:send-receive 'get-tests-for-run-mindata hed (list hed testpatt states status not-in)))) (if (list? res) (begin (mutex-lock! multi-run-mutex) (set! result (append result res)) (mutex-unlock! multi-run-mutex)) (debug:print-error 0 *default-log-port* "get-tests-for-run-mindata failed for run-id " hed ", testpatt " testpatt ", states " states ", status " status ", not-in " not-in)))) (conc "multi-run-thread for run-id " hed))) (newthreads (cons newthread threads))) (thread-start! newthread) (thread-sleep! 0.05) ;; give that thread some time to start (if (null? tal) newthreads (loop (car tal)(cdr tal) newthreads)))))) result)) ;; ;; IDEA: Threadify these - they spend a lot of time waiting ... ;; ;; ;; (define (mrmt:get-tests-for-runs-mindata run-ids testpatt states status not-in) ;; (let ((run-id-list (if run-ids ;; run-ids ;; (mrmt:get-all-run-ids)))) ;; (apply append (map (lambda (run-id) ;; (mrmt:send-receive 'get-tests-for-run-mindata run-id (list run-ids testpatt states status not-in))) ;; run-id-list)))) (define (mrmt:delete-test-records run-id test-id) (mrmt:send-receive 'delete-test-records run-id (list run-id test-id))) ;; This is not needed as test steps are deleted on test delete call ;; ;; (define (mrmt:delete-test-step-records run-id test-id) ;; (mrmt:send-receive 'delete-test-step-records run-id (list run-id test-id))) (define (mrmt:test-set-state-status run-id test-id state status msg) (mrmt:send-receive 'test-set-state-status run-id (list run-id test-id state status msg))) (define (mrmt:test-toplevel-num-items run-id test-name) (mrmt:send-receive 'test-toplevel-num-items run-id (list run-id test-name))) ;; (define (mrmt:get-previous-test-run-record run-id test-name item-path) ;; (mrmt:send-receive 'get-previous-test-run-record run-id (list run-id test-name item-path))) (define (mrmt:get-matching-previous-test-run-records run-id test-name item-path) (mrmt:send-receive 'get-matching-previous-test-run-records run-id (list run-id test-name item-path))) (define (mrmt:test-get-logfile-info run-id test-name) (mrmt:send-receive 'test-get-logfile-info run-id (list run-id test-name))) (define (mrmt:test-get-records-for-index-file run-id test-name) (mrmt:send-receive 'test-get-records-for-index-file run-id (list run-id test-name))) (define (mrmt:get-testinfo-state-status run-id test-id) (mrmt:send-receive 'get-testinfo-state-status run-id (list run-id test-id))) (define (mrmt:test-set-log! run-id test-id logf) (if (string? logf)(mrmt:general-call 'test-set-log run-id logf test-id))) (define (mrmt:test-set-top-process-pid run-id test-id pid) (mrmt:send-receive 'test-set-top-process-pid run-id (list run-id test-id pid))) (define (mrmt:test-get-top-process-pid run-id test-id) (mrmt:send-receive 'test-get-top-process-pid run-id (list run-id test-id))) (define (mrmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt) (mrmt:send-receive 'get-run-ids-matching-target #f (list keynames target res runname testpatt statepatt statuspatt))) ;; NOTE: This will open and access ALL run databases. ;; (define (mrmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname) (let ((run-ids (mrmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt))) (apply append (map (lambda (run-id) (mrmt:send-receive 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname))) run-ids)))) ;; (define (mrmt:get-run-ids-matching keynames target res) ;; (mrmt:send-receive #f 'get-run-ids-matching (list keynames target res))) (define (mrmt:get-prereqs-not-met run-id waitons ref-test-name ref-item-path #!key (mode '(normal))(itemmaps #f)) (mrmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-test-name ref-item-path mode itemmaps))) (define (mrmt:get-count-tests-running-for-run-id run-id) (mrmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id))) ;; Statistical queries (define (mrmt:get-count-tests-running run-id) (mrmt:send-receive 'get-count-tests-running run-id (list run-id))) (define (mrmt:get-count-tests-running-for-testname run-id testname) (mrmt:send-receive 'get-count-tests-running-for-testname run-id (list run-id testname))) (define (mrmt:get-count-tests-running-in-jobgroup run-id jobgroup) (mrmt:send-receive 'get-count-tests-running-in-jobgroup run-id (list run-id jobgroup))) ;; state and status are extra hints not usually used in the calculation ;; (define (mrmt:set-state-status-and-roll-up-items run-id test-name item-path state status comment) (mrmt:send-receive 'set-state-status-and-roll-up-items run-id (list run-id test-name item-path state status comment))) (define (mrmt:update-pass-fail-counts run-id test-name) (mrmt:general-call 'update-pass-fail-counts run-id test-name test-name test-name)) (define (mrmt:top-test-set-per-pf-counts run-id test-name) (mrmt:send-receive 'top-test-set-per-pf-counts run-id (list run-id test-name))) (define (mrmt:get-raw-run-stats run-id) (mrmt:send-receive 'get-raw-run-stats run-id (list run-id))) ;;====================================================================== ;; R U N S ;;====================================================================== (define (mrmt:get-run-info run-id) (mrmt:send-receive 'get-run-info run-id (list run-id))) (define (mrmt:get-num-runs runpatt) (mrmt:send-receive 'get-num-runs #f (list runpatt))) ;; Use the special run-id == #f scenario here since there is no run yet (define (mrmt:register-run keyvals runname state status user contour) (mrmt:send-receive 'register-run #f (list keyvals runname state status user contour))) (define (mrmt:get-run-name-from-id run-id) (mrmt:send-receive 'get-run-name-from-id run-id (list run-id))) (define (mrmt:delete-run run-id) (mrmt:send-receive 'delete-run run-id (list run-id))) (define (mrmt:update-run-stats run-id stats) (mrmt:send-receive 'update-run-stats #f (list run-id stats))) (define (mrmt:delete-old-deleted-test-records) (mrmt:send-receive 'delete-old-deleted-test-records #f '())) (define (mrmt:get-runs runpatt count offset keypatts) (mrmt:send-receive 'get-runs #f (list runpatt count offset keypatts))) (define (mrmt:get-all-run-ids) (mrmt:send-receive 'get-all-run-ids #f '())) (define (mrmt:get-prev-run-ids run-id) (mrmt:send-receive 'get-prev-run-ids #f (list run-id))) (define (mrmt:lock/unlock-run run-id lock unlock user) (mrmt:send-receive 'lock/unlock-run #f (list run-id lock unlock user))) ;; set/get status (define (mrmt:get-run-status run-id) (mrmt:send-receive 'get-run-status #f (list run-id))) (define (mrmt:set-run-status run-id run-status #!key (msg #f)) (mrmt:send-receive 'set-run-status #f (list run-id run-status msg))) (define (mrmt:update-run-event_time run-id) (mrmt:send-receive 'update-run-event_time #f (list run-id))) (define (mrmt:get-runs-by-patt keys runnamepatt targpatt offset limit fields last-runs-update) ;; fields of #f uses default (mrmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit fields last-runs-update))) (define (mrmt:find-and-mark-incomplete run-id ovr-deadtime) ;; (if (mrmt:send-receive 'have-incompletes? run-id (list run-id ovr-deadtime)) (mrmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime))) ;; ) (define (mrmt:get-main-run-stats run-id) (mrmt:send-receive 'get-main-run-stats #f (list run-id))) (define (mrmt:get-var varname) (mrmt:send-receive 'get-var #f (list varname))) (define (mrmt:del-var varname) (mrmt:send-receive 'del-var #f (list varname))) (define (mrmt:set-var varname value) (mrmt:send-receive 'set-var #f (list varname value))) ;;====================================================================== ;; M U L T I R U N Q U E R I E S ;;====================================================================== ;; Need to move this to multi-run section and make associated changes (define (mrmt:find-and-mark-incomplete-all-runs #!key (ovr-deadtime #f)) (let ((run-ids (mrmt:get-all-run-ids))) (for-each (lambda (run-id) (mrmt:find-and-mark-incomplete run-id ovr-deadtime)) run-ids))) ;; get the previous record for when this test was run where all keys match but runname ;; returns #f if no such test found, returns a single test record if found ;; ;; Run this at the client end since we have to connect to multiple run-id dbs ;; (define (mrmt:get-previous-test-run-record run-id test-name item-path) (let* ((keyvals (mrmt:get-key-val-pairs run-id)) (keys (mrmt:get-keys)) (selstr (string-intersperse keys ",")) (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND "))) (if (not keyvals) #f (let ((prev-run-ids (mrmt:get-prev-run-ids run-id))) ;; for each run starting with the most recent look to see if there is a matching test ;; if found then return that matching test record (debug:print 4 *default-log-port* "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) (if (null? prev-run-ids) #f (let loop ((hed (car prev-run-ids)) (tal (cdr prev-run-ids))) (let ((results (mrmt:get-tests-for-run hed (conc test-name "/" item-path) '() '() ;; run-id testpatt states statuses #f #f #f ;; offset limit not-in hide/not-hide #f #f #f #f 'normal))) ;; sort-by sort-order qryvals last-update mode (debug:print 4 *default-log-port* "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results) (if (and (null? results) (not (null? tal))) (loop (car tal)(cdr tal)) (if (null? results) #f (car results)))))))))) (define (mrmt:get-run-stats) (mrmt:send-receive 'get-run-stats #f '())) ;;====================================================================== ;; S T E P S ;;====================================================================== ;; Getting steps is more complicated. ;; ;; If given work area ;; 1. Find the testdat.db file ;; 2. Open the testdat.db file and do the query ;; If not given the work area ;; 1. Do a remote call to get the test path ;; 2. Continue as above ;; ;;(define (mrmt:get-steps-for-test run-id test-id) ;; (mrmt:send-receive 'get-steps-data run-id (list test-id))) (define (mrmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile) (let* ((state (items:check-valid-items "state" state-in)) (status (items:check-valid-items "status" status-in))) (if (or (not state)(not status)) (debug:print 3 *default-log-port* "WARNING: Invalid " (if status "status" "state") " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) (mrmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile)))) (define (mrmt:get-steps-for-test run-id test-id) (mrmt:send-receive 'get-steps-for-test run-id (list run-id test-id))) ;;====================================================================== ;; T E S T D A T A ;;====================================================================== (define (mrmt:read-test-data run-id test-id categorypatt #!key (work-area #f)) (mrmt:send-receive 'read-test-data run-id (list run-id test-id categorypatt))) (define (mrmt:read-test-data* run-id test-id categorypatt varpatt #!key (work-area #f)) (mrmt:send-receive 'read-test-data* run-id (list run-id test-id categorypatt varpatt))) ;; (let ((tdb (mrmt:open-test-db-by-test-id run-id test-id work-area: work-area))) ;; (if tdb ;; (tdb:read-test-data tdb test-id categorypatt) ;; '()))) (define (mrmt:testmeta-add-record testname) (mrmt:send-receive 'testmeta-add-record #f (list testname))) (define (mrmt:testmeta-get-record testname) (mrmt:send-receive 'testmeta-get-record #f (list testname))) (define (mrmt:testmeta-update-field test-name fld val) (mrmt:send-receive 'testmeta-update-field #f (list test-name fld val))) (define (mrmt:test-data-rollup run-id test-id status) (mrmt:send-receive 'test-data-rollup run-id (list run-id test-id status))) (define (mrmt:csv->test-data run-id test-id csvdata) (mrmt:send-receive 'csv->test-data run-id (list run-id test-id csvdata))) ;;====================================================================== ;; T A S K S ;;====================================================================== (define (mrmt:tasks-find-task-queue-records target run-name test-patt state-patt action-patt) (mrmt:send-receive 'find-task-queue-records #f (list target run-name test-patt state-patt action-patt))) (define (mrmt:tasks-add action owner target runname testpatt params) (mrmt:send-receive 'tasks-add #f (list action owner target runname testpatt params))) (define (mrmt:tasks-set-state-given-param-key param-key new-state) (mrmt:send-receive 'tasks-set-state-given-param-key #f (list param-key new-state))) (define (mrmt:tasks-get-last target runname) (mrmt:send-receive 'tasks-get-last #f (list target runname))) ;;====================================================================== ;; N O S Y N C D B ;;====================================================================== (define (mrmt:no-sync-set var val) (mrmt:send-receive 'no-sync-set #f `(,var ,val))) (define (mrmt:no-sync-get/default var default) (mrmt:send-receive 'no-sync-get/default #f `(,var ,default))) (define (mrmt:no-sync-del! var) (mrmt:send-receive 'no-sync-del! #f `(,var))) (define (mrmt:no-sync-get-lock keyname) (mrmt:send-receive 'no-sync-get-lock #f `(,keyname))) ;;====================================================================== ;; A R C H I V E S ;;====================================================================== (define (mrmt:archive-get-allocations testname itempath dneeded) (mrmt:send-receive 'archive-get-allocations #f (list testname itempath dneeded))) (define (mrmt:archive-register-block-name bdisk-id archive-path) (mrmt:send-receive 'archive-register-block-name #f (list bdisk-id archive-path))) (define (mrmt:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey) (mrmt:send-receive 'archive-allocate-test-to-block #f (list block-id testsuite-name areakey))) (define (mrmt:archive-register-disk bdisk-name bdisk-path df) (mrmt:send-receive 'archive-register-disk #f (list bdisk-name bdisk-path df))) (define (mrmt:test-set-archive-block-id run-id test-id archive-block-id) (mrmt:send-receive 'test-set-archive-block-id run-id (list run-id test-id archive-block-id))) (define (mrmt:test-get-archive-block-info archive-block-id) (mrmt:send-receive 'test-get-archive-block-info #f (list archive-block-id))) |
Modified mtut.scm from [1f120769b0] to [1a4e185888].
︙ | ︙ | |||
437 438 439 440 441 442 443 444 445 446 | '()))) (filter cdr args-data))))) ;; (print "Alldat: " alldat ;; " args-data: " args-data) (add-z-card (apply construct-sdat alldat)))) (define (simple-setup start-dir-in) (let* ((start-dir (or start-dir-in ".")) (mtconfig (or (args:get-arg "-config") "megatest.config")) | > | | 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 | '()))) (filter cdr args-data))))) ;; (print "Alldat: " alldat ;; " args-data: " args-data) (add-z-card (apply construct-sdat alldat)))) ;; merge/consolidate with common:simple-setup (define (simple-setup start-dir-in) (let* ((start-dir (or start-dir-in ".")) (mtconfig (or (args:get-arg "-config") "megatest.config")) (mtconfdat (find-and-read-config ;; NB// sets MT_RUN_AREA_HOME as side effect -> NOPE! Not if pathenvvar is #f mtconfig ;; environ-patt: "env-override" given-toppath: start-dir ;; pathenvvar: "MT_RUN_AREA_HOME" )) (mtconf (if mtconfdat (car mtconfdat) #f))) ;; we set some dynamic data in a section called "dyndata" |
︙ | ︙ | |||
985 986 987 988 989 990 991 | (system (conc "/bin/cat " schema-file))))) ((sqlite3schema) (let* ((install-home (common:get-install-area)) (schema-file (conc install-home "/share/db/mt-sqlite3.sql"))) (if (common:file-exists? schema-file) (system (conc "/bin/cat " schema-file))))) ((junk) | | > | 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 | (system (conc "/bin/cat " schema-file))))) ((sqlite3schema) (let* ((install-home (common:get-install-area)) (schema-file (conc install-home "/share/db/mt-sqlite3.sql"))) (if (common:file-exists? schema-file) (system (conc "/bin/cat " schema-file))))) ((junk) (rmt:get-keys)))))) )) ;; If HTTP_HOST is defined then we must be in the cgi environment ;; so run stml and exit ;; (if (get-environment-variable "HTTP_HOST") (begin (stml:main #f) |
︙ | ︙ |
Modified rmt.scm from [677a774188] to [8ae137f573].
︙ | ︙ | |||
475 476 477 478 479 480 481 | ;; These require run-id because the values come from the run! ;; (define (rmt:get-key-val-pairs run-id) (rmt:send-receive 'get-key-val-pairs run-id (list run-id))) (define (rmt:get-keys) | | | | | | | 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 | ;; These require run-id because the values come from the run! ;; (define (rmt:get-key-val-pairs run-id) (rmt:send-receive 'get-key-val-pairs run-id (list run-id))) (define (rmt:get-keys) ;; (if *db-keys* *db-keys* (let ((res (rmt:send-receive 'get-keys #f '()))) ;; (set! *db-keys* res) res)) ;; ) (define (rmt:get-keys-write) ;; dummy query to force server start (let ((res (rmt:send-receive 'get-keys-write #f '()))) ;; (set! *db-keys* res) res)) ;; we don't reuse run-id's (except possibly *after* a db cleanup) so it is safe ;; to cache the resuls in a hash ;; (define (rmt:get-key-vals run-id) (or (hash-table-ref/default *keyvals* run-id #f) |
︙ | ︙ |
Modified utils/plot-code.scm from [2b66df6bfd] to [6d50d1bd96].
1 2 3 4 5 6 7 8 9 | #!/mfs/pkgs/chicken/4.8.0.5/bin/csi -nbq ;; Coming soon (right?) Usage: plot-code file1.scm,file2.scm "fun1,fun2,x*" *.scm > plot.dot ;; Usage: plot-code file1.scm,file2.scm *.scm > plot.dot ;; dot -Tpdf plot.dot > plot.pdf ;; first param is comma separated list of files to include in the map, use - to do all ;; second param is list of regexs for functions to include in the map ;; third param is list of files to scan | | > > > | > > > > > > > | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 | #!/mfs/pkgs/chicken/4.8.0.5/bin/csi -nbq ;; Coming soon (right?) Usage: plot-code file1.scm,file2.scm "fun1,fun2,x*" *.scm > plot.dot ;; Usage: plot-code file1.scm,file2.scm *.scm > plot.dot ;; dot -Tpdf plot.dot > plot.pdf ;; first param is comma separated list of files to include in the map, use - to do all ;; second param is list of regexs for functions to include in the map ;; third param is list of files to scan (use regex srfi-69 srfi-13 srfi-1 data-structures posix) ;; 1 2 remainder ;; plot-code file1.scm,file2.scm... fn-regex file1.scm file2.scm ... (define targs #f) (define args (argv)) (if (< (length args) 2) ;; no args provided (begin (print "Usage: plot-code file1.scm,file2.scm... 'your.*regex' file3.scm file4.scm file5.scm ...") (exit))) (define files (cdddr args)) (let ((targdat (cadr args))) (if (equal? targdat "-") (set! targs files) (set! targs (string-split targdat ",")))) (define function-patt (caddr args)) (define function-rx (regexp function-patt)) (define filedat-defns (make-hash-table)) (define filedat-usages (make-hash-table)) (define defn-rx (regexp "^\\s*\\(define\\s+\\(([^\\s\\)]+).*")) (define all-regexs (make-hash-table)) |
︙ | ︙ |