Megatest: Check-in [d9c3068419]

Overview

Comment:	merged with latest v1.62
Downloads:	Tarball \| ZIP archive \| SQL archive
Timelines:	family \| ancestors \| descendants \| both \| defstruct-srehman
Files:	files \| file ages \| folders
SHA1:	d9c3068419ab068e29ed096fd9a1cd0a0661c769
User & Date:	srehman on 2016-09-23 11:16:51
Other Links:	branch diff \| manifest \| tags

Context

2016-09-23
12:26		fixed error with alist being passed instead of single defstruct check-in: 24ed7d9e0a user: srehman tags: defstruct-srehman
11:16		merged with latest v1.62 check-in: d9c3068419 user: srehman tags: defstruct-srehman
11:16		fixed rmt issue when returning information from server check-in: f84ef58d2d user: srehman tags: defstruct-srehman
2016-09-21
09:11		moved readline fix include out of the if. Update copyright date. Block when running db migration IF version bumped check-in: e24aa68ed5 user: mrwellan tags: v1.62

Changes

Hide Diffs Unified Diffs Ignore Whitespace Patch

Modified common.scm from [14a3d2fe92] to [b0ca248a45].

Modified dashboard-tests.scm from [3a6a535f7d] to [18a620ff35].

Modified dashboard.scm from [5514682bcc] to [f755ea6a07].

Modified db_records.scm from [b1caab6d0d] to [c013213d68].

Modified dcommon.scm from [c53658a736] to [03679c636d].

Modified megatest.scm from [8777b38b5a] to [c9c26e5538].

Modified rmt.scm from [a85b27b9ab] to [2952ad46e2].

︙			︙
55 56 57 58 59 60 61 62 63 64 65 66 67 68	(define (make-dbr:dbstruct #!key (path #f)(local #f)) (let ((v (make-vector 15 #f))) (dbr:dbstruct-set-path! v path) (dbr:dbstruct-set-local! v local) (dbr:dbstruct-set-locdbs! v (make-hash-table)) v)) (define (dbr:dbstruct-get-localdb v run-id) (hash-table-ref/default (dbr:dbstruct-get-locdbs v) run-id #f)) (define (dbr:dbstruct-set-localdb! v run-id db) (hash-table-set! (dbr:dbstruct-get-locdbs v) run-id db)) (require-extension typed-records)	> >	55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70	(define (make-dbr:dbstruct #!key (path #f)(local #f)) (let ((v (make-vector 15 #f))) (dbr:dbstruct-set-path! v path) (dbr:dbstruct-set-local! v local) (dbr:dbstruct-set-locdbs! v (make-hash-table)) v)) ;; Returns the database for a particular run-id fron the dbstruct:localdbs ;; (define (dbr:dbstruct-get-localdb v run-id) (hash-table-ref/default (dbr:dbstruct-get-locdbs v) run-id #f)) (define (dbr:dbstruct-set-localdb! v run-id db) (hash-table-set! (dbr:dbstruct-get-locdbs v) run-id db)) (require-extension typed-records)
︙			︙
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	(conc (db:test-get-testname vec) "/" (db:test-get-item-path vec))) ;; replace runs:make-full-test-name with this routine (define (db:test-make-full-name testname itempath) (if (equal? itempath "") testname (conc testname "/" itempath))) (define-inline (db:test-get-first_err vec) (printable (vector-ref vec 15))) ~~(define-inline (db:test-get-first_warn vec) (printable (vector-ref vec 16)))~~ (define-inline (db:test-set-cpuload! vec val)(vector-set! vec 7 val)) (define-inline (db:test-set-diskfree! vec val)(vector-set! vec 8 val)) (define-inline (db:test-set-testname! vec val)(vector-set! vec 2 val)) (define-inline (db:test-set-state! vec val)(vector-set! vec 3 val)) (define-inline (db:test-set-status! vec val)(vector-set! vec 4 val)) (define-inline (db:test-set-run_duration! vec val)(vector-set! vec 12 val)) (define-inline (db:test-set-final_logf! vec val)(vector-set! vec 13 val)) ;; Test record utility functions ;; Is a test a toplevel? ;; (define (db:test-get-is-toplevel vec) (and (equal? (db:test-get-item-path vec) "") ;; test is not an item (equal? (db:test-get-uname vec) "n/a"))) ;; test has never been run ;; make-vector-record "" db mintest id run_id testname state status event_time item_path ;; (define (make-db:mintest)(make-vector 7)) (define-inline (db:mintest-get-id vec) (vector-ref vec 0)) (define-inline (db:mintest-get-run_id vec) (vector-ref vec 1)) (define-inline (db:mintest-get-testname vec) (vector-ref vec 2)) (define-inline (db:mintest-get-state vec) (vector-ref vec 3)) (define-inline (db:mintest-get-status vec) (vector-ref vec 4))	\| >	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	(conc (db:test-get-testname vec) "/" (db:test-get-item-path vec))) ;; replace runs:make-full-test-name with this routine (define (db:test-make-full-name testname itempath) (if (equal? itempath "") testname (conc testname "/" itempath))) (define-inline (db:test-get-first_err vec) (printable (vector-ref vec 15))) (define-inline (db:test-get-first_warn vec) (printable (vector-ref vec 16))) ;; RADT => reference 16 is repeated (define-inline (db:test-set-cpuload! vec val)(vector-set! vec 7 val)) (define-inline (db:test-set-diskfree! vec val)(vector-set! vec 8 val)) (define-inline (db:test-set-testname! vec val)(vector-set! vec 2 val)) (define-inline (db:test-set-state! vec val)(vector-set! vec 3 val)) (define-inline (db:test-set-status! vec val)(vector-set! vec 4 val)) (define-inline (db:test-set-run_duration! vec val)(vector-set! vec 12 val)) (define-inline (db:test-set-final_logf! vec val)(vector-set! vec 13 val)) ;; Test record utility functions ;; Is a test a toplevel? ;; (define (db:test-get-is-toplevel vec) (and (equal? (db:test-get-item-path vec) "") ;; test is not an item (equal? (db:test-get-uname vec) "n/a"))) ;; test has never been run ;; make-vector-record "" db mintest id run_id testname state status event_time item_path ;; RADT => purpose of mintest?? ;; (define (make-db:mintest)(make-vector 7)) (define-inline (db:mintest-get-id vec) (vector-ref vec 0)) (define-inline (db:mintest-get-run_id vec) (vector-ref vec 1)) (define-inline (db:mintest-get-testname vec) (vector-ref vec 2)) (define-inline (db:mintest-get-state vec) (vector-ref vec 3)) (define-inline (db:mintest-get-status vec) (vector-ref vec 4))
︙			︙

