Overview
Comment: | auto migrate megatest.db to new db. Allow separate overrides of monitor.db and other db's (enables putting db's in /var/tmp) |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | v1.60-openlava |
Files: | files | file ages | folders |
SHA1: |
7e968145c39135b8d3da8cebe0ab2035 |
User & Date: | matt on 2015-04-11 12:50:29 |
Other Links: | branch diff | manifest | tags |
Context
2015-04-11
| ||
15:14 | Merged v1.60 into multi-area Closed-Leaf check-in: c9f40b5f73 user: matt tags: v1.60-openlava | |
12:53 | Merged changes on openlava branch (openlava launch calls backed out) check-in: 8ce158ae19 user: matt tags: v1.60 | |
12:50 | auto migrate megatest.db to new db. Allow separate overrides of monitor.db and other db's (enables putting db's in /var/tmp) check-in: 7e968145c3 user: matt tags: v1.60-openlava | |
2015-04-04
| ||
10:00 | openlava-compatibility check-in: 7c4eb7fd5c user: matt tags: v1.60-openlava | |
Changes
Modified Makefile from [a4b4fe5222] to [9b7ed373de].
︙ | ︙ | |||
34 35 36 37 38 39 40 | # BASH_MACHTYPE=$(shell bash -c "echo \$$MACHTYPE") # ARCHSTR=$(BASH_MACHTYPE)_$(shell lsb_release -sr) ARCHSTR=$(shell lsb_release -sr) # ARCHSTR=$(shell bash -c "echo \$$MACHTYPE") all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard | | | 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | # BASH_MACHTYPE=$(shell bash -c "echo \$$MACHTYPE") # ARCHSTR=$(BASH_MACHTYPE)_$(shell lsb_release -sr) ARCHSTR=$(shell lsb_release -sr) # ARCHSTR=$(shell bash -c "echo \$$MACHTYPE") all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtest: $(OFILES) megatest.o readline-fix.scm csc $(CSCOPTS) $(OFILES) megatest.o -o mtest dboard : $(OFILES) $(GOFILES) dashboard.scm csc $(OFILES) dashboard.scm $(GOFILES) -o dboard ndboard : newdashboard.scm $(OFILES) $(GOFILES) csc $(OFILES) $(GOFILES) newdashboard.scm -o ndboard |
︙ | ︙ | |||
190 191 192 193 194 195 196 | sd : datashare-testing/sd mkdir -p /tmp/$(USER)/datashare/disk1 /tmp/$(USER)/basepath xterm : sd (export BASEPATH=/tmp/$(USER)/basepath ; export PATH="$(PWD)/datashare-testing:$(PATH)" ; xterm &) | > > > > > > > | 190 191 192 193 194 195 196 197 198 199 200 201 202 203 | sd : datashare-testing/sd mkdir -p /tmp/$(USER)/datashare/disk1 /tmp/$(USER)/basepath xterm : sd (export BASEPATH=/tmp/$(USER)/basepath ; export PATH="$(PWD)/datashare-testing:$(PATH)" ; xterm &) # "(define (toplevel-command . a) #f)" readline-fix.scm : if egrep 'version.*3.0' $(shell dirname $(shell dirname $(shell which csi)))/lib/chicken/7/readline.setup-info;then \ echo "(use-legacy-bindings)" > readline-fix.scm; \ else \ echo "" > readline-fix.scm;\ fi |
Modified configf.scm from [04a7bf6224] to [c344d55487].
︙ | ︙ | |||
83 84 85 86 87 88 89 | (sect (car parts)) (var (cadr parts))) (conc "(lambda (ht)(config-lookup ht \"" sect "\" \"" var "\"))"))) ((runconfigs-get) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) ((rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) (else "(lambda (ht)(print \"ERROR\") \"ERROR\")")))) ;; (print "fullcmd=" fullcmd) | > > > | | | | | | > | 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 | (sect (car parts)) (var (cadr parts))) (conc "(lambda (ht)(config-lookup ht \"" sect "\" \"" var "\"))"))) ((runconfigs-get) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) ((rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) (else "(lambda (ht)(print \"ERROR\") \"ERROR\")")))) ;; (print "fullcmd=" fullcmd) (handle-exceptions exn (debug:print 0 "ERROR: failed to process config input \"" l "\"") (if (or allow-system (not (member cmdtype '("system" "shell")))) (with-input-from-string fullcmd (lambda () (set! result ((eval (read)) ht)))) (set! result (conc "#{(" cmdtype ") " cmd "}")))) (loop (conc prestr result poststr))) res)) res))) ;; Run a shell command and return the output as a string (define (shell cmd) (let* ((output (cmd-run->list cmd)) (res (car output)) |
︙ | ︙ |
Modified db.scm from [cd6cb3bd8f] to [48bf00d682].
︙ | ︙ | |||
59 60 61 62 63 64 65 | ;; if db not open, open inmem, rundb and sync then return inmem ;; inuse gets set automatically for rundb's ;; (define (db:get-db dbstruct run-id) (if (sqlite3:database? dbstruct) ;; pass sqlite3 databases on through dbstruct (begin | < < < | 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 | ;; if db not open, open inmem, rundb and sync then return inmem ;; inuse gets set automatically for rundb's ;; (define (db:get-db dbstruct run-id) (if (sqlite3:database? dbstruct) ;; pass sqlite3 databases on through dbstruct (begin (let ((dbdat (if (or (not run-id) (eq? run-id 0)) (db:open-main dbstruct) (db:open-rundb dbstruct run-id) ))) dbdat)))) (define (db:dbdat-get-db dbdat) (if (pair? dbdat) (car dbdat) dbdat)) |
︙ | ︙ | |||
139 140 141 142 143 144 145 | ;; (let ((fdb (db:get-filedb dbstruct))) ;; (filedb:get-path db id))) ;; NB// #f => return dbdir only ;; (was planned to be; zeroth db with name=main.db) ;; (define (db:dbfile-path run-id) | < | | | < < < | | 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 | ;; (let ((fdb (db:get-filedb dbstruct))) ;; (filedb:get-path db id))) ;; NB// #f => return dbdir only ;; (was planned to be; zeroth db with name=main.db) ;; (define (db:dbfile-path run-id) (let* ((dbdir (or (configf:lookup *configdat* "setup" "dbdir") (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))) (fname (if run-id (if (eq? run-id 0) "main.db" (conc run-id ".db")) #f))) (handle-exceptions exn (begin (debug:print 0 "ERROR: Couldn't create path to " dbdir) (exit 1)) (if (not (directory? dbdir))(create-directory dbdir #t))) (if fname (conc dbdir "/" fname) dbdir))) (define (db:set-sync db) (let ((syncprag (configf:lookup *configdat* "setup" "sychronous"))) (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 1) ";")))) ;; open an sql database inside a file lock |
︙ | ︙ | |||
197 198 199 200 201 202 203 | (let* ((local (dbr:dbstruct-get-local dbstruct)) (rdb (if local (dbr:dbstruct-get-localdb dbstruct run-id) (dbr:dbstruct-get-inmem dbstruct)))) ;; (dbr:dbstruct-get-runrec dbstruct run-id 'inmem))) (if (or rdb do-not-open) rdb | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | > > | | | | | | | | | | > > > > | | 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 | (let* ((local (dbr:dbstruct-get-local dbstruct)) (rdb (if local (dbr:dbstruct-get-localdb dbstruct run-id) (dbr:dbstruct-get-inmem dbstruct)))) ;; (dbr:dbstruct-get-runrec dbstruct run-id 'inmem))) (if (or rdb do-not-open) rdb (begin (mutex-lock! *rundb-mutex*) (let* ((dbpath (db:dbfile-path run-id)) ;; (conc toppath "/db/" run-id ".db")) (dbexists (file-exists? dbpath)) (inmem (if local #f (db:open-inmem-db))) (refdb (if local #f (db:open-inmem-db))) (db (db:lock-create-open dbpath ;; this is the database physically on disk (lambda (db) (handle-exceptions exn (begin (release-dot-lock dbpath) (if (> attemptnum 2) (debug:print 0 "ERROR: tried twice, cannot create/initialize db for run-id " run-id ", at path " dbpath) (db:open-rundb dbstruct run-id attemptnum (+ attemptnum 1)))) (db:initialize-run-id-db db) (sqlite3:execute db "INSERT OR IGNORE INTO tests (id,run_id,testname,event_time,item_path,state,status) VALUES (?,?,'bogustest',strftime('%s','now'),'nowherepath','DELETED','n/a');" (* run-id 30000) ;; allow for up to 30k tests per run run-id) ;; do a dummy query to test that the table exists and the db is truly readable (sqlite3:execute db "SELECT * FROM tests WHERE id=?;" (* run-id 30000)) )))) ;; add strings db to rundb, not in use yet ;; )) ;; (sqlite3:open-database dbpath)) (olddb (if *megatest-db* *megatest-db* (let ((db (db:open-megatest-db))) (set! *megatest-db* db) db))) (write-access (file-write-access? dbpath)) ;; (handler (make-busy-timeout 136000)) ) (if (and dbexists (not write-access)) (set! *db-write-access* #f)) ;; only unset so other db's also can use this control (dbr:dbstruct-set-rundb! dbstruct (cons db dbpath)) (dbr:dbstruct-set-inuse! dbstruct #t) (dbr:dbstruct-set-olddb! dbstruct olddb) ;; (dbr:dbstruct-set-run-id! dbstruct run-id) (mutex-unlock! *rundb-mutex*) (if local (begin (dbr:dbstruct-set-localdb! dbstruct run-id db) ;; (dbr:dbstruct-set-inmem! dbstruct db) ;; direct access ... db) (begin (dbr:dbstruct-set-inmem! dbstruct inmem) ;; dec 14, 2014 - keep deleted records available. hunch is that they are needed for id placeholders ;; (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';") ;; they just slow us down in this context (db:sync-tables db:sync-tests-only db inmem) (db:delay-if-busy refdb) ;; dbpath: (db:dbdat-get-path refdb)) ;; What does delaying here achieve? (dbr:dbstruct-set-refdb! dbstruct refdb) (db:sync-tables db:sync-tests-only inmem refdb) ;; use inmem as the reference, don't read again from db ;; sync once more to deal with delays? ;; (db:sync-tables db:sync-tests-only db inmem) ;; (db:sync-tables db:sync-tests-only inmem refdb) inmem))))))) ;; This routine creates the db. It is only called if the db is not already ls opened ;; (define (db:open-main dbstruct) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) (let ((mdb (dbr:dbstruct-get-main dbstruct))) (if mdb mdb (begin (mutex-lock! *rundb-mutex*) (let* ((dbpath (db:dbfile-path 0)) (dbexists (file-exists? dbpath)) (db (db:lock-create-open dbpath db:initialize-main-db)) (olddb (db:open-megatest-db)) (write-access (file-write-access? dbpath)) (dbdat (cons db dbpath))) (if (and dbexists (not write-access)) (set! *db-write-access* #f)) (dbr:dbstruct-set-main! dbstruct dbdat) (dbr:dbstruct-set-olddb! dbstruct olddb) ;; olddb is already a (cons db path) (mutex-unlock! *rundb-mutex*) (if (and (not dbexists) *db-write-access*) ;; did not have a prior db and do have write access (db:multi-db-sync #f 'old2new)) ;; migrate data from megatest.db automatically dbdat))))) ;; Make the dbstruct, setup up auxillary db's and call for main db at least once ;; (define (db:setup run-id #!key (local #f)) (let* ((dbdir (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) (dbstruct (make-dbr:dbstruct path: dbdir local: local))) dbstruct)) |
︙ | ︙ |
Modified dcommon.scm from [a30707a8d1] to [207685ba58].
︙ | ︙ | |||
34 35 36 37 38 39 40 | ;; C O M M O N D A T A S T R U C T U R E ;;====================================================================== ;; ;; A single data structure for all the data used in a dashboard. ;; Share this structure between newdashboard and dashboard with the ;; intent of converging on a single app. ;; | | | 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | ;; C O M M O N D A T A S T R U C T U R E ;;====================================================================== ;; ;; A single data structure for all the data used in a dashboard. ;; Share this structure between newdashboard and dashboard with the ;; intent of converging on a single app. ;; (define *data* (make-vector 25 #f)) (define (dboard:data-get-runs vec) (vector-ref vec 0)) (define (dboard:data-get-tests vec) (vector-ref vec 1)) (define (dboard:data-get-runs-matrix vec) (vector-ref vec 2)) (define (dboard:data-get-tests-tree vec) (vector-ref vec 3)) (define (dboard:data-get-run-keys vec) (vector-ref vec 4)) (define (dboard:data-get-curr-test-ids vec) (vector-ref vec 5)) ;; (define (dboard:data-get-test-details vec) (vector-ref vec 6)) |
︙ | ︙ |
Modified items.scm from [8234d9cd3a] to [c5fa10b153].
︙ | ︙ | |||
14 15 16 17 18 19 20 | ;; (season "summer winter fall spring"))) (declare (unit items)) (declare (uses common)) (include "common_records.scm") | < < < < < < < < < < < < < < < < < < < | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | ;; (season "summer winter fall spring"))) (declare (unit items)) (declare (uses common)) (include "common_records.scm") ;; Puts out all combinations (define (process-itemlist hierdepth curritemkey itemlist) (let ((res '())) (if (not hierdepth) (set! hierdepth (length itemlist))) (let loop ((hed (car itemlist)) (tal (cdr itemlist))) |
︙ | ︙ |
Modified launch.scm from [5de4b9b150] to [fa00256018].
︙ | ︙ | |||
823 824 825 826 827 828 829 | (test-sig (conc test-name ":" item-path)) ;; (item-list->path itemdat))) ;; test-path is the full path including the item-path (work-area #f) (toptest-work-area #f) ;; for iterated tests the top test contains data relevant for all (diskpath #f) (cmdparms #f) (fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x)))) (mt-bindir-path #f) | < | 823 824 825 826 827 828 829 830 831 832 833 834 835 836 | (test-sig (conc test-name ":" item-path)) ;; (item-list->path itemdat))) ;; test-path is the full path including the item-path (work-area #f) (toptest-work-area #f) ;; for iterated tests the top test contains data relevant for all (diskpath #f) (cmdparms #f) (fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x)))) (mt-bindir-path #f) (testinfo (rmt:get-test-info-by-id run-id test-id)) (mt_target (string-intersperse (map cadr keyvals) "/")) (debug-param (append (if (args:get-arg "-debug") (list "-debug" (args:get-arg "-debug")) '()) (if (args:get-arg "-logging")(list "-logging") '())))) (setenv "MT_ITEMPATH" item-path) (if hosts (set! hosts (string-split hosts))) ;; set the megatest to be called on the remote host |
︙ | ︙ |
Modified megatest.scm from [0e40d16995] to [00a199ef0c].
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | ;; 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. ;; (include "common.scm") ;; (include "megatest-version.scm") (use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 readline apropos json http-client directory-utils rpc ;; (srfi 18) extras) http-client srfi-18 extras format) ;; zmq extras) ;; Added for csv stuff - will be removed ;; (use sparse-vectors) | > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | ;; 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. ;; (include "common.scm") ;; (include "megatest-version.scm") (define (toplevel-command . a) #f) (use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 readline apropos json http-client directory-utils rpc ;; (srfi 18) extras) http-client srfi-18 extras format) ;; zmq extras) ;; Added for csv stuff - will be removed ;; (use sparse-vectors) |
︙ | ︙ | |||
886 887 888 889 890 891 892 | (testpatt (if (args:get-arg "-testpatt") (args:get-arg "-testpatt") "%")) (keys (db:get-keys dbstruct)) ;; (runsdat (db:get-runs dbstruct runpatt #f #f '())) (runsdat (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target) #f #f)) | < | 888 889 890 891 892 893 894 895 896 897 898 899 900 901 | (testpatt (if (args:get-arg "-testpatt") (args:get-arg "-testpatt") "%")) (keys (db:get-keys dbstruct)) ;; (runsdat (db:get-runs dbstruct runpatt #f #f '())) (runsdat (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target) #f #f)) (runs (db:get-rows runsdat)) (header (db:get-header runsdat)) (db-targets (args:get-arg "-list-db-targets")) (seen (make-hash-table)) (dmode (let ((d (args:get-arg "-dumpmode"))) (if d (string->symbol d) #f))) (data (make-hash-table))) |
︙ | ︙ | |||
1248 1249 1250 1251 1252 1253 1254 | (if (args:get-arg "-runstep")(debug:print-info 1 "Running -runstep, first change to directory " work-area)) (change-directory work-area) ;; can setup as client for server mode now ;; (client:setup) (if (args:get-arg "-load-test-data") ;; has sub commands that are rdb: | | | 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 | (if (args:get-arg "-runstep")(debug:print-info 1 "Running -runstep, first change to directory " work-area)) (change-directory work-area) ;; can setup as client for server mode now ;; (client:setup) (if (args:get-arg "-load-test-data") ;; has sub commands that are rdb: ;; DO NOT put this one into either rmt: or open-run-close (tdb:load-test-data run-id test-id)) (if (args:get-arg "-setlog") (let ((logfname (args:get-arg "-setlog"))) (rmt:test-set-log! run-id test-id logfname))) (if (args:get-arg "-set-toplog") ;; DO NOT run remote (tests:test-set-toplog! run-id test-name (args:get-arg "-set-toplog"))) |
︙ | ︙ | |||
1345 1346 1347 1348 1349 1350 1351 | (args:get-arg "-show-keys")) (let ((db #f) (keys #f)) (if (not (launch:setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) | | | 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 | (args:get-arg "-show-keys")) (let ((db #f) (keys #f)) (if (not (launch:setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (set! keys (rmt:get-keys)) ;; db)) (debug:print 1 "Keys: " (string-intersperse keys ", ")) (if (sqlite3:database? db)(sqlite3:finalize! db)) (set! *didsomething* #t))) (if (args:get-arg "-gui") (begin (debug:print 0 "Look at the dashboard for now") |
︙ | ︙ | |||
1428 1429 1430 1431 1432 1433 1434 | (set! *didsomething* #t))) ;;====================================================================== ;; Start a repl ;;====================================================================== ;; fakeout readline | < > | 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 | (set! *didsomething* #t))) ;;====================================================================== ;; Start a repl ;;====================================================================== ;; fakeout readline (if (or (args:get-arg "-repl") (args:get-arg "-load")) (let* ((toppath (launch:setup-for-run)) (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))) (if dbstruct (begin (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") (gnu-history-install-file-manager (string-append (or (get-environment-variable "HOME") ".") "/.megatest_history")) (current-input-port (make-gnu-readline-port "megatest> ")) (if (args:get-arg "-repl") (repl) (load (args:get-arg "-load"))) |
︙ | ︙ |
Modified mt.scm from [15956fcc00] to [c221837872].
︙ | ︙ | |||
182 183 184 185 186 187 188 | (if newstate (rmt:general-call 'set-test-state run-id newstate test-id)) (if newstatus (rmt:general-call 'set-test-status run-id newstatus test-id)) (if newcomment (rmt:general-call 'set-test-comment run-id newcomment test-id)))) (mt:process-triggers run-id test-id newstate newstatus) #t))) (define (mt:test-set-state-status-by-testname run-id test-name item-path new-state new-status new-comment) | | | 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 | (if newstate (rmt:general-call 'set-test-state run-id newstate test-id)) (if newstatus (rmt:general-call 'set-test-status run-id newstatus test-id)) (if newcomment (rmt:general-call 'set-test-comment run-id newcomment test-id)))) (mt:process-triggers run-id test-id newstate newstatus) #t))) (define (mt:test-set-state-status-by-testname run-id test-name item-path new-state new-status new-comment) (let ((test-id (rmt:get-test-id run-id test-name item-path))) (mt:test-set-state-status-by-id test-id new-state new-status new-comment))) (define (mt:lazy-read-test-config test-name) (let ((tconf (hash-table-ref/default *testconfigs* test-name #f))) (if tconf tconf (let ((test-dirs (tests:get-tests-search-path *configdat*))) |
︙ | ︙ |
Modified runs.scm from [61baf1971a] to [4e55b0ef22].
︙ | ︙ | |||
893 894 895 896 897 898 899 | (define (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests reglen-in all-tests-registry) ;; At this point the list of parent tests is expanded ;; NB// Should expand items here and then insert into the run queue. (debug:print 5 "test-records: " test-records ", flags: " (hash-table->alist flags)) ;; Do mark-and-find clean up of db before starting runing of quue ;; | | | 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 | (define (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests reglen-in all-tests-registry) ;; At this point the list of parent tests is expanded ;; NB// Should expand items here and then insert into the run queue. (debug:print 5 "test-records: " test-records ", flags: " (hash-table->alist flags)) ;; Do mark-and-find clean up of db before starting runing of quue ;; ;; (rmt:find-and-mark-incomplete) (let ((run-info (rmt:get-run-info run-id)) (tests-info (mt:get-tests-for-run run-id #f '() '())) ;; qryvals: "id,testname,item_path")) (sorted-test-names (tests:sort-by-priority-and-waiton test-records)) (test-registry (make-hash-table)) (registry-mutex (make-mutex)) (num-retries 0) |
︙ | ︙ | |||
1589 1590 1591 1592 1593 1594 1595 | (let* ((dparts (string-split lasttpath "/")) (runpath (conc "/" (string-intersperse (take dparts (- (length dparts) 1)) "/")))) (debug:print 1 "Removing run: " runkey " " (db:get-value-by-header run header "runname") " and related record") (rmt:delete-run run-id) (rmt:delete-old-deleted-test-records) | | | 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 | (let* ((dparts (string-split lasttpath "/")) (runpath (conc "/" (string-intersperse (take dparts (- (length dparts) 1)) "/")))) (debug:print 1 "Removing run: " runkey " " (db:get-value-by-header run header "runname") " and related record") (rmt:delete-run run-id) (rmt:delete-old-deleted-test-records) ;; (rmt:set-var "DELETED_TESTS" (current-seconds)) ;; need to figure out the path to the run dir and remove it if empty ;; (if (null? (glob (conc runpath "/*"))) ;; (begin ;; (debug:print 1 "Removing run dir " runpath) ;; (system (conc "rmdir -p " runpath)))) ))))) )) |
︙ | ︙ | |||
1672 1673 1674 1675 1676 1677 1678 | (let (;; (db #f) (keys #f)) (if (launch:setup-for-run) (launch:cache-config) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) | < < | 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 | (let (;; (db #f) (keys #f)) (if (launch:setup-for-run) (launch:cache-config) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (set! keys (keys:config-get-fields *configdat*)) ;; have enough to process -target or -reqtarg here (if (args:get-arg "-reqtarg") (let* ((runconfigf (conc *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL (runconfig (read-config runconfigf #f #t environ-patt: #f))) (if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f) (keys:target-set-args keys (args:get-arg "-reqtarg") args:arg-hash) |
︙ | ︙ | |||
1792 1793 1794 1795 1796 1797 1798 | (conc "INSERT OR REPLACE INTO tests (run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment) " "VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?);") new-run-id (cddr (vector->list testdat))) (set! new-testdat (car (mt:get-tests-for-run new-run-id (conc testname "/" item-path) '() '()))) (hash-table-set! curr-tests-hash full-name new-testdat) ;; this could be confusing, which record should go into the lookup table? ;; Now duplicate the test steps (debug:print 4 "Copying records in test_steps from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat)) | | | 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 | (conc "INSERT OR REPLACE INTO tests (run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment) " "VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?);") new-run-id (cddr (vector->list testdat))) (set! new-testdat (car (mt:get-tests-for-run new-run-id (conc testname "/" item-path) '() '()))) (hash-table-set! curr-tests-hash full-name new-testdat) ;; this could be confusing, which record should go into the lookup table? ;; Now duplicate the test steps (debug:print 4 "Copying records in test_steps from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat)) (cdb:remote-run ;; to be replaced, note: this routine is not used currently (lambda () (sqlite3:execute db (conc "INSERT OR REPLACE INTO test_steps (test_id,stepname,state,status,event_time,comment) " "SELECT " (db:test-get-id new-testdat) ",stepname,state,status,event_time,comment FROM test_steps WHERE test_id=?;") (db:test-get-id testdat)) ;; Now duplicate the test data |
︙ | ︙ |
Modified synchash.scm from [67fbbc1d0f] to [1596fbcb93].
︙ | ︙ | |||
54 55 56 57 58 59 60 | (set! deleted (cons id deleted)) (hash-table-delete! synchash id)))) orig-keys) (list changed deleted) ;; (list indat '()) ;; just for debugging )) | < < < < | 54 55 56 57 58 59 60 61 62 63 64 65 66 67 | (set! deleted (cons id deleted)) (hash-table-delete! synchash id)))) orig-keys) (list changed deleted) ;; (list indat '()) ;; just for debugging )) ;; keynum => the field to use as the unique key (usually 0 but can be other field) ;; (define (synchash:client-get proc synckey keynum synchash run-id . params) (let* ((data (rmt:synchash-get run-id proc synckey keynum params)) (newdat (car data)) (removs (cadr data)) (myhash (hash-table-ref/default synchash synckey #f))) |
︙ | ︙ |
Modified tasks.scm from [590db5beef] to [a2f9968b1b].
︙ | ︙ | |||
51 52 53 54 55 56 57 | (- count 1))) (begin (if remove (system (conc "rm -rf " fullpath))) #f))) #t)))))) (define (tasks:get-task-db-path) | > | | > > | | | > > | 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 | (- count 1))) (begin (if remove (system (conc "rm -rf " fullpath))) #f))) #t)))))) (define (tasks:get-task-db-path) (let ((dbdir (or (configf:lookup *configdat* "setup" "monitordir") (configf:lookup *configdat* "setup" "dbdir") (conc (configf:lookup *configdat* "setup" "linktree") "/.db")))) (handle-exceptions exn (begin (debug:print 0 "ERROR: Couldn't create path to " dbdir) (exit 1)) (if (not (directory? dbdir))(create-directory dbdir #t))) dbdir)) ;; If file exists AND ;; file readable ;; ==> open it ;; If file exists AND ;; file NOT readable ;; ==> open in-mem version |
︙ | ︙ |
Modified tests/fullrun/megatest.config from [02f469b7ea] to [ce641a4a1c].
︙ | ︙ | |||
19 20 21 22 23 24 25 26 27 28 29 30 31 | home #{shell readlink -f $MT_RUN_AREA_HOME} parent #{shell readlink -f $MT_RUN_AREA_HOME/..} [tests-paths] 1 #{get misc parent}/simplerun/tests [setup] # Set launchwait to no to use the more agressive code that does not wait for the launch to complete before proceeding # this may save a few milliseconds on launching tests # launchwait no waivercommentpatt ^WW\d+ [a-z].* incomplete-timeout 1 | > > > > > > > < < < | 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 | home #{shell readlink -f $MT_RUN_AREA_HOME} parent #{shell readlink -f $MT_RUN_AREA_HOME/..} [tests-paths] 1 #{get misc parent}/simplerun/tests [setup] # put monitor.db in MT_RUN_AREA_HOME/db monitordir #{getenv MT_RUN_AREA_HOME}/db # set the dbdir to /var/tmp/$USER/mt_db, default is linktree dbdir /var/tmp/#{getenv USER}/mt_db # Set launchwait to no to use the more agressive code that does not wait for the launch to complete before proceeding # this may save a few milliseconds on launching tests # launchwait no waivercommentpatt ^WW\d+ [a-z].* incomplete-timeout 1 # wait for runs to completely complete. yes, anything else is no run-wait yes # If set to "default" the old code is used. Otherwise defaults to 200 or uses # numeric value given. # runqueue 20 |
︙ | ︙ | |||
205 206 207 208 209 210 211 | # Archives will be organised under these paths like this: # <testsuite>/<creationdate> # Within the archive the data is structured like this: # <target>/<runname>/<test>/ disk0 /tmp/#{getenv USER}/adisk1 # Uncomment these to emulate a job queue with a long time (look in bin/sleeprunner for the time) | | | | | | | | | 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 | # Archives will be organised under these paths like this: # <testsuite>/<creationdate> # Within the archive the data is structured like this: # <target>/<runname>/<test>/ disk0 /tmp/#{getenv USER}/adisk1 # Uncomment these to emulate a job queue with a long time (look in bin/sleeprunner for the time) # [jobtools] # launcher #{scheme (case (string->symbol (conc (getenv "datapath"))) \ # ((none) "nbfake") \ # ((openlava) "bsub") \ # (else "sleeprunner"))} # # launcher bsub -q priority -o $MT_TEST_RUN_DIR/openlava.log |