Changes In Branch refactor-db Through [5a1b924a67] Excluding Merge-Ins
This is equivalent to a diff from b1700997ff to 5a1b924a67
2014-11-30
| ||
12:37 | Merged v1.60 into old dev branch Closed-Leaf check-in: 61fd6d3c06 user: matt tags: dev | |
2013-10-19
| ||
10:36 | Merged refactor-api into refactor-db check-in: 45b4ad07c1 user: matt tags: refactor-db | |
10:24 | Partial edits for refactor of db, committing prior to trying to merge in the api branch check-in: 5a1b924a67 user: matt tags: refactor-db | |
2013-10-18
| ||
00:20 | Ported tests.scm to dbstruct check-in: a3f5835386 user: matt tags: refactor-db | |
2013-10-15
| ||
22:18 | Start restructuring db check-in: 3a478cdcba user: matt tags: refactor-db | |
2013-10-13
| ||
23:17 | More on the performance analysis check-in: b1700997ff user: matt tags: dev | |
17:59 | Part one of sqlite3 test done check-in: bc4a22eff5 user: matt tags: dev | |
Modified Makefile from [269d99e807] to [43096021d4].
1 2 3 4 5 6 7 8 9 10 | # make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)' PREFIX=$(PWD) CSCOPTS= INSTALL=install SRCFILES = common.scm items.scm launch.scm \ ods.scm runconfig.scm server.scm configf.scm \ db.scm keys.scm margs.scm megatest-version.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ fs-transport.scm http-transport.scm \ client.scm gutils.scm synchash.scm daemon.scm mt.scm dcommon.scm \ | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | # make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)' PREFIX=$(PWD) CSCOPTS= INSTALL=install SRCFILES = common.scm items.scm launch.scm \ ods.scm runconfig.scm server.scm configf.scm \ db.scm keys.scm margs.scm megatest-version.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ fs-transport.scm http-transport.scm \ client.scm gutils.scm synchash.scm daemon.scm mt.scm dcommon.scm \ tree.scm ezsteps.scm lock-queue.scm filedb.scm GUISRCF = dashboard-tests.scm dashboard-guimonitor.scm OFILES = $(SRCFILES:%.scm=%.o) GOFILES = $(GUISRCF:%.scm=%.o) ADTLSCR=mt_laststep mt_runstep mt_ezstep |
︙ | ︙ | |||
57 58 59 60 61 62 63 | # Special dependencies for the includes tests.o db.o launch.o runs.o dashboard-tests.o dashboard-guimonitor.o dashboard-main.o monitor.o dashboard.o megatest.o : db_records.scm tests.o runs.o dashboard.o dashboard-tests.o dashboard-main.o : run_records.scm db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm tests.o tasks.o dashboard-tasks.o : task_records.scm | | > | 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 | # Special dependencies for the includes tests.o db.o launch.o runs.o dashboard-tests.o dashboard-guimonitor.o dashboard-main.o monitor.o dashboard.o megatest.o : db_records.scm tests.o runs.o dashboard.o dashboard-tests.o dashboard-main.o : run_records.scm db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm tests.o tasks.o dashboard-tasks.o : task_records.scm runs.o : test_records.scm megatest.o : megatest-fossil-hash.scm filedb.o : fdb_records.scm # Temporary while transitioning to new routine # runs.o : run-tests-queue-classic.scm run-tests-queue-new.scm megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm echo "(define megatest-fossil-hash \"$(MTESTHASH)\")" > megatest-fossil-hash.new if ! diff -q megatest-fossil-hash.new megatest-fossil-hash.scm ; then echo copying .new to .scm;cp -f megatest-fossil-hash.new megatest-fossil-hash.scm;fi |
︙ | ︙ |
Modified common.scm from [23d24f4c55] to [236bfdcd02].
︙ | ︙ | |||
25 26 27 28 29 30 31 | ;; (include "margs.scm") (define getenv get-environment-variable) (define home (getenv "HOME")) (define user (getenv "USER")) | | > > > > > | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 | ;; (include "margs.scm") (define getenv get-environment-variable) (define home (getenv "HOME")) (define user (getenv "USER")) ;; GLOBAL GLETCHES (define *db-keys* #f) (define *configinfo* #f) (define *configdat* #f) (define *toppath* #f) (define *already-seen-runconfig-info* #f) (define *waiting-queue* (make-hash-table)) (define *test-meta-updated* (make-hash-table)) (define *globalexitstatus* 0) ;; attempt to work around possible thread issues (define *passnum* 0) ;; when running track calls to run-tests or similar (define *global-delta* 0) (define *last-global-delta-printed* 0) ;; DATABASE (define *open-dbs* (vector #f (make-hash-table))) ;; megatestdb run-id-dbs ;; SERVER (define *my-client-signature* #f) (define *transport-type* 'fs) (define *megatest-db* #f) (define *rpc:listener* #f) ;; if set up for server communication this will hold the tcp port (define *runremote* #f) ;; if set up for server communication this will hold <host port> |
︙ | ︙ | |||
90 91 92 93 94 95 96 | (set! *test-id-cache* (make-hash-table))) ;;====================================================================== ;; S T A T E S A N D S T A T U S E S ;;====================================================================== (define *common:std-states* | > > > | > > > > > > > > > > > > | | 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 | (set! *test-id-cache* (make-hash-table))) ;;====================================================================== ;; S T A T E S A N D S T A T U S E S ;;====================================================================== (define *common:std-states* '((0 "COMPLETED") (1 "NOT_STARTED") (2 "RUNNING") (3 "REMOTEHOSTSTART") (4 "LAUNCHED") (5 "KILLED") (6 "KILLREQ") (7 "STUCK"))) (define *common:std-statuses* '((0 "PASS") (1 "WARN") (2 "FAIL") (3 "CHECK") (4 "n/a") (5 "WAIVED") (6 "SKIP") (7 "DELETED") (8 "STUCK/DEAD"))) ;; These are stopping conditions that prevent a test from being run (define *common:cant-run-states-sym* '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) ;;====================================================================== ;; D E B U G G I N G S T U F F |
︙ | ︙ |
Modified common_records.scm from [7793eb36cc] to [e135053931].
︙ | ︙ | |||
42 43 44 45 46 47 48 | (debug:check-verbosity *verbosity* debugstr) (if (or (args:get-arg "-debug") (not (getenv "MT_DEBUG_MODE"))) (setenv "MT_DEBUG_MODE" (if (list? *verbosity*) (string-intersperse (map conc *verbosity*) ",") (conc *verbosity*)))))) | < | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 | (debug:check-verbosity *verbosity* debugstr) (if (or (args:get-arg "-debug") (not (getenv "MT_DEBUG_MODE"))) (setenv "MT_DEBUG_MODE" (if (list? *verbosity*) (string-intersperse (map conc *verbosity*) ",") (conc *verbosity*)))))) (define (debug:print n . params) (if (debug:debug-mode n) (with-output-to-port (current-error-port) (lambda () (if *logging* (db:log-event (apply conc params)) (apply print params) |
︙ | ︙ |
Modified db.scm from [a7b6fe1509] to [6cf3bdce2e].
︙ | ︙ | |||
26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 | (declare (unit db)) (declare (uses common)) (declare (uses keys)) (declare (uses ods)) (declare (uses fs-transport)) (declare (uses client)) (declare (uses mt)) (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") (include "run_records.scm") ;; timestamp type (val1 val2 ...) ;; type: meta-info, step (define *incoming-writes* '()) (define *completed-writes* (make-hash-table)) (define *incoming-last-time* (current-seconds)) (define *incoming-mutex* (make-mutex)) (define *completed-mutex* (make-mutex)) | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > | > > > > > > > > | < > > | | > | | > | > | < < < < < < < > > | > > > > > | | | | | | > | | > > > > > > > > > | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 | (declare (unit db)) (declare (uses common)) (declare (uses keys)) (declare (uses ods)) (declare (uses fs-transport)) (declare (uses client)) (declare (uses mt)) (declare (uses filedb)) (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") (include "run_records.scm") ;; timestamp type (val1 val2 ...) ;; type: meta-info, step (define *incoming-writes* '()) (define *completed-writes* (make-hash-table)) (define *incoming-last-time* (current-seconds)) (define *incoming-mutex* (make-mutex)) (define *completed-mutex* (make-mutex)) (define (db:get-db dbstruct run-id) (let ((db (if run-id (hash-table-ref/default (vector-ref dbstruct 1) run-id #f) (vector-ref dbstruct 0)))) (if db db (let ((db (open-db run-id))) (if run-id (hash-table-set! (vector-ref dbstruct 1) run-id db) (vector-set! dbstruct 0 db)) db)))) ;;====================================================================== ;; K E E P F I L E D B I N dbstruct ;;====================================================================== (define (db:get-filedb dbstruct) (let ((db (vector-ref dbstruct 2))) (if db db (let ((fdb (filedb:open-db (conc *toplevel* "/db/files.db")))) (vector-set! dbstruct 2 fdb) fdb)))) ;; Can also be used to save arbitrary strings ;; (define (db:save-path dbstruct path) (let ((fdb (db:get-filedb dbstruct))) (filedb:register-path fdb path))) ;; Use to get a path. To get an arbitrary string see next define ;; (define (db:get-path dbstruct id) (let ((fdb (db:get-filedb dbstruct))) (filedb:get-path db id))) ;;====================================================================== ;; U S E F I L E D B T O S T O R E S T R I N G S ;; ;; N O T E ! ! T H I S C L O B B E R S M U L T I P L E //// T O / ;; ;; Replace with something proper! ;; ;;====================================================================== ;; Use to save a stored string, pad with _ to deal with trimming the prepending of / ;; (define (db:save-string dbstruct str) (let ((fdb (db:get-filedb dbstruct))) (filedb:register-path fdb (conc "_" str)))) ;; Use to get a stored string ;; (define (db:get-string dbstruct id) (let ((fdb (db:get-filedb dbstruct))) (string-drop (filedb:get-path fdb id) 2))) ;; This routine creates the db. It is only called if the db is not already opened ;; (define (open-db dbstruct run-id) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) (if (not *toppath*) (if (not (setup-for-run)) (begin (debug:print 0 "ERROR: Attempted to open db when not in megatest area. Exiting.") (exit)))) (let* ((dbpath (if run-id (conc *toppath* "/db/" run-id ".db") (let ((dbdir (conc *toppath* "/db"))) ;; use this opportunity to create our db dir (if (not (directory-exists? dbdir)) (create-direcory dbdir)) (conc *toppath* "/megatest.db")))) (dbexists (file-exists? dbpath)) (write-access (file-write-access? dbpath)) (db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath)) (handler (make-busy-timeout (if (args:get-arg "-override-timeout") (string->number (args:get-arg "-override-timeout")) 136000)))) ;; 136000))) ;; 136000 = 2.2 minutes (if (and dbexists (not write-access)) (set! *db-write-access* write-access)) ;; only unset so other db's also can use this control (debug:print-info 11 "open-db, dbpath=" dbpath " argv=" (argv)) (sqlite3:set-busy-handler! db handler) (if (not dbexists) (if (not run-id) ;; do the megatest.db (db:initialize-megatest-db db) (db:initialize-run-id-db db run-id))) (sqlite3:execute db "PRAGMA synchronous = 0;") db)) ;; close all opened run-id dbs (define (db:close-all-db) (for-each (lambda (db) (finalize! db)) (hash-table-values (vector-ref *open-dbs* 1))) (finalize! (vector-ref *open-dbs* 0))) ;; keeping it around for debugging purposes only (define (open-run-close-no-exception-handling proc idb . params) (debug:print-info 11 "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params) (let* ((db (if idb (if (procedure? idb) (idb) idb) |
︙ | ︙ | |||
108 109 110 111 112 113 114 | (debug:print 0 " " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain) (thread-sleep! (random 120)) (debug:print-info 0 "trying db call one more time....") (apply open-run-close-no-exception-handling proc idb params)) (apply open-run-close-no-exception-handling proc idb params))) | | | < < < < | < < < < < < < < < < < < < < < | < | < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | < < < < < < < < < < < < < > > > | < < < < < < < < < < | > | < | < < < < < < < < < < < < < < < < < < < | | < | > | | | | | | | | | | < > | > > | > > > > > > > | < < < < | < < < < < < | | < | < < < < < > | | | < < > | | | | | | < | > | | | | | | | | < < < | | | < < < < < | < < | < < > | 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 | (debug:print 0 " " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain) (thread-sleep! (random 120)) (debug:print-info 0 "trying db call one more time....") (apply open-run-close-no-exception-handling proc idb params)) (apply open-run-close-no-exception-handling proc idb params))) ;; (define open-run-close (define open-run-close (if (debug:debug-mode 2) open-run-close-no-exception-handling open-run-close-exception-handling)) (define (db:initialize-megatest-db db) (let* ((configdat (car *configinfo*)) ;; tut tut, global warning... (keys (keys:configq-get-fields configdat)) (havekeys (> (length keys) 0)) (keystr (keys->keystr keys)) (fieldstr (keys->key/field keys))) (for-each (lambda (key) (let ((keyn key)) (if (member (string-downcase keyn) (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count")) (begin (print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table") (system (conc "rm -f " dbpath)) (exit 1))))) keys) (sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));") (for-each (lambda (key) (sqlite3:execute db "INSERT INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT")) keys) (sqlite3:execute db (conc "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, " fieldstr (if havekeys "," "") "runname TEXT," "state TEXT DEFAULT ''," "status TEXT DEFAULT ''," "owner TEXT DEFAULT ''," "event_time TIMESTAMP," "comment TEXT DEFAULT ''," "fail_count INTEGER DEFAULT 0," "pass_count INTEGER DEFAULT 0," "CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));")) (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta ( id INTEGER PRIMARY KEY, testname TEXT DEFAULT '', author TEXT DEFAULT '', owner TEXT DEFAULT '', description TEXT DEFAULT '', reviewed TIMESTAMP, iterated TEXT DEFAULT '', avg_runtime REAL, avg_disk REAL, tags TEXT DEFAULT '', jobgroup TEXT DEFAULT 'default', CONSTRAINT test_meta_constraint UNIQUE (testname));") (sqlite3:execute db (conc "CREATE INDEX runs_index ON runs (runname" (if havekeys "," "") keystr ");")) ;; (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, CONSTRAINT metadat_constraint UNIQUE (var));") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") ;; Must do this *after* running patch db !! No more. (db:set-var db "MEGATEST_VERSION" megatest-version) (debug:print-info 11 "db:initialize END"))) ;;====================================================================== ;; R U N S P E C I F I C D B ;;====================================================================== (define (db:initialized-run-id-db db run-id) (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tests (id INTEGER PRIMARY KEY, run_id INTEGER, testname TEXT, host TEXT DEFAULT 'n/a', cpuload REAL DEFAULT -1, diskfree INTEGER DEFAULT -1, uname TEXT DEFAULT 'n/a', rundir_id INTEGER, realdir_id INTEGER, item_path TEXT DEFAULT '', state TEXT DEFAULT 'NOT_STARTED', status TEXT DEFAULT 'FAIL', attemptnum INTEGER DEFAULT 0, final_logf TEXT DEFAULT 'logs/final.log', logdat BLOB, run_duration INTEGER DEFAULT 0, comment TEXT DEFAULT '', event_time TIMESTAMP, fail_count INTEGER DEFAULT 0, pass_count INTEGER DEFAULT 0, archived INTEGER DEFAULT 0, -- 0=no, 1=in progress, 2=yes CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path));") (sqlite3:execute db "CREATE INDEX tests_index ON tests (run_id, testname, item_path);") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps (id INTEGER PRIMARY KEY, test_id INTEGER, stepname TEXT, state TEXT DEFAULT 'NOT_STARTED', status TEXT DEFAULT 'n/a', event_time TIMESTAMP, comment TEXT DEFAULT '', logfile TEXT DEFAULT '', CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, test_id INTEGER, category TEXT DEFAULT '', variable TEXT, value REAL, expected REAL, tol REAL, units TEXT, comment TEXT DEFAULT '', status TEXT DEFAULT 'n/a', type TEXT DEFAULT '', CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat ( id INTEGER PRIMARY KEY, test_id INTEGER, update_time TIMESTAMP, cpuload INTEGER DEFAULT -1, diskfree INTEGER DEFAULT -1, diskusage INTGER DEFAULT -1, run_duration INTEGER DEFAULT 0);") db) ;;====================================================================== ;; L O G G I N G D B ;;====================================================================== (define (open-logging-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) (let* ((dbpath (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname) |
︙ | ︙ | |||
358 359 360 361 362 363 364 | (begin (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log (id INTEGER PRIMARY KEY,event_time TIMESTAMP DEFAULT (strftime('%s','now')),logline TEXT,pwd TEXT,cmdline TEXT,pid INTEGER);") (sqlite3:execute db (conc "PRAGMA synchronous = 0;")))) db)) (define (db:log-local-event . loglst) (let ((logline (apply conc loglst))) | < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | > > > > | | | | | | | | | | | | | | | < < < < > > > > | < > | < | < | < | < | < | | | | | | | 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 | (begin (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log (id INTEGER PRIMARY KEY,event_time TIMESTAMP DEFAULT (strftime('%s','now')),logline TEXT,pwd TEXT,cmdline TEXT,pid INTEGER);") (sqlite3:execute db (conc "PRAGMA synchronous = 0;")))) db)) (define (db:log-local-event . loglst) (let ((logline (apply conc loglst))) (db:log-event logline))) (define (db:log-event logline) (let ((db (open-logging-db))) (sqlite3:execute db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);" logline (current-directory) (string-intersperse (argv) " ") (current-process-id)) (sqlite3:finalize! db) logline)) ;;====================================================================== ;; D B U T I L S ;;====================================================================== ;; Clean out old junk and vacuum the database ;; ;; Ultimately do something like this: ;; ;; 1. Look at test records either deleted or part of deleted run: ;; a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown' ;; b. If test dir gone, delete the test record ;; 2. Look at run records ;; a. If have tests that are not deleted, set state='unknown' ;; b. .... ;; (define (db:clean-up dbstruct) (debug:print 0 "ERROR: db clean up not ported yet") (let* ((db (db:get-db dbstruct #f)) (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);")) (statements (map (lambda (stmt) (sqlite3:prepare db stmt)) (list ;; delete all tests that belong to runs that are 'deleted' "DELETE FROM tests WHERE run_id in (SELECT id FROM runs WHERE state='deleted');" ;; delete all tests that are 'DELETED' "DELETE FROM tests WHERE state='DELETED';" ;; delete all tests that have no run "DELETE FROM tests WHERE run_id NOT IN (SELECT DISTINCT id FROM runs);" ;; delete all runs that are state='deleted' "DELETE FROM runs WHERE state='deleted';" ;; delete empty runs "DELETE FROM runs WHERE id NOT IN (SELECT DISTINCT r.id FROM runs AS r INNER JOIN tests AS t ON t.run_id=r.id);" )))) (sqlite3:with-transaction db (lambda () (sqlite3:for-each-row (lambda (tot) (debug:print-info 0 "Records count before clean: " tot)) count-stmt) (map sqlite3:execute statements) (sqlite3:for-each-row (lambda (tot) (debug:print-info 0 "Records count after clean: " tot)) count-stmt))) (map sqlite3:finalize! statements) (sqlite3:finalize! count-stmt) (sqlite3:execute db "VACUUM;"))) ;;====================================================================== ;; M E T A G E T A N D S E T V A R S ;;====================================================================== ;; returns number if string->number is successful, string otherwise ;; also updates *global-delta* ;; ;; Operates on megatestdb ;; (define (db:get-var dbstruct var) (let* ((start-ms (current-milliseconds)) (throttle (let ((t (config-lookup *configdat* "setup" "throttle"))) (if t (string->number t) t))) (res #f)) (sqlite3:for-each-row (lambda (val) (set! res val)) (db:get-db dbstruct #f) "SELECT val FROM metadat WHERE var=?;" var) ;; convert to number if can (if (string? res) (let ((valnum (string->number res))) (if valnum (set! res valnum)))) ;; scale by 10, average with current value. (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms) (if throttle throttle 0.01))) 2)) (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit (begin (debug:print-info 4 "launch throttle factor=" *global-delta*) (set! *last-global-delta-printed* *global-delta*))) res)) (define (db:set-var dbstruct var val) (sqlite3:execute (db:get-db dbstruct #f) "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val)) (define (db:del-var dbstruct var) (sqlite3:execute (db:get-db dbstruct #f) "DELETE FROM metadat WHERE var=?;" var)) ;; use a global for some primitive caching, it is just silly to ;; re-read the db over and over again for the keys since they never ;; change ;; why get the keys from the db? why not get from the *configdat* ;; using keys:config-get-fields? (define (db:get-keys dbstruct) (if *db-keys* *db-keys* (let ((res '())) (sqlite3:for-each-row (lambda (key) (set! res (cons key res))) (db:get-db dbstruct #f) "SELECT fieldname FROM keys ORDER BY id DESC;") (set! *db-keys* res) res))) ;; (define (db:get-value-by-header row header field) (debug:print-info 4 "db:get-value-by-header row: " row " header: " header " field: " field) (if (null? header) #f (let loop ((hed (car header)) (tal (cdr header)) (n 0)) (if (equal? hed field) (vector-ref row n) (if (null? tal) #f (loop (car tal)(cdr tal)(+ n 1))))))) ;;====================================================================== ;; R U N S ;;====================================================================== (define (db:get-run-name-from-id dbstruct run-id) (let ((res #f)) (sqlite3:for-each-row (lambda (runname) (set! res runname)) (db:get-db dbstruct #f) "SELECT runname FROM runs WHERE id=?;" run-id) res)) (define (db:get-run-key-val dbstruct run-id key) (let ((res #f)) (sqlite3:for-each-row (lambda (val) (set! res val)) (db:get-db dbstruct #f) (conc "SELECT " key " FROM runs WHERE id=?;") run-id) res)) ;; keys list to key1,key2,key3 ... (define (runs:get-std-run-fields keys remfields) (let* ((header (append keys remfields)) |
︙ | ︙ | |||
619 620 621 622 623 624 625 | (if (null? patts) '("") patts)) comparator))) ;; register a test run with the db | | > | | 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 | (if (null? patts) '("") patts)) comparator))) ;; register a test run with the db (define (db:register-run dbstruct keyvals runname state status user) (debug:print 3 "runs:register-run runname: " runname " state: " state " status: " status " user: " user) (let* ((db (db:get-db dbstruct #f)) (keys (map car keyvals)) (keystr (keys->keystr keys)) (comma (if (> (length keys) 0) "," "")) (andstr (if (> (length keys) 0) " AND " "")) (valslots (keys->valslots keys)) ;; ?,?,? ... (allvals (append (list runname state status user) (map cadr keyvals))) (qryvals (append (list runname) (map cadr keyvals))) (key=?str (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND "))) |
︙ | ︙ | |||
655 656 657 658 659 660 661 | ;; replace header and keystr with a call to runs:get-std-run-fields ;; ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; runpatts: patt1,patt2 ... ;; | | > | | | 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 | ;; replace header and keystr with a call to runs:get-std-run-fields ;; ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; runpatts: patt1,patt2 ... ;; (define (db:get-runs dbstruct runpatt count offset keypatts) (let* ((db (db:get-db dbstruct #f)) (res '()) (keys (db:get-keys dbstruct)) (runpattstr (db:patt->like "runname" runpatt)) (remfields (list "id" "runname" "state" "status" "owner" "event_time")) (header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ","))) (qrystr (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? " ;; Generate: " AND x LIKE 'keypatt' ..." |
︙ | ︙ | |||
693 694 695 696 697 698 699 | qrystr ) (debug:print-info 11 "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) (vector header res))) ;; Get all targets from the db ;; | | | | | | | | > > > > > > > > | > > > > | | | | | | | | | | > | | 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 | qrystr ) (debug:print-info 11 "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) (vector header res))) ;; Get all targets from the db ;; (define (db:get-targets dbstruct) (let* ((res '()) (keys (db:get-keys dbstruct)) (header keys) ;; (map key:get-fieldname keys)) (keystr (keys->keystr keys)) (qrystr (conc "SELECT " keystr " FROM runs;")) (seen (make-hash-table))) (sqlite3:for-each-row (lambda (a . x) (let ((targ (cons a x))) (if (not (hash-table-ref/default seen targ #f)) (begin (hash-table-set! seen targ #t) (set! res (cons (apply vector targ) res)))))) (db:get-db dbstruct #f) qrystr) (debug:print-info 11 "db:get-targets END qrystr: " qrystr ) (vector header res))) ;; just get count of runs (define (db:get-num-runs dbstruct runpatt) (let ((numruns 0)) (debug:print-info 11 "db:get-num-runs START " runpatt) (sqlite3:for-each-row (lambda (count) (set! numruns count)) (db:get-db dbstruct #f) "SELECT COUNT(id) FROM runs WHERE runname LIKE ? AND state != 'deleted';" runpatt) (debug:print-info 11 "db:get-num-runs END " runpatt) numruns)) ;; get some basic run stats ;; ;; ( (runname (( state count ) ... )) ;; ( ... (define (db:get-run-stats dbstruct) (let ((totals (make-hash-table)) (res '()) (runs-info '())) ;; First get all the runname/run-ids (sqlite3:for-each-row (lambda (run-id runname) (set! runs-info (cons (list runname run-id) runs-info))) (db:get-db dbstruct #f) "SELECT id,runname FROM runs;") ;; for each run get stats data (for-each (lambda (run-info) (let ((run-name (cadr run-info)) (run-id (car run-info))) (sqlite3:for-each-row (lambda (state count) (let* ((stateparts (string-split state "|")) (newstate (conc (car stateparts) "\n" (cadr stateparts)))) (hash-table-set! totals newstate (+ (hash-table-ref/default totals newstate 0) count)) (set! res (cons (list runname newstate count) res)))) (db:get-db dbstruct run-id) "SELECT state||'|'||status AS s,count(id) FROM tests AS t ON ORDER BY s DESC;" ) ;; (set! res (reverse res)) (for-each (lambda (state) (set! res (cons (list "Totals" state (hash-table-ref totals state)) res))) (sort (hash-table-keys totals) string>=)))) runs-info) res)) ;; db:get-runs-by-patt ;; get runs by list of criteria ;; register a test run with the db ;; ;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) ;; to extract info from the structure returned ;; (define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit) ;; test-name) (let* ((tmp (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time"))) (keystr (car tmp)) (header (cadr tmp)) (res '()) (key-patt "") (runwildtype (if (substring-index "%" runnamepatt) "like" "glob")) (qry-str #f) |
︙ | ︙ | |||
780 781 782 783 784 785 786 | (if limit (conc " LIMIT " limit) "") (if offset (conc " OFFSET " offset) "") ";")) (debug:print-info 4 "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) (sqlite3:for-each-row (lambda (a . r) (set! res (cons (list->vector (cons a r)) res))) | | | | | | < | < | | > | < < < | | < < | | < | < | | | > > > > > > > > > | | < | < | | < < | < | | | | 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 | (if limit (conc " LIMIT " limit) "") (if offset (conc " OFFSET " offset) "") ";")) (debug:print-info 4 "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) (sqlite3:for-each-row (lambda (a . r) (set! res (cons (list->vector (cons a r)) res))) (db:get-db dbstruct #f) qry-str runnamepatt) (vector header res))) ;; use (get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) (define (db:get-run-info dbstruct run-id) ;;(if (hash-table-ref/default *run-info-cache* run-id #f) ;; (hash-table-ref *run-info-cache* run-id) (let* ((res #f) (keys (db:get-keys dbstruct)) (remfields (list "id" "runname" "state" "status" "owner" "event_time")) (header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ",")))) (debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) (sqlite3:for-each-row (lambda (a . x) (set! res (apply vector a x))) (db:get-db dbstruct #f) (conc "SELECT " keystr " FROM runs WHERE id=? AND state != 'deleted';") run-id) (debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) (let ((finalres (vector header res))) ;; (hash-table-set! *run-info-cache* run-id finalres) finalres))) (define (db:set-comment-for-run dbstruct run-id comment) (sqlite3:execute (db:get-db dbstruct #f) "UPDATE runs SET comment=? WHERE id=?;" comment run-id)) ;; does not (obviously!) removed dependent data. But why not!!? (define (db:delete-run dbstruct run-id) ;; (common:clear-caches) ;; don't trust caches after doing any deletion ;; First set any related tests to DELETED (let ((db (db:get-db dbstruct run-id))) (sqlite3:execute db "UPDATE tests SET state='DELETED',comment='';") (sqlite3:execute db "DELETE FROM test_steps;") (sqlite3:execute db "DELETE FROM test_data;") (sqlite3:execute (db:get-db dbstruct #f) "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id))) (define (db:update-run-event_time dbstruct run-id) (sqlite3:execute (db:get-db dbstruct #f) "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id)) (define (db:lock/unlock-run dbstruct run-id lock unlock user) (let ((newlockval (if lock "locked" (if unlock "unlocked" "locked")))) ;; semi-failsafe (sqlite3:execute (db:get-db dbstruct #f) "UPDATE runs SET state=? WHERE id=?;" newlockval run-id) (sqlite3:execute (db:get-db dbstruct #f) "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);" user (conc newlockval " " run-id)) (debug:print-info 1 "" newlockval " run number " run-id))) (define (db:get-all-run-ids dbstruct) (let ((res '())) (sqlite3:for-each-row (lambda (run-id) (set! res (cons run-id res))) (db:get-db dbstruct #f) "SELECT id FROM runs;") (reverse res))) ;;====================================================================== ;; K E Y S ;;====================================================================== ;; get key val pairs for a given run-id ;; ( (FIELDNAME1 keyval1) (FIELDNAME2 keyval2) ... ) (define (db:get-key-val-pairs dbstruct run-id) (let* ((keys (db:get-keys dbstruct)) (res '())) (for-each (lambda (key) (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) ;; (debug:print 0 "qry: " qry) (sqlite3:for-each-row (lambda (key-val) (set! res (cons (list key key-val) res))) (db:get-db dbstruct #f) qry run-id))) keys) (reverse res))) ;; get key vals for a given run-id (define (db:get-key-vals dbstruct run-id) (let ((mykeyvals (hash-table-ref/default *keyvals* run-id #f))) (if mykeyvals mykeyvals (let* ((keys (db:get-keys dbstruct)) (res '())) (for-each (lambda (key) (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) (sqlite3:for-each-row (lambda (key-val) (set! res (cons key-val res))) (db:get-db dbstruct #f) qry run-id))) keys) (let ((final-res (reverse res))) (hash-table-set! *keyvals* run-id final-res) final-res))))) ;; The target is keyval1/keyval2..., cached in *target* as it is used often (define (db:get-target dbstruct run-id) (let ((mytarg (hash-table-ref/default *target* run-id #f))) (if mytarg mytarg (let* ((keyvals (db:get-key-vals dbstruct run-id)) (thekey (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/"))) (hash-table-set! *target* run-id thekey) thekey)))) ;;====================================================================== ;; T E S T S ;;====================================================================== ;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN ;; i.e. these lists define what to NOT show. ;; states and statuses are required to be lists, empty is ok ;; not-in #t = above behaviour, #f = must match (define (db:get-tests-for-run dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order #!key (qryvals #f) ) (let* ((qryvals (if qryvals qryvals "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")) (res '()) ;; if states or statuses are null then assume match all when not-in is false (states-qry (if (null? states) |
︙ | ︙ | |||
937 938 939 940 941 942 943 | (states-qry (conc " AND " states-qry)) (statuses-qry (conc " AND " statuses-qry)) (else ""))) (tests-match-qry (tests:match->sqlqry testpatt)) (qry (conc "SELECT " qryvals | | | | | | | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < > | | < | < < < | | < | < < < < < < | < | | < | | | < > | | < > | > > | > | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | > | | | | | | | | | | > > | | > > | | | | | | | < < < < < < < < < < < | < < < < < | | | | < < | | < < < < > | | < < < < < < < < | < | | | < < < < < < < < < < < < | < | | < > | > | > | | > > > > | | > > > | > | | | < | | | | | < < < | < < < < < | < < < < | < | | | > < | | < < < < < < < < < | | < < < | < | | | > | | | 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 | (states-qry (conc " AND " states-qry)) (statuses-qry (conc " AND " statuses-qry)) (else ""))) (tests-match-qry (tests:match->sqlqry testpatt)) (qry (conc "SELECT " qryvals " FROM tests WHERE AND state != 'DELETED' " states-statuses-qry (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") (case sort-by ((rundir) " ORDER BY length(rundir) ") ((testname) (conc " ORDER BY testname " (if sort-order (conc sort-order ",") "") " item_path ")) ((statestatus) (conc " ORDER BY state " (if sort-order (conc sort-order ",") "") " status ")) ((event_time) " ORDER BY event_time ") (else (if (string? sort-by) (conc " ORDER BY " sort-by) ""))) (if sort-order sort-order "") (if limit (conc " LIMIT " limit) "") (if offset (conc " OFFSET " offset) "") ";" ))) (debug:print-info 8 "db:get-tests-for-run qry=" qry) (sqlite3:for-each-row (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) (db:get-db dbstruct run-id) qry) res)) ;; Convert calling routines to get list of run-ids and loop, do not use the get-tests-for-runs ;; ;; ;; ;; get a useful subset of the tests data (used in dashboard ;; ;; ;; use db:mintests-get-{id ,run_id,testname ...} ;; ;; (define (db:get-tests-for-runs-mindata dbstruct run-ids testpatt states status not-in) ;; ;; (db:get-tests-for-runs dbstruct run-ids testpatt states status not-in: not-in qryvals: "id,run_id,testname,state,status,event_time,item_path")) ;; ;; ;; ;; ;; NB // This is get tests for "runs" (note the plural!!) ;; ;; ;; ;; ;; ;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN ;; ;; ;; i.e. these lists define what to NOT show. ;; ;; ;; states and statuses are required to be lists, empty is ok ;; ;; ;; not-in #t = above behaviour, #f = must match ;; ;; ;; run-ids is a list of run-ids or a single number or #f for all runs ;; ;; (define (db:get-tests-for-runs dbstruct run-ids testpatt states statuses ;; ;; #!key (not-in #t) ;; ;; (sort-by #f) ;; ;; (qryvals "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")) ;; 'rundir 'event_time ;; ;; (let* ((res '()) ;; ;; ;; if states or statuses are null then assume match all when not-in is false ;; ;; (states-qry (if (null? states) ;; ;; #f ;; ;; (conc " state " ;; ;; (if not-in "NOT" "") ;; ;; " IN ('" ;; ;; (string-intersperse states "','") ;; ;; "')"))) ;; ;; (statuses-qry (if (null? statuses) ;; ;; #f ;; ;; (conc " status " ;; ;; (if not-in "NOT" "") ;; ;; " IN ('" ;; ;; (string-intersperse statuses "','") ;; ;; "')"))) ;; ;; (tests-match-qry (tests:match->sqlqry testpatt)) ;; ;; (qry (conc "SELECT " qryvals ;; ;; " FROM tests WHERE state != 'DELETED' " ;; ;; (if run-ids ;; ;; (if (list? run-ids) ;; ;; (conc "AND run_id IN (" (string-intersperse (map conc run-ids) ",") ") ") ;; ;; (conc "AND run_id=" run-ids " ")) ;; ;; " ") ;; #f => run-ids don't filter on run-ids ;; ;; (if states-qry (conc " AND " states-qry) "") ;; ;; (if statuses-qry (conc " AND " statuses-qry) "") ;; ;; (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") ;; ;; (case sort-by ;; ;; ((rundir) " ORDER BY length(rundir) DESC;") ;; ;; ((event_time) " ORDER BY event_time ASC;") ;; ;; (else ";")) ;; ;; ))) ;; ;; (debug:print-info 8 "db:get-tests-for-runs qry=" qry) ;; ;; (sqlite3:for-each-row ;; ;; (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) ;; ;; (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) ;; ;; db ;; ;; qry ;; ;; ) ;; ;; res)) ;; this one is a bit broken BUG FIXME (define (db:delete-test-step-records dbstruct run-id test-id) (let ((db (db:get-db dbstruct run-id))) (sqlite3:execute db "DELETE FROM test_steps WHERE test_id=?;" test-id) (sqlite3:execute db "DELETE FROM test_data WHERE test_id=?;" test-id))) ;; (define (db:delete-test-records dbstruct run-id test-id) (let ((db (db:get-db dbstruct run-id))) (sqlite3:execute db "DELETE FROM test_steps WHERE test_id=?;" test-id) (sqlite3:execute db "DELETE FROM test_data WHERE test_id=?;" test-id) ;; (sqlite3:execute db "DELETE FROM tests WHERE id=?;" test-id) (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id))) (define (db:delete-tests-for-run dbstruct run-id) (let ((db (db:get-db dbstruct run-id))) (sqlite3:execute db "DELETE FROM tests;"))) (define (db:delete-old-deleted-test-records dbstruct) (let ((run-ids (db:get-all-run-ids dbstruct)) (targtime (- (current-seconds)(* 30 24 60 60)))) ;; one month in the past (for-each (lambda (run-id) (sqlite3:execute (db:get-db dbstruct run-id) "DELETE FROM tests WHERE state='DELETED' AND event_time<?;" targtime)) run-ids))) ;; set tests with state currstate and status currstatus to newstate and newstatus ;; use currstate = #f and or currstatus = #f to apply to any state or status respectively ;; WARNING: SQL injection risk. NB// See new but not yet used "faster" version below ;; (define (db:set-tests-state-status dbstruct run-id testnames currstate currstatus newstate newstatus) (for-each (lambda (testname) (let ((qry (conc "UPDATE tests SET state=?,status=? WHERE " (if currstate (conc "state='" currstate "' AND ") "") (if currstatus (conc "status='" currstatus "' AND ") "") " testname=? AND NOT (item_path='' AND testname in (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));"))) ;;(debug:print 0 "QRY: " qry) (sqlite3:execute (db:get-db dbstruct run-id) qry run-id newstate newstatus testname testname))) testnames)) ;; (define (cdb:set-tests-state-status-faster serverdat run-id testnames currstate currstatus newstate newstatus) ;; ;; Convert #f to wildcard % ;; (if (null? testnames) ;; #t ;; (let ((currstate (if currstate currstate "%")) ;; (currstatus (if currstatus currstatus "%"))) ;; (let loop ((hed (car testnames)) ;; (tal (cdr testnames)) ;; (thr '())) ;; (let ((th1 (if newstate (create-thread (cbd:client-call serverdat 'update-test-state #t *default-numtries* newstate currstate run-id testname testname)) #f)) ;; (th2 (if newstatus (create-thread (cbd:client-call serverdat 'update-test-status #t *default-numtries* newstatus currstatus run-id testname testname)) #f))) ;; (thread-start! th1) ;; (thread-start! th2) ;; (if (null? tal) ;; (loop (car tal)(cdr tal)(cons th1 (cons th2 thr))) ;; (for-each ;; (lambda (th) ;; (if th (thread-join! th))) ;; thr))))))) (define (db:delete-tests-in-state dbstruct run-id state) (sqlite3:execute (db:get-db dbstruct run-id)(db:lookup-query 'delete-tests-in-state) state)) (define (db:tests-update-cpuload-diskfree dbstruct run-id test-id cpuload diskfree) (sqlite3:execute (db:get-db dbstruct run-id)(db:lookup-query 'update-cpuload-diskfree) cpuload diskfree test-id)) (define (db:tests-update-run-duration dbstruct run-id test-id minutes) (sqlite3:execute (db:get-db dbstruct run-id)(db:lookup-query 'update-run-duration) minutes test-id)) (define (db:tests-update-uname-host dbstruct run-id test-id uname hostname) (sqlite3:execute (db:get-db dbstruct run-id)(db:lookup-query 'update-uname-host) uname hostname test-id)) ;; speed up for common cases with a little logic ;; NB// Ultimately this will be deprecated in deference to mt:test-set-state-status-by-id ;; (define (db:test-set-state-status-by-id dbstruct run-id test-id newstate newstatus newcomment) (let ((db (db:get-db dbstruct run-id))) (cond ((and newstate newstatus newcomment) (sqlite3:execute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus newcomment test-id)) ((and newstate newstatus) (sqlite3:execute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id)) (else (if newstate (sqlite3:execute db "UPDATE tests SET state=? WHERE id=?;" newstate test-id)) (if newstatus (sqlite3:execute db "UPDATE tests SET status=? WHERE id=?;" newstatus test-id)) (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment test-id)))) (mt:process-triggers run-id test-id newstate newstatus))) ;; Never used ;; (define (db:test-set-state-status-by-run-id-testname db run-id test-name item-path status state) ;; (sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strftime('%s','now') WHERE run_id=? AND testname=? AND item_path=?;" ;; state status run-id test-name item-path)) ;; NEW BEHAVIOR: Count tests running in only one run! ;; (define (db:get-count-tests-running dbstruct run-id) (let ((res 0)) (sqlite3:for-each-row (lambda (count) (set! res count)) (db:get-db dbstruct run-id) "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART');") res)) ;; NEW BEHAVIOR: Look only at single run with run-id ;; (define (db:get-running-stats dbstruct run-id) (let ((res '())) (sqlite3:for-each-row (lambda (state count) (set! res (cons (list state count) res))) (db:get-db dbstruct run-id) "SELECT state,count(id) FROM tests GROUP BY state ORDER BY id DESC;") res)) (define (db:get-count-tests-running-in-jobgroup dbstruct run-id jobgroup) (if (not jobgroup) 0 ;; (let ((res 0)) (sqlite3:for-each-row (lambda (count) (set! res count)) (db:get-db dbstruct run-id) "SELECT count(id) FROM tests WHERE state = 'RUNNING' OR state = 'LAUNCHED' OR state = 'REMOTEHOSTSTART' AND testname in (SELECT testname FROM test_meta WHERE jobgroup=?);" jobgroup) res))) ;; done with run when: ;; 0 tests in LAUNCHED, NOT_STARTED, REMOTEHOSTSTART, RUNNING (define (db:estimated-tests-remaining dbstruct run-id) (let ((res 0)) (sqlite3:for-each-row (lambda (count) (set! res count)) (db:get-db dbstruct run-id) ;; NB// KILLREQ means the jobs is still probably running "SELECT count(id) FROM tests WHERE state in ('LAUNCHED','NOT_STARTED','REMOTEHOSTSTART','RUNNING','KILLREQ');") res)) ;; map run-id, testname item-path to test-id (define (db:get-test-id-not dbstruct run-id testname item-path) (let* ((res #f)) (sqlite3:for-each-row (lambda (id) ;; run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment ) (set! res id)) ;; (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment ))) (db:get-db dbstruct run-id) "SELECT id FROM tests WHERE testname=? AND item_path=?;" testname item-path) res)) (define db:test-record-qry-selector "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir_id,item_path,run_duration,final_logf,comment,realdir_id") ;; ;; NOTE: Use db:test-get* to access records ;; ;; NOTE: This needs rundir_id decoding? Decide, decode here or where used? For the moment decode where used. ;; ;; Get test data using test_id (define (db:get-test-info-by-id dbstruct run-id test-id) (let ((res #f)) (sqlite3:for-each-row (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final_logf comment realdir-id) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final_logf comment realdir-id))) (db:get-db dbstruct run-id) (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=?;") test-id) res)) ;; Use db:test-get* to access ;; ;; Get test data using test_ids. NB// Only works within a single run!! ;; (define (db:get-test-info-by-ids dbstruct run-id test-ids) (let ((res '())) (sqlite3:for-each-row (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final_logf comment realdir-id) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final_logf comment realdir-id) res))) (db:get-db dbstruct run-id) (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id in (" (string-intersperse (map conc test-ids) ",") ");")) res)) (define (db:get-test-info dbstruct run-id testname item-path) (let ((res #f)) (sqlite3:for-each-row (lambda (a . b) (set! res (apply vector a b))) (db:get-db dbstruct run-id) (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=?;") test-name item-path) res)) (define (db:test-set-comment dbstruct run-id test-id comment) (sqlite3:execute (db:get-db dbstruct run-id) "UPDATE tests SET comment=? WHERE id=?;" comment test-id)) (define (db:test-set-rundir! dbstruct run-id test-name item-path rundir-id) (sqlite3:execute (db:get-db dbstruct run-id)(db:lookup-query 'test-set-rundir) test-name item-path)) (define (db:test-set-rundir-by-test-id dbstruct run-id test-id rundir-id) (sqlite3:execute (db:get-db dbstruct run-id) 'test-set-rundir-by-test-id rundir-id test-id)) (define (db:test-get-rundir-from-test-id dbstruct run-id test-id) (let ((res #f)) (sqlite3:for-each-row (lambda (tpath) (set! res tpath)) (db:get-db dbstruct run-id) "SELECT rundir FROM tests WHERE id=?;" test-id) res)) (define (db:test-set-log! dbstruct run-id test-id logf-id) (if (string? logf)(sqlite3:execute (db:get-db dbstruct run-id) 'test-set-log logf-id test-id))) ;;====================================================================== ;; Misc. test related queries ;;====================================================================== ;; MUST BE CALLED local! ;; (define (db:test-get-paths-matching dbstruct keynames target fnamepatt #!key (res '())) ;; BUG: Move the values derived from args to parameters and push to megatest.scm (let* ((testpatt (if (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%")) (statepatt (if (args:get-arg ":state") (args:get-arg ":state") "%")) (statuspatt (if (args:get-arg ":status") (args:get-arg ":status") "%")) (runname (if (args:get-arg ":runname") (args:get-arg ":runname") "%")) (paths-from-db (db:test-get-paths-matching-keynames-target-new dbstruct keynames target res testpatt: testpatt statepatt: statepatt statuspatt: statuspatt runname: runname))) (if fnamepatt (apply append (map (lambda (p) |
︙ | ︙ | |||
1356 1357 1358 1359 1360 1361 1362 | (sqlite3:for-each-row (lambda (p) (set! res (cons p res))) db qrystr) res)) | | | | > | | | | | > > > | | | | | | | | | | | | | | | | | 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 | (sqlite3:for-each-row (lambda (p) (set! res (cons p res))) db qrystr) res)) (define (db:test-get-paths-matching-keynames-target-new dbstruct keynames target res #!key (testpatt "%") (statepatt "%") (statuspatt "%") (runname "%")) (let* ((row-ids '()) (keystr (string-intersperse (map (lambda (key val) (conc key " like '" val "'")) keynames (string-split target "/")) " AND ")) (testqry (tests:match->sqlqry testpatt)) (runsqry (sqlite3:prepare (db:get-db dbstruct #f)(conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';"))) (tstsqry (conc "SELECT rundir_id FROM tests WHERE " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;"))) (sqlite3:for-each-row (lambda (rid) (set! row-ids (cons rid row-ids))) runsqry) (for-each (lambda (rid) (sqlite3:for-each-row (lambda (p) (set! res (cons p res))) (db:get-db dbstruct rid) tstsqry)) row-ids) ;; (sqlite3:finalize! tstsqry) (sqlite3:finalize! runsqry) res)) ;; NEVER FINISHED? ;; look through tests from matching runs for a file ;; NEVER FINISHED? (define (db:test-get-first-path-matching dbstruct keynames target fname) ;; NEVER FINISHED? ;; [refpaths] is the section where references to other megatest databases are stored ;; NEVER FINISHED? ;; ;; NEVER FINISHED? ;; NEED TO REVISIT THIS!!! BUGGISHNESS ;; NEVER FINISHED? ;; ;; NEVER FINISHED? (let ((mt-paths (configf:get-section "refpaths")) ;; NEVER FINISHED? (res (db:test-get-paths-matching dbstruct keynames target fname))) ;; NEVER FINISHED? (let loop ((pathdat (if (null? paths) #f (car mt-paths))) ;; NEVER FINISHED? (tal (if (null? paths) '()(cdr mt-paths)))) ;; NEVER FINISHED? (if (not (null? res)) ;; NEVER FINISHED? (car res) ;; return first found ;; NEVER FINISHED? (if path ;; NEVER FINISHED? (let* ((db (open-db path: (cadr pathdat))) ;; NEVER FINISHED? (newres (db:test-get-paths-matching db keynames target fname))) ;; NEVER FINISHED? (debug:print-info 4 "Trying " (car pathdat) " at " (cadr pathdat)) ;; NEVER FINISHED? (sqlite3:finalize! db) ;; NEVER FINISHED? (if (not (null? newres)) ;; NEVER FINISHED? (car newres) ;; NEVER FINISHED? (if (null? tal) ;; NEVER FINISHED? #f ;; NEVER FINISHED? (loop (car tal)(cdr tal)))))))))) ;;====================================================================== ;; QUEUE UP META, TEST STATUS AND STEPS REMOTE ACCESS ;;====================================================================== ;; NOTE: Can remove the regex and base64 encoding for zmq (define (db:obj->string obj) |
︙ | ︙ | |||
1452 1453 1454 1455 1456 1457 1458 | ;; ;; cdb:client-call is the unified interface to all the transports. It dispatches the ;; query to a server routine (e.g. server:client-send-recieve) that ;; transports the data to the server where it is passed to db:process-queue-item ;; which either returns the data to the calling server routine or ;; directly calls the returning procedure (e.g. zmq). ;; | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < > | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > | < < < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | > > | | | | | | > | | | | | | < < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | < < | | | | | | < | < | | | | < | < < | | | | | | | < | | | < < < < < < < < < | | < < < < < < < < < < < < | | < | | < | | | | | | < | < | | | 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 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 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 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 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 | ;; ;; cdb:client-call is the unified interface to all the transports. It dispatches the ;; query to a server routine (e.g. server:client-send-recieve) that ;; transports the data to the server where it is passed to db:process-queue-item ;; which either returns the data to the calling server routine or ;; directly calls the returning procedure (e.g. zmq). ;; ;; (define (cdb:client-call serverdat qtype immediate numretries . params) ;; (debug:print-info 11 "cdb:client-call serverdat=" serverdat ", qtype=" qtype ", immediate=" immediate ", numretries=" numretries ", params=" params) ;; (case *transport-type* ;; ((fs) ;; (let ((packet (vector "na" qtype immediate "na" params 0))) ;; (fs:process-queue-item packet))) ;; ((http) ;; (let* ((client-sig (client:get-signature)) ;; (query-sig (message-digest-string (md5-primitive) (conc qtype immediate params))) ;; (zdat (db:obj->string (vector client-sig qtype immediate query-sig params (current-seconds))))) ;; (with-output-to-string (lambda ()(serialize params)))) ;; (debug:print-info 11 "zdat=" zdat) ;; (let* ((res #f) ;; (rawdat (http-transport:client-send-receive serverdat zdat)) ;; (tmp #f)) ;; (debug:print-info 11 "Sent " zdat ", received " rawdat) ;; (if rawdat ;; (begin ;; (set! tmp (db:string->obj rawdat)) ;; (vector-ref tmp 2)) ;; (begin ;; (debug:print 0 "ERROR: Communication with the server failed. Exiting if possible") ;; (exit 1)))))) ;; ((zmq) ;; (handle-exceptions ;; exn ;; (begin ;; (debug:print-info 0 "cdb:client-call timeout or error. Trying again in 5 seconds") ;; (thread-sleep! 5) ;; (if (> numretries 0)(apply cdb:client-call serverdat qtype immediate (- numretries 1) params))) ;; (let* ((push-socket (vector-ref serverdat 0)) ;; (sub-socket (vector-ref serverdat 1)) ;; (client-sig (client:get-signature)) ;; (query-sig (message-digest-string (md5-primitive) (conc qtype immediate params))) ;; (zdat (db:obj->string (vector client-sig qtype immediate query-sig params (current-seconds)))) ;; (with-output-to-string (lambda ()(serialize params)))) ;; (res #f) ;; (send-receive (lambda () ;; (debug:print-info 11 "sending message") ;; (send-message push-socket zdat) ;; (debug:print-info 11 "message sent") ;; (let loop () ;; ;; get the sender info ;; ;; this should match (client:get-signature) ;; ;; we will need to process "all" messages here some day ;; (receive-message* sub-socket) ;; ;; now get the actual message ;; (let ((myres (db:string->obj (receive-message* sub-socket)))) ;; (if (equal? query-sig (vector-ref myres 1)) ;; (set! res (vector-ref myres 2)) ;; (loop))))))) ;; ;; (timeout (lambda () ;; ;; (let loop ((n numretries)) ;; ;; (thread-sleep! 15) ;; ;; (if (not res) ;; ;; (if (> numretries 0) ;; ;; (begin ;; ;; (debug:print 2 "WARNING: no reply to query " params ", trying resend") ;; ;; (debug:print-info 11 "re-sending message") ;; ;; (send-message push-socket zdat) ;; ;; (debug:print-info 11 "message re-sent") ;; ;; (loop (- n 1))) ;; ;; ;; (apply cdb:client-call *runremote* qtype immediate (- numretries 1) params)) ;; ;; (begin ;; ;; (debug:print 0 "ERROR: cdb:client-call timed out " params ", exiting.") ;; ;; (exit 5)))))))) ;; (debug:print-info 11 "Starting threads") ;; (let ((th1 (make-thread send-receive "send receive")) ;; ;; (th2 (make-thread timeout "timeout")) ;; ) ;; (thread-start! th1) ;; ;; (thread-start! th2) ;; (thread-join! th1) ;; (debug:print-info 11 "cdb:client-call returning res=" res) ;; res)))))) ;; NOT NEEDED FOR NOW (define (cdb:set-verbosity serverdat val) ;; NOT NEEDED FOR NOW (cdb:client-call serverdat 'set-verbosity #f *default-numtries* val)) ;; NOT NEEDED FOR NOW ;; NOT NEEDED FOR NOW (define (cdb:login serverdat keyval signature) ;; NOT NEEDED FOR NOW (cdb:client-call serverdat 'login #t *default-numtries* keyval megatest-version signature)) ;; NOT NEEDED FOR NOW ;; NOT NEEDED FOR NOW (define (cdb:logout serverdat keyval signature) ;; NOT NEEDED FOR NOW (cdb:client-call serverdat 'logout #t *default-numtries* keyval signature)) ;; NOT NEEDED FOR NOW ;; NOT NEEDED FOR NOW (define (cdb:num-clients serverdat) ;; NOT NEEDED FOR NOW (cdb:client-call serverdat 'numclients #t *default-numtries*)) ;; NOT NEEDED FOR NOW ;; I think this would be more efficient if executed on client side FIXME??? (define (db:test-set-status-state dbstruct run-id test-id status state msg-id) (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) (sqlite3:execute (db:get-db dbstruct run-id) 'set-test-start-time test-id)) (if msg (sqlite3:execute (db:get-db dbstruct run-id) 'state-status-msg state status msg-id test-id) (sqlite3:execute (db:get-db dbstruct run-id) 'state-status state status test-id))) (define (db:test-rollup-test_data-pass-fail dbstruct run-id test-id) (sqlite3:execute (db:get-db dbstruct run-id) 'test_data-pf-rollup test-id test-id test-id test-id)) (define (db:pass-fail-counts dbstruct run-id test-id fail-count pass-count) (sqlite3:execute (db:get-db dbstruct run-id) 'pass-fail-counts fail-count pass-count test-id)) (define (db:tests-register-test dbstruct run-id test-name item-path) (sqlite3:execute (db:get-db dbstruct run-id) 'register-test run-id test-name item-path)) ;; more transactioned calls, these for roll-up-pass-fail stuff (define (db:update-pass-fail-counts dbstruct run-id test-name) (sqlite3:execute (db:get-db dbstruct run-id) 'update-fail-pass-counts test-name test-name test-name)) (define (db:top-test-set-running dbstruct run-id test-name) (sqlite3:execute (db:get-db dbstruct run-id) 'top-test-set-running test-name)) (define (db:top-test-set-per-pf-counts dbstruct run-id test-name) (sqlite3:execute (db:get-db dbstruct run-id) 'top-test-set-per-pf-counts test-name test-name test-name)) ;;= ;; NOT NEEDED FOR NOW (define (cdb:flush-queue serverdat) ;; NOT NEEDED FOR NOW (cdb:client-call serverdat 'flush #f *default-numtries*)) ;; NOT NEEDED FOR NOW ;; NOT NEEDED FOR NOW (define (cdb:kill-server serverdat pid) ;; NOT NEEDED FOR NOW (cdb:client-call serverdat 'killserver #t *default-numtries* pid)) ;; (define (cdb:roll-up-pass-fail-counts serverdat run-id test-name item-path status) ;; (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:roll-up-pass-fail-counts #f run-id test-name item-path status)) ;; ;; (define (db:get-test-info serverdat run-id test-name item-path) ;; (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:get-test-info #f run-id test-name item-path)) ;; ;; (define (cdb:get-test-info-by-id serverdat test-id) ;; (let ((test-dat (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:get-test-info-by-id #f test-id))) ;; (hash-table-set! *test-info* test-id (vector (current-seconds) test-dat)) ;; cached for use where up-to-date info is not needed ;; test-dat)) ;; ;; ;; db should be db open proc or #f ;; (define (cdb:remote-run proc db . params) ;; (apply cdb:client-call *runremote* 'immediate #f *default-numtries* open-run-close proc #f params)) ;; (define (db:test-get-logfile-info dbstruct run-id test-name) (let ((res #f)) (sqlite3:for-each-row (lambda (path-id final_logf-id) (let ((path (db:get-path dbstruct path-id)) (final_logf (db:get-string dbstruct final_logf-id))) (set! logf final_logf) (set! res (list path final_logf)) (if (directory? path) (debug:print 2 "Found path: " path) (debug:print 2 "No such path: " path)))) (db:get-db dbstruct run-id) "SELECT rundir_id,final_logf_id FROM tests WHERE testname=? AND item_path='';" test-name) res)) ;;====================================================================== ;; A G R E G A T E D T R A N S A C T I O N D B W R I T E S ;;====================================================================== (define db:queries (list '(register-test "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');") ;; DONE ;; Test state and status '(set-test-state "UPDATE tests SET state=? WHERE id=?;") '(set-test-status "UPDATE tests SET state=? WHERE id=?;") '(state-status "UPDATE tests SET state=?,status=? WHERE id=?;") ;; DONE '(state-status-msg "UPDATE tests SET state=?,status=?,comment_id=? WHERE id=?;") ;; DONE ;; Test comment '(set-test-comment "UPDATE tests SET comment_id=? WHERE id=?;") '(set-test-start-time "UPDATE tests SET event_time=strftime('%s','now') WHERE id=?;") ;; DONE '(pass-fail-counts "UPDATE tests SET fail_count=?,pass_count=? WHERE id=?;") ;; DONE ;; test_data-pf-rollup is used to set a tests PASS/FAIL based on the pass/fail info from the steps '(test_data-pf-rollup "UPDATE tests SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 THEN 'FAIL' WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL') THEN 'PASS' ELSE status END WHERE id=?;") ;; DONE '(test-set-log "UPDATE tests SET final_logf_id=? WHERE id=?;") ;; DONE '(test-set-rundir-by-test-id "UPDATE tests SET rundir_id=? WHERE id=?") ;; DONE '(test-set-rundir "UPDATE tests SET rundir_id=? AND testname=? AND item_path=?;") ;; DONE '(delete-tests-in-state "DELETE FROM tests WHERE state=?;") ;; DONE '(tests:test-set-toplog "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';") '(update-cpuload-diskfree "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;") ;; DONE '(update-run-duration "UPDATE tests SET run_duration=? WHERE id=?;") ;; DONE '(update-uname-host "UPDATE tests SET uname=?,host=? WHERE id=?;") ;; DONE '(update-test-state "UPDATE tests SET state=? WHERE state=? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));") '(update-test-status "UPDATE tests SET status=? WHERE status like ? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));") ;; stuff for roll-up-pass-fail-counts '(update-fail-pass-counts "UPDATE tests SET fail_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('FAIL','CHECK')), pass_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED')) WHERE testname=? AND item_path='';") ;; DONE '(top-test-set-running "UPDATE tests SET state='RUNNING' WHERE testname=? AND item_path='';") ;; DONE '(top-test-set-per-pf-counts "UPDATE tests SET state=CASE WHEN (SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND state in ('RUNNING','NOT_STARTED','LAUNCHED','REMOTEHOSTSTART')) > 0 THEN 'RUNNING' ELSE 'COMPLETED' END, status=CASE WHEN fail_count > 0 THEN 'FAIL' WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' WHEN (SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status = 'SKIP') > 0 THEN 'SKIP' ELSE 'UNKNOWN' END WHERE testname=? AND item_path='';") ;; DONE )) (define (db:lookup-query qry-name) (let ((q (alist-ref qry-name db:queries))) (if q (car q) #f))) ;; do not run these as part of the transaction (define db:special-queries '(rollup-tests-pass-fail ;; db:roll-up-pass-fail-counts ;; WHY NOT!? login immediate flush sync set-verbosity killserver )) ;; not used, intended to indicate to run in calling process (define db:run-local-queries '()) ;; rollup-tests-pass-fail)) ;; DISABLING FOR NOW (define (db:process-cached-writes db) ;; DISABLING FOR NOW (let ((queries (make-hash-table)) ;; DISABLING FOR NOW (data #f)) ;; DISABLING FOR NOW (mutex-lock! *incoming-mutex*) ;; DISABLING FOR NOW ;; data is a list of query packets <vector qry-sig query params ;; DISABLING FOR NOW (set! data (reverse *incoming-writes*)) ;; (sort ... (lambda (a b)(< (vector-ref a 1)(vector-ref b 1))))) ;; DISABLING FOR NOW (set! *server:last-write-flush* (current-milliseconds)) ;; DISABLING FOR NOW (set! *incoming-writes* '()) ;; DISABLING FOR NOW (mutex-unlock! *incoming-mutex*) ;; DISABLING FOR NOW (if (> (length data) 0) ;; DISABLING FOR NOW ;; Process if we have data ;; DISABLING FOR NOW (begin ;; DISABLING FOR NOW (debug:print-info 7 "Writing cached data " data) ;; DISABLING FOR NOW ;; DISABLING FOR NOW ;; Prepare the needed sql statements ;; DISABLING FOR NOW ;; ;; DISABLING FOR NOW (for-each (lambda (request-item) ;; DISABLING FOR NOW (let ((stmt-key (vector-ref request-item 0)) ;; DISABLING FOR NOW (query (vector-ref request-item 1))) ;; DISABLING FOR NOW (hash-table-set! queries stmt-key (sqlite3:prepare db query)))) ;; DISABLING FOR NOW data) ;; DISABLING FOR NOW ;; DISABLING FOR NOW ;; No outer loop needed. Single loop for write items only. Reads trigger flush of queue ;; DISABLING FOR NOW ;; and then are executed. ;; DISABLING FOR NOW (sqlite3:with-transaction ;; DISABLING FOR NOW db ;; DISABLING FOR NOW (lambda () ;; DISABLING FOR NOW (for-each ;; DISABLING FOR NOW (lambda (hed) ;; DISABLING FOR NOW (let* ((params (vector-ref hed 2)) ;; DISABLING FOR NOW (stmt-key (vector-ref hed 0)) ;; DISABLING FOR NOW (stmt (hash-table-ref/default queries stmt-key #f))) ;; DISABLING FOR NOW (if stmt ;; DISABLING FOR NOW (apply sqlite3:execute stmt params) ;; DISABLING FOR NOW (debug:print 0 "ERROR: Problem Executing " stmt-key " for " params)))) ;; DISABLING FOR NOW data))) ;; DISABLING FOR NOW ;; DISABLING FOR NOW ;; let all the waiting calls know all is done ;; DISABLING FOR NOW (mutex-lock! *completed-mutex*) ;; DISABLING FOR NOW (for-each (lambda (item) ;; DISABLING FOR NOW (let ((qry-sig (cdb:packet-get-client-sig item))) ;; DISABLING FOR NOW (debug:print-info 7 "Registering query " qry-sig " as done") ;; DISABLING FOR NOW (hash-table-set! *completed-writes* qry-sig #t))) ;; DISABLING FOR NOW data) ;; DISABLING FOR NOW (mutex-unlock! *completed-mutex*) ;; DISABLING FOR NOW ;; DISABLING FOR NOW ;; Finalize the statements. Should this be done inside the mutex above? ;; DISABLING FOR NOW ;; I think sqlite3 mutexes will keep the data safe ;; DISABLING FOR NOW (for-each (lambda (stmt-key) ;; DISABLING FOR NOW (sqlite3:finalize! (hash-table-ref queries stmt-key))) ;; DISABLING FOR NOW (hash-table-keys queries)) ;; DISABLING FOR NOW ;; DISABLING FOR NOW ;; Do a little record keeping ;; DISABLING FOR NOW (let ((cache-size (length data))) ;; DISABLING FOR NOW (if (> cache-size *max-cache-size*) ;; DISABLING FOR NOW (set! *max-cache-size* cache-size))) ;; DISABLING FOR NOW #t) ;; DISABLING FOR NOW #f))) ;; DISABLING FOR NOW ;; DISABLING FOR NOW (define *db:process-queue-mutex* (make-mutex)) ;; DISABLING FOR NOW ;; DISABLING FOR NOW (define *number-of-writes* 0) ;; DISABLING FOR NOW (define *writes-total-delay* 0) ;; DISABLING FOR NOW (define *total-non-write-delay* 0) ;; DISABLING FOR NOW (define *number-non-write-queries* 0) ;; DISABLING FOR NOW ;; DISABLING FOR NOW ;; The queue is a list of vectors where the zeroth slot indicates the type of query to ;; DISABLING FOR NOW ;; apply and the second slot is the time of the query and the third entry is a list of ;; DISABLING FOR NOW ;; values to be applied ;; DISABLING FOR NOW ;; ;; DISABLING FOR NOW (define (db:queue-write-and-wait db qry-sig query params) ;; DISABLING FOR NOW (let ((queue-len 0) ;; DISABLING FOR NOW (res #f) ;; DISABLING FOR NOW (got-it #f) ;; DISABLING FOR NOW (qry-pkt (vector qry-sig query params)) ;; DISABLING FOR NOW (start-time (current-milliseconds)) ;; DISABLING FOR NOW (timeout (+ 10 (current-seconds)))) ;; set the time out to 10 secs in future ;; DISABLING FOR NOW ;; DISABLING FOR NOW ;; Put the item in the queue *incoming-writes* ;; DISABLING FOR NOW (mutex-lock! *incoming-mutex*) ;; DISABLING FOR NOW (set! *incoming-writes* (cons qry-pkt *incoming-writes*)) ;; DISABLING FOR NOW (set! queue-len (length *incoming-writes*)) ;; DISABLING FOR NOW (mutex-unlock! *incoming-mutex*) ;; DISABLING FOR NOW ;; DISABLING FOR NOW (debug:print-info 7 "Current write queue length is " queue-len) ;; DISABLING FOR NOW ;; DISABLING FOR NOW ;; poll for the write to complete, timeout after 10 seconds ;; DISABLING FOR NOW ;; periodic flushing of the queue is taken care of by ;; DISABLING FOR NOW ;; db:flush-queue ;; DISABLING FOR NOW (let loop () ;; DISABLING FOR NOW (thread-sleep! 0.001) ;; DISABLING FOR NOW (mutex-lock! *completed-mutex*) ;; DISABLING FOR NOW (if (hash-table-ref/default *completed-writes* qry-sig #f) ;; DISABLING FOR NOW (begin ;; DISABLING FOR NOW (hash-table-delete! *completed-writes* qry-sig) ;; DISABLING FOR NOW (set! got-it #t))) ;; DISABLING FOR NOW (mutex-unlock! *completed-mutex*) ;; DISABLING FOR NOW (if (and (not got-it) ;; DISABLING FOR NOW (< (current-seconds) timeout)) ;; DISABLING FOR NOW (begin ;; DISABLING FOR NOW (thread-sleep! 0.01) ;; DISABLING FOR NOW (loop)))) ;; DISABLING FOR NOW (set! *number-of-writes* (+ *number-of-writes* 1)) ;; DISABLING FOR NOW (set! *writes-total-delay* (+ *writes-total-delay* (- (current-milliseconds) start-time))) ;; DISABLING FOR NOW got-it)) ;; DISABLING FOR NOW ;; DISABLING FOR NOW (define (db:process-queue-item db item) ;; DISABLING FOR NOW (let* ((stmt-key (cdb:packet-get-qtype item)) ;; DISABLING FOR NOW (qry-sig (cdb:packet-get-query-sig item)) ;; DISABLING FOR NOW (return-address (cdb:packet-get-client-sig item)) ;; DISABLING FOR NOW (params (cdb:packet-get-params item)) ;; DISABLING FOR NOW (query (let ((q (alist-ref stmt-key db:queries))) ;; DISABLING FOR NOW (if q (car q) #f)))) ;; DISABLING FOR NOW (debug:print-info 11 "Special queries/requests stmt-key=" stmt-key ", return-address=" return-address ", query=" query ", params=" params) ;; DISABLING FOR NOW (if query ;; DISABLING FOR NOW ;; hand queries off to the write queue ;; DISABLING FOR NOW (let ((response (case *transport-type* ;; DISABLING FOR NOW ((http) ;; DISABLING FOR NOW (debug:print-info 7 "Queuing item " item " for wrapped write") ;; DISABLING FOR NOW (db:queue-write-and-wait db qry-sig query params)) ;; DISABLING FOR NOW (else ;; DISABLING FOR NOW (apply sqlite3:execute db query params) ;; DISABLING FOR NOW #t)))) ;; DISABLING FOR NOW (debug:print-info 7 "Received " response " from wrapped write") ;; DISABLING FOR NOW (server:reply return-address qry-sig response response)) ;; DISABLING FOR NOW ;; otherwise if appropriate flush the queue (this is a read or complex query) ;; DISABLING FOR NOW (begin ;; DISABLING FOR NOW (cond ;; DISABLING FOR NOW ((member stmt-key db:special-queries) ;; DISABLING FOR NOW (let ((starttime (current-milliseconds))) ;; DISABLING FOR NOW (debug:print-info 9 "Handling special statement " stmt-key) ;; DISABLING FOR NOW (case stmt-key ;; DISABLING FOR NOW ((immediate) ;; DISABLING FOR NOW ;; This is a read or mixed read-write query, must clear the cache ;; DISABLING FOR NOW (case *transport-type* ;; DISABLING FOR NOW ((http) ;; DISABLING FOR NOW (mutex-lock! *db:process-queue-mutex*) ;; DISABLING FOR NOW (db:process-cached-writes db) ;; DISABLING FOR NOW (mutex-unlock! *db:process-queue-mutex*))) ;; DISABLING FOR NOW (let* ((proc (car params)) ;; DISABLING FOR NOW (remparams (cdr params)) ;; DISABLING FOR NOW ;; we are being handed a procedure so call it ;; DISABLING FOR NOW ;; (debug:print-info 11 "Running (apply " proc " " remparams ")") ;; DISABLING FOR NOW (result (server:reply return-address qry-sig #t (apply proc remparams)))) ;; DISABLING FOR NOW (set! *total-non-write-delay* (+ *total-non-write-delay* (- (current-milliseconds) starttime))) ;; DISABLING FOR NOW (set! *number-non-write-queries* (+ *number-non-write-queries* 1)) ;; DISABLING FOR NOW result)) ;; DISABLING FOR NOW ((login) ;; DISABLING FOR NOW (if (< (length params) 3) ;; should get toppath, version and signature ;; DISABLING FOR NOW (server:reply return-address qry-sig '(#f "login failed due to missing params")) ;; missing params ;; DISABLING FOR NOW (let ((calling-path (car params)) ;; DISABLING FOR NOW (calling-vers (cadr params)) ;; DISABLING FOR NOW (client-key (caddr params))) ;; DISABLING FOR NOW (if (and (equal? calling-path *toppath*) ;; DISABLING FOR NOW (equal? megatest-version calling-vers)) ;; DISABLING FOR NOW (begin ;; DISABLING FOR NOW (hash-table-set! *logged-in-clients* client-key (current-seconds)) ;; DISABLING FOR NOW (server:reply return-address qry-sig #t '(#t "successful login"))) ;; path matches - pass! Should vet the caller at this time ... ;; DISABLING FOR NOW (server:reply return-address qry-sig #f (list #f (conc "Login failed due to mismatch paths: " calling-path ", " *toppath*))))))) ;; DISABLING FOR NOW ((flush sync) ;; DISABLING FOR NOW (server:reply return-address qry-sig #t 1)) ;; (length data))) ;; DISABLING FOR NOW ((set-verbosity) ;; DISABLING FOR NOW (set! *verbosity* (car params)) ;; DISABLING FOR NOW (server:reply return-address qry-sig #t (list #t *verbosity*))) ;; DISABLING FOR NOW ((killserver) ;; DISABLING FOR NOW (let ((hostname (car *runremote*)) ;; DISABLING FOR NOW (port (cadr *runremote*)) ;; DISABLING FOR NOW (pid (car params))) ;; DISABLING FOR NOW (debug:print 0 "WARNING: Server on " hostname ":" port " going down by user request!") ;; DISABLING FOR NOW (debug:print-info 1 "current pid=" (current-process-id)) ;; DISABLING FOR NOW (open-run-close tasks:server-deregister tasks:open-db ;; DISABLING FOR NOW hostname ;; DISABLING FOR NOW port: port) ;; DISABLING FOR NOW (set! *server-run* #f) ;; DISABLING FOR NOW (thread-sleep! 3) ;; DISABLING FOR NOW (process-signal pid signal/kill) ;; DISABLING FOR NOW (server:reply return-address qry-sig #t '(#t "exit process started")))) ;; DISABLING FOR NOW (else ;; not a command, i.e. is a query ;; DISABLING FOR NOW (debug:print 0 "ERROR: Unrecognised query/command " stmt-key) ;; DISABLING FOR NOW (server:reply return-address qry-sig #f 'failed))))) ;; DISABLING FOR NOW (else ;; DISABLING FOR NOW (debug:print-info 11 "Executing " stmt-key " for " params) ;; DISABLING FOR NOW (apply sqlite3:execute (hash-table-ref queries stmt-key) params) ;; DISABLING FOR NOW (server:reply return-address qry-sig #t #t))))))) ;; DISABLING FOR NOW (define (db:test-get-records-for-index-file dbstruct run-id test-name) (let ((res '())) (sqlite3:for-each-row (lambda (id itempath state status run_duration logf-id comment-id) (let ((logf (db:get-string dbstruct logf-id)) (comment (db:get-string dbstruct comment-id))) (set! res (cons (vector id itempath state status run_duration logf comment) res))) (db:get-db dbstruct run-id) "SELECT id,item_path,state,status,run_duration,final_logf_id,comment_id FROM tests WHERE testname=? AND item_path != '';" test-name) res))) ;;====================================================================== ;; Tests meta data ;;====================================================================== ;; read the record given a testname (define (db:testmeta-get-record dbstruct testname) (let ((res #f)) (sqlite3:for-each-row (lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags) (set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags))) (db:get-db dbstruct #f) "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags FROM test_meta WHERE testname=?;" testname) res)) ;; create a new record for a given testname (define (db:testmeta-add-record dbstruct testname) (sqlite3:execute (db:get-db dbstruct #f) "INSERT OR IGNORE INTO test_meta (testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags) VALUES (?,'','','','','','','','');" testname)) ;; update one of the testmeta fields (define (db:testmeta-update-field dbstruct testname field value) (sqlite3:execute (db:get-db dbstruct #f) (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname)) ;;====================================================================== ;; T E S T D A T A ;;====================================================================== (define (db:csv->test-data dbstruct run-id test-id csvdata) (let ((csvlist (csv->list (make-csv-reader (open-input-string csvdata) '((strip-leading-whitespace? #t) (strip-trailing-whitespace? #t)) )))) ;; (csv->list csvdata))) (for-each (lambda (csvrow) (let* ((padded-row (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9)) (category (list-ref padded-row 0)) (variable (list-ref padded-row 1)) (value (any->number-if-possible (list-ref padded-row 2))) (expected (any->number-if-possible (list-ref padded-row 3))) (tol (any->number-if-possible (list-ref padded-row 4))) ;; >, <, >=, <=, or a number (units (list-ref padded-row 5)) (comment (list-ref padded-row 6)) (status (let ((s (list-ref padded-row 7))) (if (and (string? s)(or (string-match (regexp "^\\s*$") s) (string-match (regexp "^n/a$") s))) #f s))) ;; if specified on the input then use, else calculate (type (list-ref padded-row 8))) ;; look up expected,tol,units from previous best fit test if they are all either #f or '' (debug:print 4 "BEFORE: category: " category " variable: " variable " value: " value ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment " type: " type) (if (and (or (not expected)(equal? expected "")) (or (not tol) (equal? expected "")) (or (not units) (equal? expected ""))) (let-values (((new-expected new-tol new-units)(db:get-prev-tol-for-test dbstruct run-id test-id category variable))) (set! expected new-expected) (set! tol new-tol) (set! units new-units))) (debug:print 4 "AFTER: category: " category " variable: " variable " value: " value ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) ;; calculate status if NOT specified (if (and (not status)(number? expected)(number? value)) ;; need expected and value to be numbers (if (number? tol) ;; if tol is a number then we do the standard comparison (let* ((max-val (+ expected tol)) (min-val (- expected tol)) (result (and (>= value min-val)(<= value max-val)))) (debug:print 4 "max-val: " max-val " min-val: " min-val " result: " result) (set! status (if result "pass" "fail"))) (set! status ;; NB// need to assess each one (i.e. not return operator since need to act if not valid op. (case (string->symbol tol) ;; tol should be >, <, >=, <= ((>) (if (> value expected) "pass" "fail")) ((<) (if (< value expected) "pass" "fail")) ((>=) (if (>= value expected) "pass" "fail")) ((<=) (if (<= value expected) "pass" "fail")) (else (conc "ERROR: bad tol comparator " tol)))))) (debug:print 4 "AFTER2: category: " category " variable: " variable " value: " value ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) (sqlite3:execute (db:get-db dbstruct run-id) "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);" test-id category variable value expected tol units (if comment comment "") status type))) csvlist))) ;; get a list of test_data records matching categorypatt (define (db:read-test-data dbstruct run-id test-id categorypatt) (let ((res '())) (sqlite3:for-each-row (lambda (id test_id category variable value expected tol units comment status type) (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) (db:get-db dbstruct run-id) "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt) (reverse res))) ;; NOTE: Run this local with #f for db !!! (define (db:load-test-data dbstruct run-id test-id) (let loop ((lin (read-line))) (if (not (eof-object? lin)) (begin (debug:print 4 lin) (db:csv->test-data dbstruct run-id test-id lin) (loop (read-line))))) ;; roll up the current results. ;; FIXME: Add the status to (db:test-data-rollup dbstruct run-id test-id #f)) ;; WARNING: Do NOT call this for the parent test on an iterated test ;; Roll up test_data pass/fail results ;; look at the test_data status field, ;; if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS. ;; if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored (define (db:test-data-rollup dbstruct run-id test-id status) (let ((fail-count 0) (pass-count 0)) (sqlite3:for-each-row (lambda (fcount pcount) (set! fail-count fcount) (set! pass-count pcount)) (db:get-db dbstruct run-id) "SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count, (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'pass') AS pass_count;" test-id test-id) ;; Now rollup the counts to the central megatest.db (cdb:pass-fail-counts *runremote* test-id fail-count pass-count) ;; if the test is not FAIL then set status based on the fail and pass counts. (cdb:test-rollup-test_data-pass-fail *runremote* test-id))) (define (db:get-prev-tol-for-test dbstruct run-id test-id category variable) ;; Finish me? (values #f #f #f)) ;;====================================================================== ;; S T E P S ;;====================================================================== (define (db:step-get-time-as-string vec) (seconds->time-string (db:step-get-event_time vec))) ;; db-get-test-steps-for-run (define (db:get-steps-for-test dbstruct run-id test-id) (let ((res '())) (sqlite3:for-each-row (lambda (id test-id stepname state status event-time logfile) (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res))) (db:get-db dbstruct run-id) "SELECT id,test_id,stepname,state,status,event_time,logfile_id FROM test_steps WHERE test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; test-id) (reverse res))) ;; get a pretty table to summarize steps ;; (define (db:get-steps-table dbstruct run-id test-id) (let ((steps (db:get-steps-for-test dbstruct run-id test-id))) ;; organise the steps for better readability (let ((res (make-hash-table))) (for-each (lambda (step) (debug:print 6 "step=" step) (let ((record (hash-table-ref/default res |
︙ | ︙ | |||
2115 2116 2117 2118 2119 2120 2121 | (cond ((< (db:step-get-event_time a)(db:step-get-event_time b)) #t) ((eq? (db:step-get-event_time a)(db:step-get-event_time b)) (< (db:step-get-id a) (db:step-get-id b))) (else #f))))) res))) | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | < | | | 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 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 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 2022 2023 2024 2025 2026 2027 2028 | (cond ((< (db:step-get-event_time a)(db:step-get-event_time b)) #t) ((eq? (db:step-get-event_time a)(db:step-get-event_time b)) (< (db:step-get-id a) (db:step-get-id b))) (else #f))))) res))) ;; ;; get a pretty table to summarize steps ;; ;; ;; (define (db:get-steps-table-list dbstruct run-id test-id #!key (work-area #f)) ;; (let ((steps (db:get-steps-for-test dbstruct run-id test-id))) ;; ;; organise the steps for better readability ;; (let ((res (make-hash-table))) ;; (for-each ;; (lambda (step) ;; (debug:print 6 "step=" step) ;; (let ((record (hash-table-ref/default ;; res ;; (db:step-get-stepname step) ;; ;; stepname start end status ;; (vector (db:step-get-stepname step) "" "" "" "" "")))) ;; (debug:print 6 "record(before) = " record ;; "\nid: " (db:step-get-id step) ;; "\nstepname: " (db:step-get-stepname step) ;; "\nstate: " (db:step-get-state step) ;; "\nstatus: " (db:step-get-status step) ;; "\ntime: " (db:step-get-event_time step)) ;; (case (string->symbol (db:step-get-state step)) ;; ((start)(vector-set! record 1 (db:step-get-event_time step)) ;; (vector-set! record 3 (if (equal? (vector-ref record 3) "") ;; (db:step-get-status step))) ;; (if (> (string-length (db:step-get-logfile step)) ;; 0) ;; (vector-set! record 5 (db:step-get-logfile step)))) ;; ((end) ;; (vector-set! record 2 (any->number (db:step-get-event_time step))) ;; (vector-set! record 3 (db:step-get-status step)) ;; (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) ;; (endt (any->number (vector-ref record 2)))) ;; (debug:print 4 "record[1]=" (vector-ref record 1) ;; ", startt=" startt ", endt=" endt ;; ", get-status: " (db:step-get-status step)) ;; (if (and (number? startt)(number? endt)) ;; (seconds->hr-min-sec (- endt startt)) "-1"))) ;; (if (> (string-length (db:step-get-logfile step)) ;; 0) ;; (vector-set! record 5 (db:step-get-logfile step)))) ;; (else ;; (vector-set! record 2 (db:step-get-state step)) ;; (vector-set! record 3 (db:step-get-status step)) ;; (vector-set! record 4 (db:step-get-event_time step)))) ;; (hash-table-set! res (db:step-get-stepname step) record) ;; (debug:print 6 "record(after) = " record ;; "\nid: " (db:step-get-id step) ;; "\nstepname: " (db:step-get-stepname step) ;; "\nstate: " (db:step-get-state step) ;; "\nstatus: " (db:step-get-status step) ;; "\ntime: " (db:step-get-event_time step)))) ;; ;; (else (vector-set! record 1 (db:step-get-event_time step))) ;; (sort steps (lambda (a b) ;; (cond ;; ((< (db:step-get-event_time a)(db:step-get-event_time b)) #t) ;; ((eq? (db:step-get-event_time a)(db:step-get-event_time b)) ;; (< (db:step-get-id a) (db:step-get-id b))) ;; (else #f))))) ;; res))) (define (db:get-compressed-steps dbstruct run-id test-id) (let ((comprsteps (open-run-close db:get-steps-table (db:get-db dbstruct run-id) test-id))) (map (lambda (x) ;; take advantage of the \n on time->string (vector (vector-ref x 0) (let ((s (vector-ref x 1))) (if (number? s)(seconds->time-string s) s)) (let ((s (vector-ref x 2))) (if (number? s)(seconds->time-string s) s)) (vector-ref x 3) ;; status (vector-ref x 4) (vector-ref x 5))) ;; time delta (sort (hash-table-values comprsteps) (lambda (a b) (let ((time-a (vector-ref a 1)) (time-b (vector-ref b 1))) (if (and (number? time-a)(number? time-b)) (if (< time-a time-b) #t (if (eq? time-a time-b) (string<? (conc (vector-ref a 2)) (conc (vector-ref b 2))) #f)) (string<? (conc time-a)(conc time-b))))))))) ;;====================================================================== ;; M I S C M A N A G E M E N T I T E M S ;;====================================================================== ;; the new prereqs calculation, looks also at itempath if specified ;; all prereqs must be met: ;; if prereq test with itempath='' is COMPLETED and PASS, WARN, CHECK, or WAIVED then prereq is met ;; if prereq test with itempath=ref-item-path and COMPLETED with PASS, WARN, CHECK, or WAIVED then prereq is met ;; ;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK, SKIP or WAIVED) ;; mode 'toplevel means that tests must be COMPLETED only ;; mode 'itemmatch or 'itemwait means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]] ;; (define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path #!key (mode 'normal)) (if (or (not waitons) (null? waitons)) '() (let* ((unmet-pre-reqs '()) (result '())) (for-each (lambda (waitontest-name) ;; by getting the tests with matching name we are looking only at the matching test ;; and related sub items (let ((tests (mt:get-tests-for-run dbstruct run-id waitontest-name '() '())) (ever-seen #f) (parent-waiton-met #f) (item-waiton-met #f)) (for-each (lambda (test) ;; (if (equal? waitontest-name (db:test-get-testname test)) ;; by defintion this had better be true ... (let* ((state (db:test-get-state test)) |
︙ | ︙ | |||
2281 2282 2283 2284 2285 2286 2287 | ;; if the test is not found then clearly the waiton is not met... ;; (if (not ever-seen)(set! result (cons waitontest-name result))))) (if (not ever-seen) (set! result (append (if (null? tests)(list waitontest-name) tests) result))))) waitons) (delete-duplicates result)))) | | < < < | | < < | | | | < > > | < > > | | 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 | ;; if the test is not found then clearly the waiton is not met... ;; (if (not ever-seen)(set! result (cons waitontest-name result))))) (if (not ever-seen) (set! result (append (if (null? tests)(list waitontest-name) tests) result))))) waitons) (delete-duplicates result)))) (define (db:teststep-set-status! dbstruct run-id test-id teststep-name state-in status-in comment logfile #!key (work-area #f)) (let ((state (items:check-valid-items "state" state-in)) (status (items:check-valid-items "status" status-in))) (if (or (not state)(not status)) (debug:print 3 "WARNING: Invalid " (if status "status" "state") " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) (sqlite3:execute (db:get-db dbstruct run-id) "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment_id,logfile_id) VALUES(?,?,?,?,?,?,?);" test-id teststep-name state-in status-in (current-seconds) (db:save-string (if comment comment "")) (db:save-string (if logfile logfile ""))) #t)) ;;====================================================================== ;; Extract ods file from the db ;;====================================================================== ;; NOT REWRITTEN YET!!!!! ;; runspatt is a comma delimited list of run patterns ;; keypatt-alist must contain *all* keys with an associated pattern: '( ("KEY1" "%") .. ) (define (db:extract-ods-file dbstruct outputfile keypatt-alist runspatt pathmod) (let* ((keysstr (string-intersperse (map car keypatt-alist) ",")) (keyqry (string-intersperse (map (lambda (p)(conc (car p) " LIKE ? ")) keypatt-alist) " AND ")) (numkeys (length keypatt-alist)) (test-ids '()) (windows (and pathmod (substring-index "\\" pathmod))) (tempdir (conc "/tmp/" (current-user-name) "/" runspatt "_" (random 10000) "_" (current-process-id))) (runsheader (append (list "Run Id" "Runname") ; 0 1 |
︙ | ︙ |
Added fdb_records.scm version [bbb0371221].
> > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | ;; Single record for managing a filedb ;; make-vector-record "Filedb record" filedb fdb db dbpath pathcache idcache partcache ;; Filedb record (define (make-filedb:fdb)(make-vector 5)) (define-inline (filedb:fdb-get-db vec) (vector-ref vec 0)) (define-inline (filedb:fdb-get-dbpath vec) (vector-ref vec 1)) (define-inline (filedb:fdb-get-pathcache vec) (vector-ref vec 2)) (define-inline (filedb:fdb-get-idcache vec) (vector-ref vec 3)) (define-inline (filedb:fdb-get-partcache vec) (vector-ref vec 4)) (define-inline (filedb:fdb-set-db! vec val)(vector-set! vec 0 val)) (define-inline (filedb:fdb-set-dbpath! vec val)(vector-set! vec 1 val)) (define-inline (filedb:fdb-set-pathcache! vec val)(vector-set! vec 2 val)) (define-inline (filedb:fdb-set-idcache! vec val)(vector-set! vec 3 val)) (define-inline (filedb:fdb-set-partcache! vec val)(vector-set! vec 4 val)) ;; children records, should have use something other than "child" (define-inline (filedb:child-get-id vec) (vector-ref vec 0)) (define-inline (filedb:child-get-path vec) (vector-ref vec 1)) (define-inline (filedb:child-get-parent_id vec)(vector-ref vec 2)) |
Added filedb.scm version [7bcdac6111].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 | ;; Copyright 2006-2011, 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. ;; (require-extension synch sqlite3 posix srfi-13 srfi-1 utils regex) (use sqlite3 srfi-1 posix regex srfi-69 srfi-13 posix-extras) (import (prefix sqlite3 sqlite3:)) (declare (unit filedb)) (include "fdb_records.scm") ;; (include "settings.scm") (define (filedb:open-db dbpath) (let* ((fdb (make-filedb:fdb)) (dbexists (file-exists? dbpath)) (db (sqlite3:open-database dbpath))) (filedb:fdb-set-db! fdb db) (filedb:fdb-set-dbpath! fdb dbpath) (filedb:fdb-set-pathcache! fdb (make-hash-table)) (filedb:fdb-set-idcache! fdb (make-hash-table)) (filedb:fdb-set-partcache! fdb (make-hash-table)) ;(sqlite3:set-busy-timeout! db 1000000) (if (not dbexists) (begin (sqlite3:execute db "PRAGMA synchronous = OFF;") (sqlite3:execute db "CREATE TABLE names (id INTEGER PRIMARY KEY,name TEST);") ;; for future use - change path in paths table to path_id (sqlite3:execute db "CREATE INDEX name_index ON names (name);") ;; NB// We store a useful subset of file attributes but do not attempt to store all (sqlite3:execute db "CREATE TABLE paths (id INTEGER PRIMARY KEY, path TEXT, parent_id INTEGER, mode INTEGER DEFAULT -1, uid INTEGER DEFAULT -1, gid INTEGER DEFAULT -1, size INTEGER DEFAULT -1, mtime INTEGER DEFAULT -1);") (sqlite3:execute db "CREATE INDEX path_index ON paths (path,parent_id);") (sqlite3:execute db "CREATE TABLE bases (id INTEGER PRIMARY KEY,base TEXT, updated TIMESTAMP);"))) fdb)) (define (filedb:get-current-time-string) (string-chomp (time->string (seconds->local-time (current-seconds))))) (define (filedb:get-base-id db path) (let ((stmt (sqlite3:prepare db "SELECT id FROM bases WHERE base=?;")) (id-num #f)) (sqlite3:for-each-row (lambda (num) (set! id-num num)) stmt path) (sqlite3:finalize! stmt) id-num)) (define (filedb:get-path-id db path parent) (let ((stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path=? AND parent_id=?;")) (id-num #f)) (sqlite3:for-each-row (lambda (num) (set! id-num num)) stmt path parent) (sqlite3:finalize! stmt) id-num)) (define (filedb:add-base db path) (let ((existing (filedb:get-base-id db path))) (if existing #f (begin (sqlite3:execute db "INSERT INTO bases (base,updated) VALUES (?,?);" path (filedb:get-current-time-string)))))) ;; index value field notes ;; 0 inode number st_ino ;; 1 mode st_mode bitfield combining file permissions and file type ;; 2 number of hard links st_nlink ;; 3 UID of owner st_uid as with file-owner ;; 4 GID of owner st_gid ;; 5 size st_size as with file-size ;; 6 access time st_atime as with file-access-time ;; 7 change time st_ctime as with file-change-time ;; 8 modification time st_mtime as with file-modification-time ;; 9 parent device ID st_dev ID of device on which this file resides ;; 10 device ID st_rdev device ID for special files (i.e. the raw major/minor number) ;; 11 block size st_blksize ;; 12 number of blocks allocated st_blocks (define (filedb:add-path-stat db path parent statinfo) (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id,mode,uid,gid,size,mtime) VALUES (?,?,?,?,?,?,?);"))) (sqlite3:execute stmt path parent (vector-ref statinfo 1) ;; mode (vector-ref statinfo 3) ;; uid (vector-ref statinfo 4) ;; gid (vector-ref statinfo 5) ;; size (vector-ref statinfo 8) ;; mtime ))) ;; (filedb:get-current-time-string)))) (define (filedb:add-path db path parent) (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id) VALUES (?,?);"))) (sqlite3:execute stmt path parent))) (define (filedb:register-path fdb path #!key (save-stat #f)) (let* ((db (filedb:fdb-get-db fdb)) (pathcache (filedb:fdb-get-pathcache fdb)) (stat (if save-stat (file-stat path #t))) (id (hash-table-ref/default pathcache path #f))) (if id id (let ((plist (string-split path "/"))) (let loop ((head (car plist)) (tail (cdr plist)) (parent 0)) (let ((id (filedb:get-path-id db head parent)) (done (null? tail))) (if id ;; we'll have a id if the path is already registered (if done (begin (hash-table-set! pathcache path id) id) ;; return the last path id for a result (loop (car tail)(cdr tail) id)) (begin ;; add the path and then repeat the loop with the same data (if save-stat (filedb:add-path-stat db head parent stat) (filedb:add-path db head parent)) (loop head tail parent))))))))) (define (filedb:update-recursively fdb path #!key (save-stat #f)) (let ((p (open-input-pipe (string-append "find -L " path)))) ;; (resolve-pathname path)))) ;; (string-append "find " path)))) (print "processed 0 files...") (let loop ((l (read-line p)) (lc 0)) ;; line count (if (eof-object? l) (begin (print " " lc " files") (close-input-port p)) (begin (filedb:register-path fdb l save-stat: save-stat) ;; (get-real-path l)) ;; don't like losing the original path info (if (= (modulo lc 100) 0) (print " " lc " files")) (loop (read-line p)(+ lc 1))))))) (define (filedb:update fdb path #!key (save-stat #f)) ;; first get the realpath and add it to the bases table (let ((real-path path) ;; (filedb:get-real-path path)) (db (filedb:fdb-get-db fdb))) (filedb:add-base db real-path) (filedb:update-recursively fdb path save-stat: save-stat))) ;; not used and broken ;; (define (filedb:get-real-path path) (let* ((p (open-input-pipe (string-append real-path " " (regexp-escape path)))) (pth (read-line p))) (if (eof-object? pth) path (begin (close-input-port p) pth)))) (define (filedb:drop-base fdb path) (print "Sorry, I don't do anything yet")) (define (filedb:find-all fdb pattern action) (let* ((db (filedb:fdb-get-db fdb)) (stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path like ?;")) (result '())) (sqlite3:for-each-row (lambda (num) (action num) (set! result (cons num result))) stmt pattern) (sqlite3:finalize! stmt) result)) (define (filedb:get-path-record fdb id) (let* ((db (filedb:fdb-get-db fdb)) (partcache (filedb:fdb-get-partcache fdb)) (dat (hash-table-ref/default partcache id #f))) (if dat dat (let ((stmt (sqlite3:prepare db "SELECT path,parent_id FROM paths WHERE id=?;")) (result #f)) (sqlite3:for-each-row (lambda (path parent_id)(set! result (list path parent_id))) stmt id) (hash-table-set! partcache id result) result)))) (define (filedb:get-children fdb parent-id) (let* ((db (filedb:fdb-get-db fdb)) (res '())) (sqlite3:for-each-row (lambda (id path parent-id) (set! res (cons (vector id path parent-id) res))) db "SELECT id,path,parent_id FROM paths WHERE parent_id=?;" parent-id) res)) ;; retrieve all that have children and those without ;; children that match patt (define (filedb:get-children-patt fdb parent-id search-patt) (let* ((db (filedb:fdb-get-db fdb)) (res '())) ;; first get the children that have no children (sqlite3:for-each-row (lambda (id path parent-id) (set! res (cons (vector id path parent-id) res))) db "SELECT id,path,parent_id FROM paths WHERE parent_id=? AND (id IN (SELECT parent_id FROM paths) OR path LIKE ?);" parent-id search-patt) res)) (define (filedb:get-path fdb id) (let* ((db (filedb:fdb-get-db fdb)) (idcache (filedb:fdb-get-idcache fdb)) (path (hash-table-ref/default idcache id #f))) (if path path (let loop ((curr-id id) (path "")) (let ((path-record (filedb:get-path-record fdb curr-id))) (if (not path-record) #f ;; this id has no path (let* ((parent-id (list-ref path-record 1)) (pname (list-ref path-record 0)) (newpath (string-append "/" pname path))) (if (= parent-id 0) ;; fields 0=path, 1=parent. root parent=0 (begin (hash-table-set! idcache id newpath) newpath) (loop parent-id newpath))))))))) (define (filedb:search db pattern) (let ((action (lambda (id)(print (filedb:get-path db id))))) (filedb:find-all db pattern action))) |
Modified megatest-version.scm from [6a6644ddd1] to [549dda85a8].
1 2 3 4 5 | ;; Always use two digit decimal ;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00.. (declare (unit megatest-version)) | | | 1 2 3 4 5 6 7 | ;; Always use two digit decimal ;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00.. (declare (unit megatest-version)) (define megatest-version 1.5513) |
Modified mt.scm from [c1cc555b4f] to [1d4bcb987f].
︙ | ︙ | |||
36 37 38 39 40 41 42 | ;; runs:get-runs-by-patt ;; get runs by list of criteria ;; register a test run with the db ;; ;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) ;; to extract info from the structure returned ;; | | | | | | | | | > > > > > > > > > > > > > > > > > > > > | 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 | ;; runs:get-runs-by-patt ;; get runs by list of criteria ;; register a test run with the db ;; ;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) ;; to extract info from the structure returned ;; (define (mt:get-runs-by-patt dbstruct keys runnamepatt targpatt) (let loop ((runsdat (db:get-runs-by-patt dbstruct keys runnamepatt targpatt 0 500)) (res '()) (offset 0) (limit 500)) ;; (print "runsdat: " runsdat) (let* ((header (vector-ref runsdat 0)) (runslst (vector-ref runsdat 1)) (full-list (append res runslst)) (have-more (eq? (length runslst) limit))) ;; (debug:print 0 "header: " header " runslst: " runslst " have-more: " have-more) (if have-more (let ((new-offset (+ offset limit)) (next-batch (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit))) (debug:print-info 4 "More than " limit " runs, have " (length full-list) " runs so far.") (debug:print-info 0 "next-batch: " next-batch) (loop next-batch full-list new-offset limit)) (vector header full-list))))) ;;====================================================================== ;; T E S T S ;;====================================================================== (define (mt:get-tests-for-run dbstruct run-id testpatt states status #!key (not-in #t) (sort-by 'event_time) (sort-order "ASC") (qryvals #f)) (let loop ((testsdat (db:get-tests-for-run dbstruct run-id testpatt states status 0 500 not-in sort-by sort-order qryvals: qryvals)) (res '()) (offset 0) (limit 500)) (let* ((full-list (append res testsdat)) (have-more (eq? (length testsdat) limit))) (if have-more (let ((new-offset (+ offset limit))) (debug:print-info 4 "More than " limit " tests, have " (length full-list) " tests so far.") (loop (db:get-tests-for-run dbstruct run-id testpatt states status new-offset limit not-in sort-by sort-order qryvals: qryvals) full-list new-offset limit)) full-list)))) (define (mt:get-prereqs-not-met run-id waitons ref-item-path #!key (mode 'normal)) (db:get-prereqs-not-met run-id waitons ref-item-path mode: mode)) (define (mt:get-run-stats dbstruct run-id) (db:get-run-stats dbstruct run-id)) (define (mt:discard-blocked-tests run-id failed-test tests test-records) (if (null? tests) tests (begin (debug:print-info 1 "Discarding tests from " tests " that are waiting on " failed-test) (let loop ((testn (car tests)) (remt (cdr tests)) (res '())) (let ((waitons (vector-ref (hash-table-ref/default test-records testn (vector #f #f '())) 2))) ;; (print "mt:discard-blocked-tests run-id: " run-id " failed-test: " failed-test " testn: " testn " with waitons: " waitons) (if (null? remt) (let ((new-res (reverse res))) ;; (print " new-res: " new-res) new-res) (loop (car remt) (cdr remt) (if (member failed-test waitons) res (cons testn res))))))))) ;;====================================================================== ;; T R I G G E R S ;;====================================================================== (define (mt:process-triggers test-id newstate newstatus) (let* ((test-dat (mt:lazy-get-test-info-by-id test-id)) |
︙ | ︙ | |||
120 121 122 123 124 125 126 | (conc state "/") (conc "/" status))))))) ;;====================================================================== ;; S T A T E A N D S T A T U S F O R T E S T S ;;====================================================================== | | | | | | | | | | | | | | | | | | | 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 | (conc state "/") (conc "/" status))))))) ;;====================================================================== ;; S T A T E A N D S T A T U S F O R T E S T S ;;====================================================================== (define (mt:roll-up-pass-fail-counts dbstruct run-id test-name item-path status) (if (and (not (equal? item-path "")) (member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK" "SKIP"))) (begin (db:update-pass-fail-counts dbstruct run-id test-name) (if (equal? status "RUNNING") (db:top-test-set-running dbstruct run-id test-name) (db:top-test-set-per-pf-counts dbstruct run-id test-name)) #f) #f)) ;; ;; speed up for common cases with a little logic ;; (define (mt:test-set-state-status-by-id dbstruct run-id test-id newstate newstatus newcomment) ;; (cond ;; ((and newstate newstatus newcomment) ;; (sqlite3: 'state-status-msg #t *default-numtries* newstate newstatus newcomment test-id)) ;; ((and newstate newstatus) ;; (cdb:client-call *runremote* 'state-status #t *default-numtries* newstate newstatus test-id)) ;; (else ;; (if newstate (cdb:client-call *runremote* 'set-test-state #t *default-numtries* newstate test-id)) ;; (if newstatus (cdb:client-call *runremote* 'set-test-status #t *default-numtries* newstatus test-id)) ;; (if newcomment (cdb:client-call *runremote* 'set-test-comment #t *default-numtries* newcomment test-id)))) ;; (mt:process-triggers test-id newstate newstatus) ;; #t) (define (mt:lazy-get-test-info-by-id test-id) (let* ((tdat (hash-table-ref/default *test-info* test-id #f))) (if (and tdat (< (current-seconds)(+ (vector-ref tdat 0) 10))) (vector-ref tdat 1) ;; no need to update *test-info* as that is done in cdb:get-test-info-by-id |
︙ | ︙ |
Modified newdashboard.scm from [1f8bd891c4] to [4e9877b3af].
︙ | ︙ | |||
566 567 568 569 570 571 572 | (iup:attribute-set! tabtop "TABTITLE2" "Run Control") (iup:attribute-set! tabtop "TABTITLE3" "megatest.config") (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config") tabtop))) (define *current-window-id* 0) | | | | 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 | (iup:attribute-set! tabtop "TABTITLE2" "Run Control") (iup:attribute-set! tabtop "TABTITLE3" "megatest.config") (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config") tabtop))) (define *current-window-id* 0) (define (newdashboard dbstruct) (let* ((data (make-hash-table)) (keys (db:get-keys dbstruct)) (runname "%") (testpatt "%") (keypatts (map (lambda (k)(list k "%")) keys)) (states '()) (statuses '()) (nextmintime (current-milliseconds)) (my-window-id *current-window-id*)) |
︙ | ︙ |
Modified runs.scm from [631ee0cd7b] to [3ff33aede5].
︙ | ︙ | |||
365 366 367 368 369 370 371 | (cdr reg) (if (null? tal) ;; if tal is null and reg not full then '() as reg contents moved to tal '() reg))) (define runs:nothing-left-in-queue-count 0) | | | 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 | (cdr reg) (if (null? tal) ;; if tal is null and reg not full then '() as reg contents moved to tal '() reg))) (define runs:nothing-left-in-queue-count 0) (define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records) (let* ((loop-list (list hed tal reg reruns)) (prereqs-not-met (mt:get-prereqs-not-met run-id waitons item-path mode: testmode)) (fails (runs:calc-fails prereqs-not-met)) (non-completed (runs:calc-not-completed prereqs-not-met))) (debug:print-info 4 "START OF INNER COND #2 " "\n can-run-more: " can-run-more "\n testname: " hed |
︙ | ︙ | |||
448 449 450 451 452 453 454 | ;; We need to use this to dequeue this item as CANNOTRUN (for-each (lambda (prereq) (if (eq? (hash-table-ref/default test-registry prereq 'justfine) 'CANNOTRUN) (set! give-up #t))) prereqstrs) (if (and give-up (not (and (null? tal)(null? reg)))) | | > | > > > | | | | | < | 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 | ;; We need to use this to dequeue this item as CANNOTRUN (for-each (lambda (prereq) (if (eq? (hash-table-ref/default test-registry prereq 'justfine) 'CANNOTRUN) (set! give-up #t))) prereqstrs) (if (and give-up (not (and (null? tal)(null? reg)))) (let ((trimmed-tal (mt:discard-blocked-tests run-id hed tal test-records)) (trimmed-reg (mt:discard-blocked-tests run-id hed reg test-records))) (debug:print 1 "WARNING: test " hed " has discarded prerequisites, removing it from the queue") (if (and (null? trimmed-tal) (null? trimmed-reg)) #f (list (runs:queue-next-hed trimmed-tal trimmed-reg reglen regfull) (runs:queue-next-tal trimmed-tal trimmed-reg reglen regfull) (runs:queue-next-reg trimmed-tal trimmed-reg reglen regfull) reruns))) (list (car newtal)(append (cdr newtal) reg) '() reruns)))) ;; (debug:print-info 1 "allinqueue: " allinqueue) ;; (debug:print-info 1 "prereqstrs: " prereqstrs) ;; (debug:print-info 1 "notinqueue: " notinqueue) ;; (debug:print-info 1 "tal: " tal) ;; (debug:print-info 1 "newtal: " newtal) ;; (debug:print-info 1 "reg: " reg) |
︙ | ︙ | |||
872 873 874 875 876 877 878 | ;; if items is a proc then need to run items:get-items-from-config, get the list and loop ;; - but only do that if resources exist to kick off the job ;; EXPAND ITEMS ((or (procedure? items)(eq? items 'have-procedure)) (let ((can-run-more (runs:can-run-more-tests jobgroup max-concurrent-jobs))) (if (and (list? can-run-more) (car can-run-more)) | | | 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 | ;; if items is a proc then need to run items:get-items-from-config, get the list and loop ;; - but only do that if resources exist to kick off the job ;; EXPAND ITEMS ((or (procedure? items)(eq? items 'have-procedure)) (let ((can-run-more (runs:can-run-more-tests jobgroup max-concurrent-jobs))) (if (and (list? can-run-more) (car can-run-more)) (let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records))) (if loop-list (apply loop loop-list))) ;; if can't run more just loop with next possible test (loop (car newtal)(cdr newtal) reg reruns)))) ;; this case should not happen, added to help catch any bugs ((and (list? items) itemdat) |
︙ | ︙ |
Modified synchash.scm from [68c033427e] to [a110b60074].
︙ | ︙ | |||
53 54 55 56 57 58 59 | (set! deleted (cons id deleted)) (hash-table-delete! synchash id)))) orig-keys) (list changed deleted) ;; (list indat '()) ;; just for debugging )) | | | | | | 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 | (set! deleted (cons id deleted)) (hash-table-delete! synchash id)))) orig-keys) (list changed deleted) ;; (list indat '()) ;; just for debugging )) ;; (c?db:remote-run db:get-keys #f) ;; (c?db:remote-run db:get-num-runs #f "%") ;; (c?db:remote-run db:get-runs #f runnamepatt numruns *start-run-offset* keypatts) ;; ;; keynum => the field to use as the unique key (usually 0 but can be other field) ;; (define (synchash:client-get proc synckey keynum synchash . params) (let* ((data (apply cdb:remote-run synchash:server-get #f proc synckey keynum params)) (newdat (car data)) (removs (cadr data)) (myhash (hash-table-ref/default synchash synckey #f))) |
︙ | ︙ |
Modified tests.scm from [ed985ac2fe] to [fb86a2abb4].
︙ | ︙ | |||
24 25 26 27 28 29 30 31 32 33 34 35 36 37 | (declare (uses runconfig)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") ;; Call this one to do all the work and get a standardized list of tests (define (tests:get-all) (let* ((test-search-path (cons (conc *toppath* "/tests") ;; the default (tests:get-tests-search-path *configdat*)))) (tests:get-valid-tests (make-hash-table) test-search-path))) | > | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | (declare (uses runconfig)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") ;; Call this one to do all the work and get a standardized list of tests (define (tests:get-all) (let* ((test-search-path (cons (conc *toppath* "/tests") ;; the default (tests:get-tests-search-path *configdat*)))) (tests:get-valid-tests (make-hash-table) test-search-path))) |
︙ | ︙ | |||
130 131 132 133 134 135 136 | #f)) ;; get the previous record for when this test was run where all keys match but runname ;; returns #f if no such test found, returns a single test record if found ;; ;; Run this server-side ;; | | | | 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 | #f)) ;; get the previous record for when this test was run where all keys match but runname ;; returns #f if no such test found, returns a single test record if found ;; ;; Run this server-side ;; (define (test:get-previous-test-run-record dbstruct run-id test-name item-path) (let* ((keys (db:get-keys dbstruct)) (selstr (string-intersperse keys ",")) (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")) (keyvals #f)) ;; first look up the key values from the run selected by run-id (sqlite3:for-each-row (lambda (a . b) (set! keyvals (cons a b))) |
︙ | ︙ | |||
155 156 157 158 159 160 161 | (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id))) ;; for each run starting with the most recent look to see if there is a matching test ;; if found then return that matching test record (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) (if (null? prev-run-ids) #f (let loop ((hed (car prev-run-ids)) (tal (cdr prev-run-ids))) | | | | | 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 | (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id))) ;; for each run starting with the most recent look to see if there is a matching test ;; if found then return that matching test record (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) (if (null? prev-run-ids) #f (let loop ((hed (car prev-run-ids)) (tal (cdr prev-run-ids))) (let ((results (db:get-tests-for-run dbstruct run-id hed (conc test-name "/" item-path)'() '() #f #f #f #f #f))) (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results) (if (and (null? results) (not (null? tal))) (loop (car tal)(cdr tal)) (if (null? results) #f (car results)))))))))) ;; get the previous records for when these tests were run where all keys match but runname ;; NB// Merge this with test:get-previous-test-run-records? This one looks for all matching tests ;; can use wildcards. Also can likely be factored in with get test paths? ;; ;; Run this remotely!! ;; (define (test:get-matching-previous-test-run-records dbstruct run-id test-name item-path) (let* ((keys (db:get-keys dbstruct)) (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ",")) (qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND ")) (keyvals #f) (tests-hash (make-hash-table))) ;; first look up the key values from the run selected by run-id (sqlite3:for-each-row (lambda (a . b) |
︙ | ︙ | |||
196 197 198 199 200 201 202 | ;; collect all matching tests for the runs then ;; extract the most recent test and return that. (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) (if (null? prev-run-ids) '() ;; no previous runs? return null (let loop ((hed (car prev-run-ids)) (tal (cdr prev-run-ids))) | | | 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 | ;; collect all matching tests for the runs then ;; extract the most recent test and return that. (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) (if (null? prev-run-ids) '() ;; no previous runs? return null (let loop ((hed (car prev-run-ids)) (tal (cdr prev-run-ids))) (let ((results (db:get-tests-for-run dbstruct run-id hed (conc test-name "/" item-path) '() '() #f #f #f #f #f))) (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path " results: " (intersperse results "\n")) ;; Keep only the youngest of any test/item combination (for-each (lambda (testdat) (let* ((full-testname (conc (db:test-get-testname testdat) "/" (db:test-get-item-path testdat))) (stored-test (hash-table-ref/default tests-hash full-testname #f))) |
︙ | ︙ | |||
276 277 278 279 280 281 282 | (if (null? tal) #t (loop (car tal)(cdr tal))) #f)))))) (pop-directory) result))))) | | | | < < | | | | | | 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 | (if (null? tal) #t (loop (car tal)(cdr tal))) #f)))))) (pop-directory) result))))) (define (tests:test-force-state-status! dbstruct run-id test-id state status) (db:test-set-status-state dbstruct run-id test-id status state #f) (mt:process-triggers test-id state status)) ;; Do not rpc this one, do the underlying calls!!! (define (tests:test-set-status! dbstruct run-id test-id state status comment dat) (let* ((real-status status) (otherdat (if dat dat (make-hash-table))) (testdat (db:get-test-info-by-id dbstruct run-id test-id)) (run-id (db:test-get-run_id testdat)) (test-name (db:test-get-testname testdat)) (item-path (db:test-get-item-path testdat)) ;; before proceeding we must find out if the previous test (where all keys matched except runname) ;; was WAIVED if this test is FAIL ;; NOTES: ;; 1. Is the call to test:get-previous-run-record remotified? ;; 2. Add test for testconfig waiver propagation control here ;; (prev-test (if (equal? status "FAIL") (test:get-previous-test-run-record dbstruct run-id test-name item-path) #f)) (waived (if prev-test (if prev-test ;; true if we found a previous test in this run series (let ((prev-status (db:test-get-status prev-test)) (prev-state (db:test-get-state prev-test)) (prev-comment (db:test-get-comment prev-test))) (debug:print 4 "prev-status " prev-status ", prev-state " prev-state ", prev-comment " prev-comment) |
︙ | ︙ | |||
323 324 325 326 327 328 329 | (set! real-status "WAIVED")) (debug:print 4 "real-status " real-status ", waived " waived ", status " status) ;; update the primary record IF state AND status are defined (if (and state status) (begin | | | | | 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 | (set! real-status "WAIVED")) (debug:print 4 "real-status " real-status ", waived " waived ", status " status) ;; update the primary record IF state AND status are defined (if (and state status) (begin (db:test-set-status-state dbstruct run-id test-id real-status state (if waived waived comment)) (mt:process-triggers dbstruct run-id test-id state real-status))) ;; if status is "AUTO" then call rollup (note, this one modifies data in test ;; run area, it does remote calls under the hood. (if (and test-id state status (equal? status "AUTO")) (db:test-data-rollup dbstruct run-id test-id status)) ;; add metadata (need to do this way to avoid SQL injection issues) ;; :first_err ;; (let ((val (hash-table-ref/default otherdat ":first_err" #f))) ;; (if val ;; (sqlite3:execute db "UPDATE tests SET first_err=? WHERE run_id=? AND testname=? AND item_path=?;" val run-id test-name item-path))) |
︙ | ︙ | |||
364 365 366 367 368 369 370 | value "," expected "," tol "," units "," dcomment ",," ;; extra comma for status type ))) ;; This was run remote, don't think that makes sense. | | | < < | | > | > > | | | | | | 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 | value "," expected "," tol "," units "," dcomment ",," ;; extra comma for status type ))) ;; This was run remote, don't think that makes sense. (db:csv->test-data dbstruct run-id test-id dat)))) ;; need to update the top test record if PASS or FAIL and this is a subtest (if (not (equal? item-path "")) (mt:roll-up-pass-fail-counts dbstruct run-id test-name item-path status)) (if (or (and (string? comment) (string-match (regexp "\\S+") comment)) waived) (let ((cmt (if waived waived comment))) (db:test-set-comment dbstruct run-id test-id (db:save-string dbstruct cmt)))))) (define (tests:test-set-toplog! dbstruct run-id test-name logf) (sqlite3:execute (db:get-db dbstruct run-id) (db:get-query 'tests:test-set-toplog) (db:save-string dbstruct logf) test-name)) (define (tests:summarize-items dbstruct run-id test-id test-name force) ;; if not force then only update the record if one of these is true: ;; 1. logf is "log/final.log ;; 2. logf is same as outputfilename (let* ((outputfilename (conc "megatest-rollup-" test-name ".html")) (orig-dir (current-directory)) (logf-info (db:test-get-logfile-info dbstruct run-id test-name)) (logf (if logf-info (cadr logf-info) #f)) (path (if logf-info (car logf-info) #f))) ;; This query finds the path and changes the directory to it for the test (if (and (string? path) (directory? path)) ;; can get #f here under some wierd conditions. why, unknown ... (begin (debug:print 4 "Found path: " path) (change-directory path)) ;; (set! outputfilename (conc path "/" outputfilename))) (print "No such path: " path)) (debug:print 4 "summarize-items with logf " logf ", outputfilename " outputfilename " and force " force) (if (or (equal? logf "logs/final.log") (equal? logf outputfilename) force) (begin (if ;; (not (obtain-dot-lock outputfilename 1 5 7)) ;; retry every second for 20 seconds, call it dead after 30 seconds and steal the lock (not (lock-queue:wait-turn outputfilename test-id)) (print "Not updating " outputfilename " as another test item has signed up for the job") (begin (print "Obtained lock for " outputfilename) (let ((oup (open-output-file outputfilename)) (counts (make-hash-table)) (statecounts (make-hash-table)) (outtxt "") (tot 0) (testdat (db:test-get-records-for-index-file dbstruct run-id test-name))) (with-output-to-port oup (lambda () (set! outtxt (conc outtxt "<html><title>Summary: " test-name "</title><body><h2>Summary for " test-name "</h2>")) (for-each (lambda (testrecord) |
︙ | ︙ | |||
470 471 472 473 474 475 476 | "<tr><td>Item</td><td>State</td><td>Status</td><td>Comment</td>" outtxt "</table></body></html>") (release-dot-lock outputfilename))) (close-output-port oup) (lock-queue:release-lock outputfilename test-id) (change-directory orig-dir) ;; NB// tests:test-set-toplog! is remote internal... | | | 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 | "<tr><td>Item</td><td>State</td><td>Status</td><td>Comment</td>" outtxt "</table></body></html>") (release-dot-lock outputfilename))) (close-output-port oup) (lock-queue:release-lock outputfilename test-id) (change-directory orig-dir) ;; NB// tests:test-set-toplog! is remote internal... (tests:test-set-toplog! dbstruct run-id test-name outputfilename) ))))))) ;;====================================================================== ;; Gather data from test/task specifications ;;====================================================================== ;; (define (tests:get-valid-tests testsdir test-patts) ;; #!key (test-names '())) |
︙ | ︙ | |||
543 544 545 546 547 548 549 | #t ;; this is the correct order, b is waiting on a and b is before a (if (> a-priority b-priority) #t ;; if a is a higher priority than b then we are good to go #f)))))))) ;; for each test: ;; | | | | | | | 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 | #t ;; this is the correct order, b is waiting on a and b is before a (if (> a-priority b-priority) #t ;; if a is a higher priority than b then we are good to go #f)))))))) ;; for each test: ;; (define (tests:filter-non-runnable dbstruct run-id testkeynames testrecordshash) (let ((runnables '())) (for-each (lambda (testkeyname) (let* ((test-record (hash-table-ref testrecordshash testkeyname)) (test-name (tests:testqueue-get-testname test-record)) (itemdat (tests:testqueue-get-itemdat test-record)) (item-path (tests:testqueue-get-item_path test-record)) (waitons (tests:testqueue-get-waitons test-record)) (keep-test #t) (test-id (db:get-test-id dbstruct run-id test-name item-path)) (tdat (db:get-test-info-by-id dbstruct run-id test-id))) (if tdat (begin ;; Look at the test state and status (if (or (and (member (db:test-get-status tdat) '("PASS" "WARN" "WAIVED" "CHECK" "SKIP")) (equal? (db:test-get-state tdat) "COMPLETED")) (member (db:test-get-state tdat) '("INCOMPLETE" "KILLED"))) (set! keep-test #f)) ;; examine waitons for any fails. If it is FAIL or INCOMPLETE then eliminate this test ;; from the runnable list (if keep-test (for-each (lambda (waiton) ;; for now we are waiting only on the parent test (let* ((parent-test-id (db:get-test-id dbstruct run-id waiton "")) (wtdat (db:get-test-info-by-id dbstruct run-id test-id))) (if (or (and (equal? (db:test-get-state wtdat) "COMPLETED") (member (db:test-get-status wtdat) '("FAIL"))) (member (db:test-get-status wtdat) '("KILLED")) (member (db:test-get-state wtdat) '("INCOMPETE"))) ;; (if (or (member (db:test-get-status wtdat) ;; '("FAIL" "KILLED")) ;; (member (db:test-get-state wtdat) |
︙ | ︙ | |||
677 678 679 680 681 682 683 | ;;====================================================================== ;; test steps ;;====================================================================== ;; teststep-set-status! used to be here | | | | | | | | | > > | < | | | < | < | | < | 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 | ;;====================================================================== ;; test steps ;;====================================================================== ;; teststep-set-status! used to be here (define (test-get-kill-request dbstruct run-id test-id) ;; run-id test-name itemdat) (let* ((testdat (db:get-test-info-by-id run-id test-id))) ;; run-id test-name item-path))) (and testdat (equal? (test:get-state testdat) "KILLREQ")))) (define (test:tdb-get-rundat-count dbstruct run-id) (if tdb (let ((res 0)) (sqlite3:for-each-row (lambda (count) (set! res count)) (db:get-db dbstruct run-id) "SELECT count(id) FROM test_rundat;") res)) 0) (define (tests:update-central-meta-info dbstruct run-id test-id cpuload diskfree minutes uname hostname) ;; This is a good candidate for threading the requests to enable ;; transactionized write at the server (db:tests-update-cpuload-diskfree dbstruct run-id test-id cpuload diskfree) (if minutes (db:tests-update-run-duration dbstruct run-id test-id minutes)) (if (and uname hostname) (db:tests-update-uname-host dbstruct run-id test-id uname hostname))) ;; OPTIMIZE THESE!!! They are redundant!! (define (tests:set-full-meta-info dbstruct test-id run-id minutes work-area) (let* ((num-records 0) ;; (test:tdb-get-rundat-count tdb)) (cpuload (get-cpu-load)) (diskfree (get-df (current-directory))) (uname (get-uname "-srvpio")) (hostname (get-host-name))) ;; (tests:update-testdat-meta-info dbstruct run-id test-id work-area cpuload diskfree minutes) (tests:update-central-meta-info dbstruct run-id test-id cpuload diskfree minutes uname hostname))) (define (tests:set-partial-meta-info dbstruct test-id run-id minutes work-area) (let* ((cpuload (get-cpu-load)) (diskfree (get-df (current-directory)))) (tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes) ;; Update central with uname and hostname = #f (tests:update-central-meta-info test-id cpuload diskfree minutes #f #f))) (define (tests:update-testdat-meta-info dbstruct run-id test-id work-area cpuload diskfree minutes) (sqlite3:execute (db:get-db dbstruct run-id "INSERT INTO test_rundat (update_time,cpuload,diskfree,run_duration) VALUES (strftime('%s','now'),?,?,?);" cpuload diskfree minutes))) ;;====================================================================== ;; A R C H I V I N G ;;====================================================================== (define (test:archive db test-id) #f) (define (test:archive-tests db keynames target) #f) |
Modified tests/Makefile from [da94c6fb9c] to [0a1e46dab4].
1 2 3 4 5 6 7 | # run some tests BINPATH=$(shell readlink -m $(PWD)/../bin) MEGATEST=$(BINPATH)/megatest PATH := $(BINPATH):$(PATH) RUNNAME := $(shell date +w%V.%u.%H.%M) IPADDR := "-" | > | 1 2 3 4 5 6 7 8 | # # run some tests BINPATH=$(shell readlink -m $(PWD)/../bin) MEGATEST=$(BINPATH)/megatest PATH := $(BINPATH):$(PATH) RUNNAME := $(shell date +w%V.%u.%H.%M) IPADDR := "-" |
︙ | ︙ | |||
97 98 99 100 101 102 103 | test8 : test8a cd fullrun;$(MEGATEST) -runtests lineitem_fail 1 -target ubuntu/nfs/none :runname $(RUNNAME)_singletest cd fullrun;$(MEGATEST) -runtests runfirst/fall 1 -target ubuntu/nfs/none :runname $(RUNNAME)_singleitem cd fullrun;$(MEGATEST) -runtests test_mt_vars/2 -target ubuntu/nfs/none :runname $(RUNNAME)_singleitem_waiton # Some simple checks for bootstrapping and run loop logic | | > > > > | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 | test8 : test8a cd fullrun;$(MEGATEST) -runtests lineitem_fail 1 -target ubuntu/nfs/none :runname $(RUNNAME)_singletest cd fullrun;$(MEGATEST) -runtests runfirst/fall 1 -target ubuntu/nfs/none :runname $(RUNNAME)_singleitem cd fullrun;$(MEGATEST) -runtests test_mt_vars/2 -target ubuntu/nfs/none :runname $(RUNNAME)_singleitem_waiton # Some simple checks for bootstrapping and run loop logic test9 : minsetup test9a test9b test9c test9d test9e test9a : @echo Run super-simple mintest e, no waitons. cd mintest;megatest -runtests e -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) test9b : @echo Run simple mintest d with one waiton c cd mintest;megatest -runtests d -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) test9c : @echo Run mintest a with full waiton chain a -> b -> c -> d -> e cd mintest;megatest -runtests a -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) test9d : @echo Run an itemized test with no items cd mintest;megatest -runtests g -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) test9e : @echo Run mintest a1 with full waiton chain with d1fail: a1 -> b1 -> c1 -> d1fail -> e1 cd mintest;megatest -runtests a1 -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) test10 : @echo Run a bunch of different targets simultaneously (cd fullrun;$(MEGATEST) -server - ;sleep 2)& for targ in mint/btrfs/mintdir sunos/sshfs/loc; do \ (cd fullrun;$(MEGATEST) -runtests priority_10_waiton_1 -target $$targ :runname $(RUNNAME) &); done for sys in ubuntu suse redhat debian;do \ for fs in afs nfs zfs; do \ |
︙ | ︙ |
Added tests/mintest/tests/a1/testconfig version [9ca81e5ed7].
> > > > > > | 1 2 3 4 5 6 | # Add steps here. Format is "stepname script" [ezsteps] step1 echo SUCCESS [requirements] waiton b1 |
Added tests/mintest/tests/b1/testconfig version [4b7d232216].
> > > > > > | 1 2 3 4 5 6 | # Add steps here. Format is "stepname script" [ezsteps] step1 echo SUCCESS [requirements] waiton c1 |
Added tests/mintest/tests/c1/testconfig version [7cc87abb7f].
> > > > > > | 1 2 3 4 5 6 | # Add steps here. Format is "stepname script" [ezsteps] step1 echo SUCCESS [requirements] waiton d1fail |
Added tests/mintest/tests/d1fail/testconfig version [896a37e3bb].
> > > > > > > | 1 2 3 4 5 6 7 | # Add steps here. Format is "stepname script" [ezsteps] step1 echo SUCCESS step2 exit 123 [requirements] waiton e1 |
Added tests/mintest/tests/e1/testconfig version [8e71a3916a].
> > > > | 1 2 3 4 | # Add steps here. Format is "stepname script" [ezsteps] step1 echo SUCCESS |