︙			︙
1039 1040 1041 1042 1043 1044 1045 ~~1046~~ 1047 1048 1049 1050 1051 1052 1053	(testpatt (common:args-get-testpatt #f)) ;; (if (args:get-arg "-testpatt") ;; (args:get-arg "-testpatt") ;; "%")) (keys (rmt:get-keys)) ;; (db:get-keys dbstruct)) ;; (runsda t (db:get-runs dbstruct runpatt #f #f '())) (runsdat (rmt:get-runs-by-patt keys (or runpatt "%") (common:args-get-target) ;; (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target) ~~#f #f '("id" "runname" "state" "status" "owner" "event_time" "comment")))~~ (runstmp (db:get-rows runsdat)) (header (db:get-header runsdat)) ;; this is "-since" support. This looks at last mod times of <run-id>.db files ;; and collects those modified since the -since time. (runs (if (and (not (null? runstmp)) (args:get-arg "-since")) (let ((changed-ids (db:get-changed-run-ids (string->number (args:get-arg "-since")))))	\|	1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053	(testpatt (common:args-get-testpatt #f)) ;; (if (args:get-arg "-testpatt") ;; (args:get-arg "-testpatt") ;; "%")) (keys (rmt:get-keys)) ;; (db:get-keys dbstruct)) ;; (runsda t (db:get-runs dbstruct runpatt #f #f '())) (runsdat (rmt:get-runs-by-patt keys (or runpatt "%") (common:args-get-target) ;; (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target) #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0)) (runstmp (db:get-rows runsdat)) (header (db:get-header runsdat)) ;; this is "-since" support. This looks at last mod times of <run-id>.db files ;; and collects those modified since the -since time. (runs (if (and (not (null? runstmp)) (args:get-arg "-since")) (let ((changed-ids (db:get-changed-run-ids (string->number (args:get-arg "-since")))))
︙			︙
1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890	(set! didsomething #t))) ;;====================================================================== ;; Start a repl ;;====================================================================== ;; fakeout readline (if (or (getenv "MT_RUNSCRIPT") (args:get-arg "-repl") (args:get-arg "-load")) (let* ((toppath (launch:setup)) (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f))) (if dbstruct	>	1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891	(set! didsomething #t))) ;;====================================================================== ;; Start a repl ;;====================================================================== ;; fakeout readline (include "readline-fix.scm") (if (or (getenv "MT_RUNSCRIPT") (args:get-arg "-repl") (args:get-arg "-load")) (let* ((toppath (launch:setup)) (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f))) (if dbstruct
︙			︙
1906 1907 1908 1909 1910 1911 1912 ~~1913~~ 1914 1915 1916 1917 1918 1919 1920	(set! db dbstruct) (set! client-non-blocking-mode #t) (import extras) ;; might not be needed ;; (import csi) (import readline) (import apropos) ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... ~~(include "readline-fix.scm")~~ (if use-new-readline (begin (install-history-file (get-environment-variable "HOME") ".megatest_history") ;; [homedir] [filename] [nlines]) (current-input-port (make-readline-port "megatest> "))) (begin (gnu-history-install-file-manager	<	1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920	(set! db dbstruct) (set! client-non-blocking-mode #t) (import extras) ;; might not be needed ;; (import csi) (import readline) (import apropos) ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... (if use-new-readline (begin (install-history-file (get-environment-variable "HOME") ".megatest_history") ;; [homedir] [filename] [nlines]) (current-input-port (make-readline-port "megatest> "))) (begin (gnu-history-install-file-manager
︙			︙

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19	;;====================================================================== ;; Copyright 2006-2013, 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 json format)~~ (declare (unit rmt)) (declare (uses api)) (declare (uses tdb)) (declare (uses http-transport)) (declare (uses nmsg-transport))	\|	1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19	;;====================================================================== ;; Copyright 2006-2013, 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 json format) ;; RADT => purpose of json format?? (declare (unit rmt)) (declare (uses api)) (declare (uses tdb)) (declare (uses http-transport)) (declare (uses nmsg-transport))
︙			︙
69 70 71 72 73 74 75 76 77 78 79 80 81 82	;; NB// can cache the answer for server running for 10 seconds ... ;; ;; (and (not (rmt:write-frequency-over-limit? cmd run-id)) (if (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id) (client:setup run-id) #f)))) (define send-receive-mutex (make-mutex)) ;; should have separate mutex per run-id (define (rmt:send-receive cmd rid params #!key (attemptnum 1)) ;; start attemptnum at 1 so the modulo below works as expected ;; clean out old connections ;; (mutex-lock! db-multi-sync-mutex) (let ((expire-time (- (current-seconds) (server:get-timeout) 10))) ;; don't forget the 10 second margin (for-each (lambda (run-id) (let ((connection (hash-table-ref/default runremote run-id #f)))	> > >	69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85	;; NB// can cache the answer for server running for 10 seconds ... ;; ;; (and (not (rmt:write-frequency-over-limit? cmd run-id)) (if (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id) (client:setup run-id) #f)))) (define send-receive-mutex (make-mutex)) ;; should have separate mutex per run-id ;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname)) ;; (define (rmt:send-receive cmd rid params #!key (attemptnum 1)) ;; start attemptnum at 1 so the modulo below works as expected ;; clean out old connections ;; (mutex-lock! db-multi-sync-mutex) (let ((expire-time (- (current-seconds) (server:get-timeout) 10))) ;; don't forget the 10 second margin (for-each (lambda (run-id) (let ((connection (hash-table-ref/default runremote run-id #f)))
︙			︙

︙			︙
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	please-update: #t update-mutex: (make-mutex) updaters: (make-hash-table) updating: #f hide-not-hide-tabs: #f )) (define (dboard:common-get-tabdat commondat #!key (tab-num #f)) (hash-table-ref/default (dboard:commondat-tabdats commondat) ~~(or tab-num (dboard:commondat-curr-tab-num commondat))~~ #f)) (define (dboard:common-set-tabdat! commondat tabnum tabdat) (hash-table-set! (dboard:commondat-tabdats commondat) tabnum tabdat)) ~~;; gets and calls updater based on curr-tab-num~~ (define (dboard:common-run-curr-updaters commondat #!key (tab-num #f)) (if (dboard:common-get-tabdat commondat tab-num: tab-num) ;; only update if there is a tabdat (let* ((tnum (or tab-num (dboard:commondat-curr-tab-num commondat))) (updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '()))) (debug:print 4 default-log-port "Found these updaters: " updaters " for tab-num: " tnum) ~~(for-each~~ (lambda (updater) ;; (debug:print 3 default-log-port "Running " updater) (updater)) updaters)))) ;; if tab-num passed in then use it, otherwise look in commondat at curr-tab-num ;; (define (dboard:commondat-add-updater commondat updater #!key (tab-num #f)) (let* ((tnum (or tab-num (dboard:commondat-curr-tab-num commondat))) (curr-updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '()))) (hash-table-set! (dboard:commondat-updaters commondat) tnum (cons updater curr-updaters)))) ;; data for each specific tab goes here ;; (defstruct dboard:tabdat ;; runs ((allruns '()) : list) ;; list of dboard:rundat records ((allruns-by-id (make-hash-table)) : hash-table) ;; hash of run-id -> dboard:rundat records ((done-runs '()) : list) ;; list of runs already drawn ((not-done-runs '()) : list) ;; list of runs not yet drawn (header #f) ;; header for decoding the run records (keys #f) ;; keys for this run (i.e. target components) ~~((numruns (string->number (or (args:get-arg "-cols") "8"))) : number) ;;~~ ((tot-runs 0) : number) ((last-data-update 0) : number) ;; last time the data in allruns was updated ((last-runs-update 0) : number) ;; last time we pulled the runs info to update the tree (runs-mutex (make-mutex)) ;; use to prevent parallel access to draw objects ((run-update-times (make-hash-table)) : hash-table) ;; update times indexed by run-id ((last-test-dat (make-hash-table)) : hash-table) ;; cache last tests dat by run-id ((run-db-paths (make-hash-table)) : hash-table) ;; cache the paths to the run db files	> > \| > > \| \| > \|	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	please-update: #t update-mutex: (make-mutex) updaters: (make-hash-table) updating: #f hide-not-hide-tabs: #f )) ;; RA => returns the tabdat stored at hashkey passed in commondat-tabdats table (e.g. 0 gives summary) ;; (define (dboard:common-get-tabdat commondat #!key (tab-num #f)) (hash-table-ref/default (dboard:commondat-tabdats commondat) (or tab-num (dboard:commondat-curr-tab-num commondat)) ;; tab-num value is curr-tab-num value in passed commondat #f)) ;; RA => sets the tabdat passed to the hashkey at commondat:tabdats hash table ;; (define (dboard:common-set-tabdat! commondat tabnum tabdat) (hash-table-set! (dboard:commondat-tabdats commondat) tabnum tabdat)) ;; gets and calls updater list based on curr-tab-num (define (dboard:common-run-curr-updaters commondat #!key (tab-num #f)) (if (dboard:common-get-tabdat commondat tab-num: tab-num) ;; only update if there is a tabdat (let* ((tnum (or tab-num (dboard:commondat-curr-tab-num commondat))) (updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '()))) (debug:print 4 default-log-port "Found these updaters: " updaters " for tab-num: " tnum) (for-each ;; perform the function calls for the complete updaters list (lambda (updater) ;; (debug:print 3 default-log-port "Running " updater) (updater)) updaters)))) ;; if tab-num passed in then use it, otherwise look in commondat at curr-tab-num ;; adds the updater passed in the updaters list at that hashkey ;; (define (dboard:commondat-add-updater commondat updater #!key (tab-num #f)) (let* ((tnum (or tab-num (dboard:commondat-curr-tab-num commondat))) (curr-updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '()))) (hash-table-set! (dboard:commondat-updaters commondat) tnum (cons updater curr-updaters)))) ;; data for each specific tab goes here ;; (defstruct dboard:tabdat ;; runs ((allruns '()) : list) ;; list of dboard:rundat records ((allruns-by-id (make-hash-table)) : hash-table) ;; hash of run-id -> dboard:rundat records ((done-runs '()) : list) ;; list of runs already drawn ((not-done-runs '()) : list) ;; list of runs not yet drawn (header #f) ;; header for decoding the run records (keys #f) ;; keys for this run (i.e. target components) ((numruns (string->number (or (args:get-arg "-cols") "10"))) : number) ;; ((tot-runs 0) : number) ((last-data-update 0) : number) ;; last time the data in allruns was updated ((last-runs-update 0) : number) ;; last time we pulled the runs info to update the tree (runs-mutex (make-mutex)) ;; use to prevent parallel access to draw objects ((run-update-times (make-hash-table)) : hash-table) ;; update times indexed by run-id ((last-test-dat (make-hash-table)) : hash-table) ;; cache last tests dat by run-id ((run-db-paths (make-hash-table)) : hash-table) ;; cache the paths to the run db files
︙			︙
212 213 214 215 216 217 218 ~~219~~ 220 221 222 223 224 225 226	states ;; states for -state s1,s2 ... statuses ;; statuses for -status s1,s2 ... ;; Selector variables curr-run-id ;; current row to display in Run summary view prev-run-id ;; previous runid selected before current runid was selected (used in xor-two-runs runs summary mode curr-test-ids ;; used only in dcommon:run-update which is used in newdashboard ~~((filters-changed #f) : boolean) ;; to to indicate that the user changed filters for this tab~~ ((last-filter-str "") : string) ;; conc the target runname and testpatt for a signature of changed filters ((hide-empty-runs #f) : boolean) ((hide-not-hide #t) : boolean) ;; toggle for hide/not hide empty runs (hide-not-hide-button #f) ((searchpatts (make-hash-table)) : hash-table) ;; ((state-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATE => #t/#f for display control ((status-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATUS => #t/#f	\|	217 218 219 220 221 222 223 224 225 226 227 228 229 230 231	states ;; states for -state s1,s2 ... statuses ;; statuses for -status s1,s2 ... ;; Selector variables curr-run-id ;; current row to display in Run summary view prev-run-id ;; previous runid selected before current runid was selected (used in xor-two-runs runs summary mode curr-test-ids ;; used only in dcommon:run-update which is used in newdashboard ((filters-changed #t) : boolean) ;; to to indicate that the user changed filters for this tab ((last-filter-str "") : string) ;; conc the target runname and testpatt for a signature of changed filters ((hide-empty-runs #f) : boolean) ((hide-not-hide #t) : boolean) ;; toggle for hide/not hide empty runs (hide-not-hide-button #f) ((searchpatts (make-hash-table)) : hash-table) ;; ((state-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATE => #t/#f for display control ((status-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATUS => #t/#f
︙			︙
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	;; This is roughly the same as dboard:get-tests-dat, should merge them if possible ;; ;; gets all the tests for run-id that match testnamepatt and key-vals, merges them ;; ;; NOTE: Yes, this is used ;; (define (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals) ~~(let* ((num-to-get ~~20)~~~~ (states (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat))) (statuses (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat))) (sort-info (get-curr-sort)) (sort-by (vector-ref sort-info 1)) (sort-order (vector-ref sort-info 2)) (bubble-type (if (member sort-order '(testname)) 'testname 'itempath)) ;; note: the rundat is normally created in "update-rundat". (run-dat (or (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f) (let ((rd (dboard:rundat-make-init run: run key-vals: key-vals))) (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id rd) rd))) ;; (prev-tests (dboard:rundat-tests prev-dat)) ;; (vector-ref prev-dat 1)) ~~~~(last-update~~ (dboard:rundat-last-update run-dat~~)) ;; (vector-ref prev-dat 3)~~)~~ (db-path (or (dboard:rundat-db-path run-dat) (let* ((db-dir (tasks:get-task-db-path)) (db-pth (conc db-dir "/" run-id ".db"))) (dboard:rundat-db-path-set! run-dat db-pth) db-pth))) ~~(tmptests (if (or ~~(configf:lookup configdat "setup" "~~do-not-use-db-file-timestamps")~~ (>= (file-modification-time db-path) last-update)) ~~(rmt:get-tests-for-run run-id testnamepatt states statuses ;; run-id testpatt states statuses~~ (dboard:rundat-run-data-offset run-dat) num-to-get (dboard:tabdat-hide-not-hide tabdat) ;; no-in sort-by ;; sort-by sort-order ;; sort-order #f ;; 'shortlist ;; qrytype (if (dboard:tabdat-filters-changed tabdat)	\| > > > > > > > > > > > \| > > > \| \|	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	;; This is roughly the same as dboard:get-tests-dat, should merge them if possible ;; ;; gets all the tests for run-id that match testnamepatt and key-vals, merges them ;; ;; NOTE: Yes, this is used ;; (define (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals) (let* ((num-to-get (let ((num-tests-from-config (configf:lookup configdat "setup" "num-tests-to-get"))) (if num-tests-from-config (begin (BB> "override num-tests 100 -> "num-tests-from-config) (string->number num-tests-from-config)) 100))) (states (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat))) (statuses (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat))) (do-not-use-db-file-timestamps (configf:lookup configdat "setup" "do-not-use-db-file-timestamps")) ;; this still hosts runs-summary-tab (do-not-use-query-timestamps (configf:lookup configdat "setup" "do-not-use-query-timestamps")) ;; this no longer troubles runs-summary-tab (sort-info (get-curr-sort)) (sort-by (vector-ref sort-info 1)) (sort-order (vector-ref sort-info 2)) (bubble-type (if (member sort-order '(testname)) 'testname 'itempath)) ;; note: the rundat is normally created in "update-rundat". (run-dat (or (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f) (let ((rd (dboard:rundat-make-init run: run key-vals: key-vals))) (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id rd) rd))) ;; (prev-tests (dboard:rundat-tests prev-dat)) ;; (vector-ref prev-dat 1)) (last-update (if do-not-use-query-timestamps 0 (dboard:rundat-last-update run-dat) ;;(hash-table-ref/default (dboard:tabdat-run-update-times tabdat) run-id 0) )) (db-path (or (dboard:rundat-db-path run-dat) (let* ((db-dir (tasks:get-task-db-path)) (db-pth (conc db-dir "/" run-id ".db"))) (dboard:rundat-db-path-set! run-dat db-pth) db-pth))) (tmptests (if (or do-not-use-db-file-timestamps (>= (file-modification-time db-path) last-update)) (rmt:get-tests-for-run run-id testnamepatt states statuses ;; run-id testpatt states statuses (dboard:rundat-run-data-offset run-dat) num-to-get (dboard:tabdat-hide-not-hide tabdat) ;; no-in sort-by ;; sort-by sort-order ;; sort-order #f ;; 'shortlist ;; qrytype (if (dboard:tabdat-filters-changed tabdat)
︙			︙
548 549 550 551 552 553 554 ~~555~~ 556 557 558 559 560 561 562	tmptests) ;; set last-update to 0 if still getting data incrementally (if (> (dboard:rundat-run-data-offset run-dat) 0) (begin ;; (print "run-data-offset: " (dboard:rundat-run-data-offset run-dat) ", setting last-update to 0") ~~(dboard:rundat-last-update-set! run-dat 0))~~ (dboard:rundat-last-update-set! run-dat (- (current-seconds) 2))) ;; go back two seconds in time to ensure all changes are captured. ;; (debug:print-info 0 default-log-port "tests-ht: " (hash-table-keys tests-ht)) tests-ht)) ;; tmptests - new tests data ;; prev-tests - old tests data	> \| > >	567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584	tmptests) ;; set last-update to 0 if still getting data incrementally (if (> (dboard:rundat-run-data-offset run-dat) 0) (begin ;; (print "run-data-offset: " (dboard:rundat-run-data-offset run-dat) ", setting last-update to 0") ;; (dboard:rundat-last-update-set! run-dat 0) (dboard:rundat-last-update-set! run-dat 0)) ;; (hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- start-time 3)) (dboard:rundat-last-update-set! run-dat (- (current-seconds) 2))) ;; go back two seconds in time to ensure all changes are captured. ;; (debug:print-info 0 default-log-port "tests-ht: " (hash-table-keys tests-ht)) tests-ht)) ;; tmptests - new tests data ;; prev-tests - old tests data
︙			︙
646 647 648 649 650 651 652 653 654 655 656 657 658 659	(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:update-tree tabdat runs-hash header tb))) (define collapsed (make-hash-table)) (define (toggle-hide lnum uidat) ; fulltestname) (let* ((btn (vector-ref (dboard:uidat-get-lftcol uidat) lnum)) (fulltestname (iup:attribute btn "TITLE")) (parts (string-split fulltestname "("))	> > >	668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684	(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:update-tree tabdat runs-hash header tb))) (define collapsed (make-hash-table)) (define (toggle-hide lnum uidat) ; fulltestname) (let* ((btn (vector-ref (dboard:uidat-get-lftcol uidat) lnum)) (fulltestname (iup:attribute btn "TITLE")) (parts (string-split fulltestname "("))
︙			︙
799 800 801 802 803 804 805 ~~806~~ 807 808 809 810 811 812 813	(take-right (dboard:tabdat-allruns tabdat) numruns) (pad-list (dboard:tabdat-allruns tabdat) numruns))) (lftcol (dboard:uidat-get-lftcol uidat)) (tableheader (dboard:uidat-get-header uidat)) (table (dboard:uidat-get-runsvec uidat)) (coln 0) (all-test-names (make-hash-table))) ;; create a concise list of test names ;; (for-each (lambda (rundat) (if rundat (let* ((testdats (dboard:rundat-tests rundat)) (testnames (map test:test-get-fullname (hash-table-values testdats))))	<	824 825 826 827 828 829 830 831 832 833 834 835 836 837	(take-right (dboard:tabdat-allruns tabdat) numruns) (pad-list (dboard:tabdat-allruns tabdat) numruns))) (lftcol (dboard:uidat-get-lftcol uidat)) (tableheader (dboard:uidat-get-header uidat)) (table (dboard:uidat-get-runsvec uidat)) (coln 0) (all-test-names (make-hash-table))) ;; create a concise list of test names ;; (for-each (lambda (rundat) (if rundat (let* ((testdats (dboard:rundat-tests rundat)) (testnames (map test:test-get-fullname (hash-table-values testdats))))
︙			︙
902 903 904 905 906 907 908 909 910 911 912 913 914 915	(color (car (gutils:get-color-for-state-status teststate teststatus))) (curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR")) (curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE"))) (if (not (equal? curr-color color)) (iup:attribute-set! button "BGCOLOR" color)) (if (not (equal? curr-title buttontxt)) (iup:attribute-set! button "TITLE" buttontxt)) (vector-set! buttondat 0 run-id) (vector-set! buttondat 1 color) (vector-set! buttondat 2 buttontxt) (vector-set! buttondat 3 testdat) (vector-set! buttondat 4 run-key))) (set! rown (+ rown 1)))) (dboard:tabdat-all-test-names tabdat)))	>	926 927 928 929 930 931 932 933 934 935 936 937 938 939 940	(color (car (gutils:get-color-for-state-status teststate teststatus))) (curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR")) (curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE"))) (if (not (equal? curr-color color)) (iup:attribute-set! button "BGCOLOR" color)) (if (not (equal? curr-title buttontxt)) (iup:attribute-set! button "TITLE" buttontxt)) ;;(print "RA => testdat " testdat " teststate " teststate " teststatus " teststatus " buttondat " buttondat " curr-color " curr-color " curr-title " curr-title "buttontxt" buttontxt " title " curr-title ) (vector-set! buttondat 0 run-id) (vector-set! buttondat 1 color) (vector-set! buttondat 2 buttontxt) (vector-set! buttondat 3 testdat) (vector-set! buttondat 4 run-key))) (set! rown (+ rown 1)))) (dboard:tabdat-all-test-names tabdat)))
︙			︙
936 937 938 939 940 941 942 ~~943~~ 944 945 946 947 948 949 950	(define (update-search commondat tabdat x val) (hash-table-set! (dboard:tabdat-searchpatts tabdat) x val) (dboard:tabdat-filters-changed-set! tabdat #t) (set-bg-on-filter commondat tabdat)) (define (mark-for-update tabdat) ~~(dboard:tabdat-filters-changed-set! tabdat #t)~~ (dboard:tabdat-last-db-update-set! tabdat 0)) ;;====================================================================== ;; R U N C O N T R O L ;;====================================================================== ;; target populating logic	\|	961 962 963 964 965 966 967 968 969 970 971 972 973 974 975	(define (update-search commondat tabdat x val) (hash-table-set! (dboard:tabdat-searchpatts tabdat) x val) (dboard:tabdat-filters-changed-set! tabdat #t) (set-bg-on-filter commondat tabdat)) (define (mark-for-update tabdat) ;; (dboard:tabdat-filters-changed-set! tabdat #t) (dboard:tabdat-last-db-update-set! tabdat 0)) ;;====================================================================== ;; R U N C O N T R O L ;;====================================================================== ;; target populating logic
︙			︙
1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 ~~1453 1454 1455 1456 1457 1458~~ 1459 ~~1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474~~ ~~1475 1476~~ 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 ~~1489 1490 1491~~ 1492 1493 1494 1495 1496 1497 1498 ~~1499~~ ~~1500~~ 1501 1502 1503 1504 1505 1506 1507	;; Here we update the tests treebox and tree keys (tree:add-node tb "Runs" run-path ;; (append key-vals (list run-name)) userdata: (conc "run-id: " run-id)) (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id) ;; (set! colnum (+ colnum 1)) )))) run-ids))) (define (dashboard:run-id->tests-mindat run-id tabdat runs-hash) (let* ((run (hash-table-ref/default runs-hash run-id #f)) ~~(last-update (hash-table-ref/default (dboard:tabdat-run-update-times tabdat) run-id 0))~~ ~~(db-path (or (hash-table-ref/default (dboard:tabdat-run-db-paths tabdat) run-id #f)~~ ~~(let* ((db-dir (tasks:get-task-db-path))~~ ~~(db-pth (conc db-dir "/" run-id ".db")))~~ ~~(hash-table-set! (dboard:tabdat-run-db-paths tabdat) run-id db-pth)~~ ~~db-pth)))~~ (key-vals (rmt:get-key-vals run-id)) (testnamepatt (or (dboard:tabdat-test-patts tabdat) "%")) (tests-dat (~~if (~~o~~r (no~~t ~~run~~-~~id)~~ ~~(configf:lookup configdat "setup" "do-not-use-db-file-timestamps")~~ ~~(not (hash-table-exists? (dboard:tabdat-last-test-dat tabdat) run-id))~~ ~~(>= (file-modification-time db-path) last-update))~~ ~~(let ((res~~ (dboard:~~get-tests-~~dat tabdat r~~un-id las~~t-upd~~ate~~) ;; TODO: replace above line (get-tests-dat) with below line (get-tests-for-run-duplicate); above is a list, below is a hash - therein lies the problem. The minimize-test-data depends on a pre-sorted list as input; hash is by nature unsorted. and its not a list. ~~;;(dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)~~ )) (hash-table-set! (dboard:tabdat-last-test-dat tabdat) run-id ~~res~~) (hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- (current-seconds) 10)) res) ~~(hash-table-~~ref (dboard:tabdat-la~~st~~-test-dat tabdat)~~ run~~-id)~~)) ~~(tests-mindat (dcommon:minimize-test-data tests-dat))) ;; reduces data for display~~~~ tests-mindat)) (define (dashboard: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:runs-summary-updater commondat tabdat tb cell-lookup run-matrix)~~ (dboard:runs-~~summary-control-panel-updater~~ tabdat) (let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat)) (runs-dat (rmt: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)))~~ (dboard:update-tree tabdat runs-hash runs-header tb) (if run-id (let* ((matrix-content (case (dboard:tabdat-runs-summary-mode tabdat) ((one-run) (dashboard:run-id->tests-mindat run-id tabdat runs-hash)) ((xor-two-runs) (dashboard:runs-summary-xor-matrix-content tabdat runs-hash)) ((xor-two-runs-hide-clean) (dashboard:runs-summary-xor-matrix-content tabdat runs-hash hide-clean: #t))	> > > > > > > > > > > > > > > > < < < < < < \| \| \| < < < \| < \| < < < \| \| \| > \| < > \| \| \| \| > > > > > > > > > > > > > > > > \| >	1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553	;; Here we update the tests treebox and tree keys (tree:add-node tb "Runs" run-path ;; (append key-vals (list run-name)) userdata: (conc "run-id: " run-id)) (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id) ;; (set! colnum (+ colnum 1)) )))) run-ids))) (define (dashboard:tests-ht->tests-dat tests-ht) (reverse (sort (hash-table-values tests-ht) (lambda (a b) (let ((a-test-name (db:test-get-testname a)) (a-item-path (db:test-get-item-path a)) (b-test-name (db:test-get-testname b)) (b-item-path (db:test-get-item-path b))) (cond ((< 0 (string-compare3 a-test-name b-test-name)) #t) ((> 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 (rmt: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) (BB> "ERROR: NO RUN FOR RUN-ID run-id="run-id) (BB> "runs-hash-> " (hash-table->alist runs-hash)) ) tests-mindat)) (define (dashboard: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:get-runs-hash tabdat) (let* ((last-runs-update 0);;(dboard:tabdat-last-runs-update tabdat)) (runs-dat (rmt: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) (dashboard:do-update-rundat tabdat) (dboard:runs-summary-control-panel-updater tabdat) (let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat)) (runs-dat (rmt: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)) ;; runs) ;; ht)) ) (dboard:update-tree tabdat runs-hash runs-header tb) (if run-id (let* ((matrix-content (case (dboard:tabdat-runs-summary-mode tabdat) ((one-run) (dashboard:run-id->tests-mindat run-id tabdat runs-hash)) ((xor-two-runs) (dashboard:runs-summary-xor-matrix-content tabdat runs-hash)) ((xor-two-runs-hide-clean) (dashboard:runs-summary-xor-matrix-content tabdat runs-hash hide-clean: #t))
︙			︙
1515 1516 1517 1518 1519 1520 1521 ~~1522~~ 1523 1524 1525 1526 1527 1528 1529	(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-last-runs-update-set! tabdat (- (current-seconds) 2))~~ (dboard:tabdat-filters-changed-set! tabdat #f) (let loop ((pass-num 0) (changed #f)) ;; Update the runs tree (dboard:update-tree tabdat runs-hash runs-header tb)	\|	1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575	(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)) ;; Update the runs tree (dboard:update-tree tabdat runs-hash runs-header tb)
︙			︙
1815 1816 1817 1818 1819 1820 1821 1822 ~~1823 1824 1825~~ ~~1826~~ ~~1827~~ 1828 1829 1830 1831 1832 1833 1834	"selection-cb in runs-summary") ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) ))) (cell-lookup (make-hash-table)) (run-matrix (iup:matrix #:expand "YES" #:click-cb (lambda (obj lin col status) ~~(let* ((toolpath (car (argv))) (key (conc lin ":" col)) (test-id (hash-table-ref/default cell-lookup key -1))~~ ~~(cmd (conc toolpath " -test " (dboard:tabdat-curr-run-id tabdat) "," test-id "&")))~~ ~~(system cmd~~)))~~))~~ (runs-summary-updater (lambda () (mutex-lock! update-mutex) (if (or (dashboard:database-changed? commondat tabdat) (dboard:tabdat-view-changed tabdat)) (debug:catch-and-dump (lambda () ;; check that run-matrix is initialized before calling the updater	> > > > > > > > > > \| \| \| > > > > > > > > > > > > > > > > > > \| > > > \| > > > > > > > > > > > > > > > > > > >	1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930	"selection-cb in runs-summary") ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) ))) (cell-lookup (make-hash-table)) (run-matrix (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)) (BB> "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 (rmt:get-run-info run-id)) (target (rmt:get-target run-id)) (runname (db:get-value-by-header (db:get-rows run-info) (db:get-header run-info) "runname")) (test-name (db:test-get-testname (rmt:get-test-info-by-id run-id test-id))) (testpatt (let ((tlast (rmt: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 (rmt: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 " &"))) (BB> "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 (BB> "mmb- test-name="test-name" testpatt="testpatt) (iup:show (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path) ;; popup-menu #:x 'mouse #:y 'mouse #:modal? "NO") ) (else (BB> "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:popup-menu run-id test-id target runname test-name testpatt item-test-path) ;; popup-menu #:x 'mouse #:y 'mouse #:modal? "NO") ) ) )) "runs-summary-click-callback")))) (runs-summary-updater (lambda () (mutex-lock! update-mutex) (if (or (dashboard:database-changed? commondat tabdat) (dboard:tabdat-view-changed tabdat)) (debug:catch-and-dump (lambda () ;; check that run-matrix is initialized before calling the updater
︙			︙
1991 1992 1993 1994 1995 1996 1997 ~~1998~~ 1999 2000 2001 2002 2003 2004 ~~2005~~ 2006 2007 2008 2009 2010 2011 2012 2013 ~~2014~~ 2015 2016 2017 2018 2019 2020 2021	(oldmax (string->number (iup:attribute obj "MAX"))) (maxruns (dboard:tabdat-tot-runs tabdat))) (dboard:tabdat-start-run-offset-set! tabdat val) (mark-for-update tabdat) (debug:print 6 default-log-port "(dboard:tabdat-start-run-offset tabdat) " (dboard:tabdat-start-run-offset tabdat) " maxruns: " maxruns ", val: " val " oldmax: " oldmax) (iup:attribute-set! obj "MAX" (* maxruns 10)))) #:expand "HORIZONTAL" ~~#:max (* 10 (le~~ngth~~ (dboard:tabdat-allruns tabdat)))~~ #:min 0 #:step 0.01))) ;;(iup:button "inc rows" #:action (lambda (obj)(dboard:tabdat-num-tests-set! tabdat (+ (dboard:tabdat-num-tests tabdat) 1)))) ;(iup:button "dec rows" #:action (lambda (obj)(dboard:tabdat-num-tests-set! tabdat (if (> (dboard:tabdat-num-tests tabdat) 0)(- (dboard:tabdat-num-tests tabdat) 1) 0)))) ))) ~~(define (dashboard:popup-menu ~~buttndat~~ run-id test-id target runname test-name testpatt)~~ (iup:menu (iup:menu-item "Run" (iup:menu (iup:menu-item (conc "Rerun " testpatt) #:action (lambda (obj) ~~;;(print ~~"buttndat: " buttndat~~ " run-id: " run-id " test-id: " test-id " target: " target " runname: " runname " test-name: " test-name " testpatt: " testpatt)~~ (common:run-a-command (conc "megatest -run -target " target " -runname " runname " -testpatt " testpatt " -preclean -clean-cache") ))) (iup:menu-item	\| \| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > \|	2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 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 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159	(oldmax (string->number (iup:attribute obj "MAX"))) (maxruns (dboard:tabdat-tot-runs tabdat))) (dboard:tabdat-start-run-offset-set! tabdat val) (mark-for-update tabdat) (debug:print 6 default-log-port "(dboard:tabdat-start-run-offset tabdat) " (dboard:tabdat-start-run-offset tabdat) " maxruns: " maxruns ", val: " val " oldmax: " oldmax) (iup:attribute-set! obj "MAX" (* maxruns 10)))) #:expand "HORIZONTAL" #:max (* 10 (max (hash-table-size (dboard:tabdat-allruns-by-id tabdat)) 10)) #:min 0 #:step 0.01))) ;;(iup:button "inc rows" #:action (lambda (obj)(dboard:tabdat-num-tests-set! tabdat (+ (dboard:tabdat-num-tests tabdat) 1)))) ;(iup:button "dec rows" #:action (lambda (obj)(dboard:tabdat-num-tests-set! tabdat (if (> (dboard:tabdat-num-tests tabdat) 0)(- (dboard:tabdat-num-tests tabdat) 1) 0)))) ))) (define (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path) (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 (not yet implemented) " item-test-path) ) (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) ;; (rmt: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 "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
︙			︙
2030 2031 2032 2033 2034 2035 2036 ~~2037~~ 2038 2039 2040 2041 ~~2042~~ 2043 2044 2045 2046 2047 ~~2048~~ 2049 2050 ~~2051~~ 2052 2053 2054 2055 2056 2057 ~~2058~~ 2059 2060 ~~2061~~ 2062 2063 2064 2065 2066 ~~2067~~ 2068 2069 2070 2071 2072 2073 2074	(iup:menu-item "Clean Complete Run" #:action (lambda (obj) (common:run-a-command (conc "megatest -remove-runs -target " target " -runname " runname ~~" -testpatt % "))))))~~ (iup:menu-item "Test" (iup:menu (iup:menu-item ~~(conc "Rerun " test-~~name~~)~~ #:action (lambda (obj) (common:run-a-command (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target " -runname " runname ~~" -testpatt " test-~~name~~~~ " -preclean -clean-cache")))) (iup:menu-item ~~(conc "Kill " test-~~name~~)~~ #:action (lambda (obj) ;; (rmt: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 " test-~~name~~~~ " -state RUNNING,REMOTEHOSTSTART,LAUNCHED")))) (iup:menu-item ~~(conc "Clean " test-~~name~~)~~ #:action (lambda (obj) (common:run-a-command (conc "megatest -remove-runs -target " target " -runname " runname ~~" -testpatt " test-~~name~~))))~~ (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))))	\| > > > > > > > > > \| \| \| \| \| \|	2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221	(iup:menu-item "Clean Complete Run" #:action (lambda (obj) (common:run-a-command (conc "megatest -remove-runs -target " target " -runname " runname " -testpatt % ")))) (iup:menu-item ;; RADT => itemize this run lists before merging with v1.61 "Kill Complete Run" #:action (lambda (obj) (common:run-a-command (conc "megatest -set-state-status KILLREQ,n/a -target " target " -runname " runname " -testpatt % " " -state RUNNING,REMOTEHOSTSTART,LAUNCHED")))))) (iup:menu-item "Test" (iup:menu (iup:menu-item (conc "Rerun " 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) ;; (rmt: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 "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))))
︙			︙
2089 2090 2091 2092 2093 2094 2095 ~~2096~~ 2097 2098 2099 2100 2101 2102 2103	" " tconfig " &"))) (system cmd)))) )))) (define (make-dashboard-buttons commondat) ;; runs-sum-dat new-view-dat) (let* ((stats-dat (dboard:tabdat-make-data)) (runs-dat (dboard:tabdat-make-data)) ~~(onerun-dat (dboard:tabdat-make-data))~~ (runcontrols-dat (dboard:tabdat-make-data)) (runtimes-dat (dboard:tabdat-make-data)) (nruns (dboard:tabdat-numruns runs-dat)) (ntests (dboard:tabdat-num-tests runs-dat)) (keynames (dboard:tabdat-dbkeys runs-dat)) (nkeys (length keynames)) (runsvec (make-vector nruns))	\|	2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250	" " tconfig " &"))) (system cmd)))) )))) (define (make-dashboard-buttons commondat) ;; runs-sum-dat new-view-dat) (let* ((stats-dat (dboard:tabdat-make-data)) (runs-dat (dboard:tabdat-make-data)) (onerun-dat (dboard:tabdat-make-data)) ;; name for run-summary structure (runcontrols-dat (dboard:tabdat-make-data)) (runtimes-dat (dboard:tabdat-make-data)) (nruns (dboard:tabdat-numruns runs-dat)) (ntests (dboard:tabdat-num-tests runs-dat)) (keynames (dboard:tabdat-dbkeys runs-dat)) (nkeys (length keynames)) (runsvec (make-vector nruns))
︙			︙
2214 2215 2216 2217 2218 2219 2220 ~~2221~~ ~~2222~~ 2223 2224 2225 2226 2227 2228 2229	(test-name (db:test-get-testname (rmt:get-test-info-by-id run-id test-id))) (testpatt (let ((tlast (rmt: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)) ~~"%"))))~~ ~~(iup:show (dashboard:popup-menu ~~buttndat~~ run-id test-id target runname test-name testpatt) ;; popup-menu~~ #:x 'mouse #:y 'mouse #:modal? "NO") ;; (print "got here") )) (if (eq? pressed 0) (let* ((toolpath (car (argv)))	\| > > > > \|	2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380	(test-name (db:test-get-testname (rmt:get-test-info-by-id run-id test-id))) (testpatt (let ((tlast (rmt: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 (rmt: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) ;; popup-menu #:x 'mouse #:y 'mouse #:modal? "NO") ;; (print "got here") )) (if (eq? pressed 0) (let* ((toolpath (car (argv)))
︙			︙
2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410	recalc)) ;; point inside line ;; (define-inline (dashboard:px-between px lx1 lx2) (and (< lx1 px)(> lx2 px))) ;; can a bar be placed in row "rownum" covering x1 to x2 without overlapping with existing ;; bars? Use num-rows to check that a block will fit from rownum to (+ rownum num-rows) ;; (define (dashboard:row-collision rowhash rownum x1 x2 #!key (num-rows #f)) (let ((lastrow (if num-rows (+ rownum num-rows) rownum))) (let loop ((i 0) (rowdat (hash-table-ref/default rowhash rownum '())))	> >	2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563	recalc)) ;; point inside line ;; (define-inline (dashboard:px-between px lx1 lx2) (and (< lx1 px)(> lx2 px))) ;;Not reference anywhere ;; ;; can a bar be placed in row "rownum" covering x1 to x2 without overlapping with existing ;; bars? Use num-rows to check that a block will fit from rownum to (+ rownum num-rows) ;; (define (dashboard:row-collision rowhash rownum x1 x2 #!key (num-rows #f)) (let ((lastrow (if num-rows (+ rownum num-rows) rownum))) (let loop ((i 0) (rowdat (hash-table-ref/default rowhash rownum '())))
︙			︙
2568 2569 2570 2571 2572 2573 2574 ~~2575~~ 2576 2577 2578 2579 2580 2581 2582	(dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table)) ;; (dboard:tabdat-allruns-set! tabdat '()) (dboard:tabdat-max-row-set! tabdat 0) (dboard:tabdat-last-filter-str-set! tabdat filtrstr))) (update-rundat tabdat runpatt ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") ~~~~10 ;;~~ (dboard:tabdat-numruns tabdat)~~ testpatt ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%") targpatt ;; old method ;; (let ((res '()))	\|	2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735	(dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table)) ;; (dboard:tabdat-allruns-set! tabdat '()) (dboard:tabdat-max-row-set! tabdat 0) (dboard:tabdat-last-filter-str-set! tabdat filtrstr))) (update-rundat tabdat runpatt ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") (dboard:tabdat-numruns tabdat) testpatt ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%") targpatt ;; old method ;; (let ((res '()))
︙			︙
2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 ~~3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020~~ 3021 3022 3023 3024 3025 3026 3027 3028	(begin (if (dboard:tabdat-layout-update-ok tabdat) (runloop (car runtal)(cdr runtal) (+ run-num 1) newdoneruns) (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat) ))))))))) ;; new-run-start-row ))) (debug:print 2 default-log-port "no tabdat for run-times-tab-updater")))) (define (dashboard:runs-tab-updater commondat tab-num) (debug:catch-and-dump (lambda () (let* ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num)) (dbkeys (dboard:tabdat-dbkeys tabdat))) (update-rundat tabdat ~~(hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%")~~ ~~(dboard:tabdat-numruns tabdat)~~ ~~(hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")~~ ~~;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%")~~ ~~(let* ((dbkeys (dboard:tabdat-dbkeys tabdat)))~~ ~~;; (print "dbkeys: " dbkeys)~~ ~~(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 '()))~~ ~~;; (print "target: " (dboard:tabdat-target tabdat))~~ ~~(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))))~~ ~~;; (debug:print 0 default-log-port "fres: " fres)~~ ~~fres)))~~ (let ((uidat (dboard:commondat-uidat commondat))) (update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat))) )) "dashboard:runs-tab-updater")) ;; ((2) ;; (dashboard:update-run-summary-tab)) ;; ((3)	> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > \| < < < < < < < < < < < < < < < < < < < >	3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256	(begin (if (dboard:tabdat-layout-update-ok tabdat) (runloop (car runtal)(cdr runtal) (+ run-num 1) newdoneruns) (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat) ))))))))) ;; new-run-start-row ))) (debug:print 2 default-log-port "no tabdat for run-times-tab-updater")))) (define (tabdat-values tabdat) (let ((allruns (dboard:tabdat-allruns tabdat)) (allruns-by-id (dboard:tabdat-allruns-by-id tabdat)) (done-runs (dboard:tabdat-done-runs tabdat)) (not-done-runs (dboard:tabdat-not-done-runs tabdat)) (header (dboard:tabdat-header tabdat)) (keys (dboard:tabdat-keys tabdat)) (numruns (dboard:tabdat-numruns tabdat)) (tot-runs (dboard:tabdat-tot-runs tabdat)) (last-data-update (dboard:tabdat-last-data-update tabdat)) (runs-mutex (dboard:tabdat-runs-mutex tabdat)) (run-update-times (dboard:tabdat-run-update-times tabdat)) (last-test-dat (dboard:tabdat-last-test-dat tabdat)) (run-db-paths (dboard:tabdat-run-db-paths tabdat)) (buttondat (dboard:tabdat-buttondat tabdat)) (item-test-names (dboard:tabdat-item-test-names tabdat)) (run-keys (dboard:tabdat-run-keys tabdat)) (start-run-offset (dboard:tabdat-start-run-offset tabdat)) (start-test-offset (dboard:tabdat-start-test-offset tabdat)) (runs-btn-height (dboard:tabdat-runs-btn-height tabdat)) (all-test-names (dboard:tabdat-all-test-names tabdat)) (cnv (dboard:tabdat-cnv tabdat)) (command (dboard:tabdat-command tabdat)) (run-name (dboard:tabdat-run-name tabdat)) (states (dboard:tabdat-states tabdat)) (statuses (dboard:tabdat-statuses tabdat)) (curr-run-id (dboard:tabdat-curr-run-id tabdat)) (curr-test-ids (dboard:tabdat-curr-test-ids tabdat)) (state-ignore-hash (dboard:tabdat-state-ignore-hash tabdat)) (test-patts (dboard:tabdat-test-patts tabdat)) (target (dboard:tabdat-target tabdat)) (dbdir (dboard:tabdat-dbdir tabdat)) (monitor-db-path (dboard:tabdat-monitor-db-path tabdat)) (path-run-ids (dboard:tabdat-path-run-ids tabdat))) (print "allruns is : " allruns) (print "allruns-by-id is : " allruns-by-id) (print "done-runs is : " done-runs) (print "not-done-runs is : " not-done-runs) (print "header is : " header ) (print "keys is : " keys) (print "numruns is : " numruns) (print "tot-runs is : " tot-runs) (print "last-data-update is : " last-data-update) (print "runs-mutex is : " runs-mutex) (print "run-update-times is : " run-update-times) (print "last-test-dat is : " last-test-dat) (print "run-db-paths is : " run-db-paths) (print "buttondat is : " buttondat) (print "item-test-names is : " item-test-names) (print "run-keys is : " run-keys) (print "start-run-offset is : " start-run-offset) (print "start-test-offset is : " start-test-offset) (print "runs-btn-height is : " runs-btn-height) (print "all-test-names is : " all-test-names) (print "cnv is : " cnv) (print "command is : " command) (print "run-name is : " run-name) (print "states is : " states) (print "statuses is : " statuses) (print "curr-run-id is : " curr-run-id) (print "curr-test-ids is : " curr-test-ids) (print "state-ignore-hash is : " state-ignore-hash) (print "test-patts is : " test-patts) (print "target is : " target) (print "dbdir is : " dbdir) (print "monitor-db-path is : " monitor-db-path) (print "path-run-ids is : " path-run-ids))) (define (dashboard:do-update-rundat tabdat) (update-rundat tabdat (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") (dboard:tabdat-numruns tabdat) (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%") (let* ((dbkeys (dboard:tabdat-dbkeys tabdat))) ;; (print "dbkeys: " dbkeys) (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 '())) ;; (print "target: " (dboard:tabdat-target tabdat)) (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)))) ;; (debug:print 0 default-log-port "fres: " fres) fres)))) (define (dashboard:runs-tab-updater commondat tab-num) (debug:catch-and-dump (lambda () (let* ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num)) (dbkeys (dboard:tabdat-dbkeys tabdat))) ;;(print "RA => calling runs-tab-updater with commondat " commondat " tab-num " tab-num) ;;(tabdat-values tabdat) ;;RA added (dashboard:do-update-rundat tabdat) (let ((uidat (dboard:commondat-uidat commondat))) ;;(print "RA => Calling update-buttons with tabdat : " tabdat " uidat " uidat) (update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat))) )) "dashboard:runs-tab-updater")) ;; ((2) ;; (dashboard:update-run-summary-tab)) ;; ((3)
︙			︙
3037 3038 3039 3040 3041 3042 3043 ~~3044~~ 3045 3046 3047 3048 ~~3049~~ 3050 3051 3052 3053 3054 3055 3056 3057 ~~3058~~ 3059 3060 3061 3062 3063 3064 3065	;; ease debugging by loading ~/.dashboardrc (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) (if (file-exists? debugcontrolf) (load debugcontrolf))) (define (main) ~~(if (not (args:get-arg "-skip-version-check"))~~(common:exit-on-version-changed))~~~~ (let* ((commondat (dboard:commondat-make))) ;; Move this stuff to db.scm? I'm not sure that is the right thing to do... (cond ((args:get-arg "-test") ;; run-id,test-id ~~(let* ((dat (let ((d (map string->number (string-split (args:get-arg "-test") ","))))~~ (if (> (length d) 1) d (list #f #f)))) (run-id (car dat)) (test-id (cadr dat))) (if (and (number? run-id) (number? test-id) (>= test-id 0)) ~~(examine-test run-id test-id)~~ (begin (debug:print 3 default-log-port "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test")) (exit 1))))) ;; ((args:get-arg "-guimonitor") ;; (gui-monitor (dboard:tabdat-dblocal tabdat))) (else (dboard:commondat-uidat-set! commondat (make-dashboard-buttons commondat)) ;; (dboard:tabdat-dblocal data)	\| > > > > > \| \|	3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298	;; ease debugging by loading ~/.dashboardrc (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) (if (file-exists? debugcontrolf) (load debugcontrolf))) (define (main) (if (not (args:get-arg "-skip-version-check")) (let ((th1 (make-thread common:exit-on-version-changed))) (thread-start! th1) (if (> megatest-version (common:get-last-run-version-number)) (debug:print-info 0 default-log-port "Version bump detected, blocking until db sync complete") (thread-join! th1)))) (let* ((commondat (dboard:commondat-make))) ;; Move this stuff to db.scm? I'm not sure that is the right thing to do... (cond ((args:get-arg "-test") ;; run-id,test-id (let* ((dat (let ((d (map string->number (string-split (args:get-arg "-test") ",")))) ;; RADT couldn't find string->number, though it works (if (> (length d) 1) d (list #f #f)))) (run-id (car dat)) (test-id (cadr dat))) (if (and (number? run-id) (number? test-id) (>= test-id 0)) (dashboard-tests:examine-test run-id test-id) (begin (debug:print 3 default-log-port "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test")) (exit 1))))) ;; ((args:get-arg "-guimonitor") ;; (gui-monitor (dboard:tabdat-dblocal tabdat))) (else (dboard:commondat-uidat-set! commondat (make-dashboard-buttons commondat)) ;; (dboard:tabdat-dblocal data)
︙			︙