Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -111,10 +111,11 @@ ;; (define (api:execute-requests dbstruct dat) (handle-exceptions exn (let ((call-chain (get-call-chain))) + (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an exception from peer") (print-call-chain (current-error-port)) (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens (if (not (vector? dat)) ;; it is an error to not receive a vector (vector #f #f "remote must be called with a vector") @@ -239,10 +240,11 @@ ;; TEST DATA ((read-test-data) (apply db:read-test-data dbstruct params)) ;; MISC + ((get-latest-host-load) (apply db:get-latest-host-load dbstruct params)) ((have-incompletes?) (apply db:have-incompletes? dbstruct params)) ((login) (apply db:login dbstruct params)) ((general-call) (let ((stmtname (car params)) (run-id (cadr params)) (realparams (cddr params))) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -1084,11 +1084,12 @@ (lambda ()(list (read)(read)(read))))) (with-input-from-file "/proc/loadavg" (lambda ()(list (read)(read)(read)))))) ;; get normalized cpu load by reading from /proc/loadavg and /proc/cpuinfo return all three values and the number of real cpus and the number of threads -;; returns list (normalized-proc-load normalized-core-load 1m 5m 15m ncores nthreads) +;; returns alist '((adj-cpu-load . normalized-proc-load) ... etc. +;; keys: adj-proc-load, adj-core-load, 1m-load, 5m-load, 15m-load ;; (define (common:get-normalized-cpu-load remote-host) (let ((data (if remote-host (with-input-from-pipe (conc "ssh " remote-host " cat /proc/loadavg;cat /proc/cpuinfo;echo end") @@ -1143,48 +1144,89 @@ (let ((res (system (conc "ping -c 1 " hostname " > /dev/null")))) (eq? res 0))) ;; ideally put all this info into the db, no need to preserve it across moving homehost ;; -(define (common:get-least-loaded-host hosts) - (if (null? hosts) - #f - ;; - ;; stategy: - ;; sort by last-used and normalized-load - ;; if last-updated > 15 seconds then re-update - ;; take the host with the lowest load with the lowest last-used (i.e. not used for longest time) - ;; - (let ((best-host #f) - (curr-time (current-seconds))) - (for-each - (lambda (hostname) - (let* ((rec (let ((h (hash-table-ref/default *host-loads* hostname #f))) - (if h - h - (let ((h (make-host))) - (hash-table-set! *host-loads* hostname h) - h)))) - ;; if host hasn't been pinged in 15 sec update it's data - (ping-good (if (< (- curr-time (host-last-update rec)) 15) - (host-reachable rec) - (or (host-reachable rec) - (begin - (host-reachable-set! rec (common:unix-ping hostname)) - (host-last-update-set! rec curr-time) - (host-last-cpuload-set! rec (common:get-normalized-cpu-load hostname)) - (host-reachable rec)))))) - (cond - ((not best-host) - (set! best-host hostname)) - ((and ping-good - (< (alist-ref 'adj-core-load (host-last-cpuload rec)) - (alist-ref 'adj-core-load - (host-last-cpuload (hash-table-ref *host-loads* best-host))))) - (set! best-host rec))))) - hosts) - best-host))) +;; return list of +;; ( reachable? cpuload update-time ) +(define (common:get-host-info hostname) + (let* ((loadinfo (rmt:get-latest-host-load hostname)) + (load (car loadinfo)) + (load-sample-time (cdr loadinfo)) + (load-sample-age (- (current-seconds) load-sample-time)) + (loadinfo-timeout-seconds 20) + (host-last-update-timeout-seconds 10) + (host-rec (hash-table-ref/default *host-loads* hostname #f)) + ) + (cond + ((< load-sample-age loadinfo-timeout-seconds) + (list #t + load-sample-time + load)) + ((and host-rec + (< (current-seconds) (+ (host-last-update host-rec) host-last-update-timeout-seconds))) + (list #t + (host-last-update host-rec) + (host-last-cpuload host-rec ))) + ((common:unix-ping hostname) + (list #t + (current-seconds) + (alist-ref 'adj-core-load (common:get-normalized-cpu-load hostname)))) + (else + (list #f 0 -1))))) + +(define (common:update-host-loads-table hosts-raw) + (let* ((hosts (filter (lambda (x) + (string-match (regexp "^\\S+$") x)) + hosts-raw))) + (for-each + (lambda (hostname) + (let* ((rec (let ((h (hash-table-ref/default *host-loads* hostname #f))) + (if h + h + (let ((h (make-host))) + (hash-table-set! *host-loads* hostname h) + h)))) + (host-info (common:get-host-info hostname)) + (is-reachable (car host-info)) + (last-reached-time (cadr host-info)) + (load (caddr host-info))) + (host-reachable-set! rec is-reachable) + (host-last-update-set! rec last-reached-time) + (host-last-cpuload-set! rec load))) + hosts))) + +(define (common:get-least-loaded-host hosts-raw) + (let* ((hosts (filter (lambda (x) + (string-match (regexp "^\\S+$") x)) + hosts-raw)) + (best-host #f) + (best-load 99999) + (curr-time (current-seconds))) + (common:update-host-loads-table hosts) + (for-each + (lambda (hostname) + (let* ((rec + (let ((h (hash-table-ref/default *host-loads* hostname #f))) + (if h + h + (let ((h (make-host))) + (hash-table-set! *host-loads* hostname h) + h)))) + (reachable (host-reachable rec)) + (load (host-last-cpuload rec))) + (cond + ((not reachable) #f) + ((< (+ load (/ (random 250) 1000)) ;; add a random factor to keep from getting in a rut + (+ best-load (/ (random 250) 1000)) ) + (set! best-load load) + (set! best-host hostname))))) + hosts) + best-host)) + + + (define (common:wait-for-cpuload maxload numcpus waitdelay #!key (count 1000) (msg #f)(remote-host #f)) (let* ((loadavg (common:get-cpu-load remote-host)) (first (car loadavg)) (next (cadr loadavg)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -18,13 +18,10 @@ (require-extension (srfi 18) extras tcp) ;; RADT => use of require-extension? (use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) ;; RADT => prefix?? -(include "/nfs/site/disks/icf_fdk_cw_gwa002/srehman/fossil/dbi/dbi.scm") -(import (prefix dbi dbi:)) - (declare (unit db)) (declare (uses common)) (declare (uses keys)) (declare (uses ods)) (declare (uses client)) @@ -85,12 +82,11 @@ default (begin (debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port)) default))) - ;;(apply dbi:get-one db stmt params))) - (apply dbi:get-one db stmt params))) + (apply sqlite3:first-result db stmt params))) ;; Get/open a database ;; if run-id => get run specific db ;; if #f => get main db ;; if db already open - return inmem @@ -135,11 +131,11 @@ (db:get-db dbstruct run-id) (begin (print-call-chain) (print "db:with-db called with dbdat instead of dbstruct, FIXME!!") dbstruct))) ;; cheat, allow for passing in a dbdat - (db (db:dbdat-get-db dbdat))) + (db (db:dbdat-get-db dbdat))) (handle-exceptions exn (begin (debug:print-error 0 *default-log-port* "sqlite3 issue in db:with-db, dbstruct=" dbstruct ", run-id=" run-id ", proc=" proc ", params=" params " error: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port))) @@ -197,11 +193,11 @@ ;; (or (configf:lookup *configdat* "setup" "dbdir") ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))) (define (db:set-sync db) (let ((syncprag (configf:lookup *configdat* "setup" "sychronous"))) - (dbi:exec db (conc "PRAGMA synchronous = " (or syncprag 0) ";")))) + (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 0) ";")))) ;; open an sql database inside a file lock ;; returns: db existed-prior-to-opening ;; RA => Returns a db handler; sets the lock if opened in writable mode ;; @@ -209,31 +205,28 @@ (let* ((parent-dir (or (pathname-directory fname)(current-directory))) ;; no parent? go local (dir-writable (file-write-access? parent-dir)) (file-exists (file-exists? fname)) (file-write (if file-exists (file-write-access? fname) - dir-writable )) - (dbdat (cons (cons 'dbname fname) '()))) + dir-writable ))) (if file-write ;; dir-writable (let (;; (lock (obtain-dot-lock fname 1 5 10)) - (db (dbi:open 'sqlite3 dbdat))) - ;;(db (sqlite3:open-database fname))) - ;;(sqlite3:set-busy-handler! db (make-busy-timeout 136000)) + (db (sqlite3:open-database fname))) + (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) ;; (db:set-sync db) - (dbi:exec db "PRAGMA synchronous = 0;") + (sqlite3:execute db "PRAGMA synchronous = 0;") (if (not file-exists) (begin (if (string-match "^/tmp/.*" fname) ;; this is a file in /tmp - (dbi:exec db "PRAGMA journal_mode=WAL;") + (sqlite3:execute db "PRAGMA journal_mode=WAL;") (print "Creating " fname " in NON-WAL mode.")) (initproc db))) ;; (release-dot-lock fname) db) (begin (debug:print 2 *default-log-port* "WARNING: opening db in non-writable dir " fname) - (dbi:open 'sqlite3 dbdat))))) - ;;(sqlite3:open-database fname))))) ;; ) + (sqlite3:open-database fname))))) ;; ) ;; ;; This routine creates the db. It is only called if the db is not already opened ;; ;; ;; (define (db:open-rundb dbstruct run-id #!key (attemptnum 0)(do-not-open #f)) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) ;; (let* ((dbfile (db:dbfile-path run-id)) ;; (conc toppath "/db/" run-id ".db")) @@ -245,17 +238,17 @@ ;; ;; (release-dot-lock dbpath) ;; (if (> attemptnum 2) ;; (debug:print-error 0 *default-log-port* "tried twice, cannot create/initialize db for run-id " run-id ", at path " dbpath) ;; (db:open-rundb dbstruct run-id attemptnum (+ attemptnum 1)))) ;; (db:initialize-run-id-db db) -;; (dbi:exec +;; (sqlite3:execute ;; db ;; "INSERT OR IGNORE INTO tests (id,run_id,testname,event_time,item_path,state,status) VALUES (?,?,'bogustest',strftime('%s','now'),'nowherepath','DELETED','n/a');" ;; (* run-id 30000) ;; allow for up to 30k tests per run ;; run-id) ;; ;; do a dummy query to test that the table exists and the db is truly readable -;; (dbi:exec db "SELECT * FROM tests WHERE id=?;" (* run-id 30000)) +;; (sqlite3:execute db "SELECT * FROM tests WHERE id=?;" (* run-id 30000)) ;; )))) ;; add strings db to rundb, not in use yet ;; (olddb (if *megatest-db* ;; *megatest-db* ;; (let ((db (db:open-megatest-db))) ;; (set! *megatest-db* db) @@ -271,11 +264,10 @@ ;; db)) ;; This routine creates the db if not already present. It is only called if the db is not already opened ;; (define (db:open-db dbstruct #!key (areapath #f)) - (print (db:open-megatest-db path: (db:dbfile-path))) (let ((tmpdb (dbr:dbstruct-tmpdb dbstruct))) ;; RA => Returns the first reference in dbstruct (if tmpdb tmpdb ;; (mutex-lock! *rundb-mutex*) (let* ((dbpath (db:dbfile-path)) ;; 0)) @@ -353,16 +345,13 @@ (begin ;; (db:sync-touched dbstruct 0 force-sync: #t) ;; NO. Do not do this here. Instead we rely on a server to be started when there are writes, even if the server itself is not going to be used as a server. (let ((tdb (db:dbdat-get-db (dbr:dbstruct-tmpdb dbstruct))) (mdb (db:dbdat-get-db (dbr:dbstruct-mtdb dbstruct))) (rdb (db:dbdat-get-db (dbr:dbstruct-refndb dbstruct)))) - (if tdb (dbi:close tdb)) - (if mdb (dbi:close mdb)) - (if rdb (dbi:close rdb)))))) - ;;(if tdb (dbi:close tdb)) - ;;(if mdb (dbi:close mdb)) - ;;(if rdb (dbi:close rdb)))))) + (if tdb (sqlite3:finalize! tdb)) + (if mdb (sqlite3:finalize! mdb)) + (if rdb (sqlite3:finalize! rdb)))))) ;; (let ((locdbs (dbr:dbstruct-locdbs dbstruct))) ;; (if (hash-table? locdbs) ;; (for-each (lambda (run-id) ;; (db:close-run-db dbstruct run-id)) @@ -480,12 +469,11 @@ ;; else return dbdat ;; (define (db:repair-db dbdat #!key (numtries 1)) (let* ((dbpath (db:dbdat-get-path dbdat)) (dbdir (pathname-directory dbpath)) - (fname (pathname-strip-directory dbpath)) - (dbdat '())) + (fname (pathname-strip-directory dbpath))) (debug:print-info 0 *default-log-port* "Checking db " dbpath " for errors.") (cond ((not (file-write-access? dbdir)) (debug:print 0 *default-log-port* "WARNING: can't write to " dbdir ", can't fix " fname) #f) @@ -513,24 +501,24 @@ "megatest -import-megatest.db;megatest -cleanup-db") "\"\n") (exit) ;; we can not safely continue when a db was corrupted - even if fixed. ) ;; test read/write access to the database - (let ((db (dbi:open 'sqlite3 (cons (cons ('dbname dbpath) '()))))) + (let ((db (sqlite3:open-database dbpath))) (cond ((equal? fname "megatest.db") - (dbi:exec db "DELETE FROM tests WHERE state='DELETED';")) + (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';")) ((equal? fname "main.db") - (dbi:exec db "DELETE FROM runs WHERE state='deleted';")) + (sqlite3:execute db "DELETE FROM runs WHERE state='deleted';")) ((string-match "\\d.db" fname) - (dbi:exec db "UPDATE tests SET state='DELETED' WHERE state='DELETED';")) + (sqlite3:execute db "UPDATE tests SET state='DELETED' WHERE state='DELETED';")) ((equal? fname "monitor.db") - (dbi:exec "DELETE FROM servers WHERE state LIKE 'defunct%';")) + (sqlite3:execute "DELETE FROM servers WHERE state LIKE 'defunct%';")) (else - (dbi:exec db "vacuum;"))) + (sqlite3:execute db "vacuum;"))) - (dbi:close db) + (finalize! db) #t)))))) ;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) ) ;; db's are dbdat's ;; @@ -560,13 +548,13 @@ 0) ;; this is the work to be done (cond ((not fromdb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with fromdb missing") -1) ((not todb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with todb missing") -2) - ((not (eq? 'sqlite3 (dbi:db-dbtype fromdb))) + ((not (sqlite3:database? (db:dbdat-get-db fromdb))) (debug:print-error 0 *default-log-port* "db:sync-tables called with fromdb not a database " fromdb) -3) - ((not (eq? 'sqlite3 (dbi:db-dbtype todb))) + ((not (sqlite3:database? (db:dbdat-get-db todb))) (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a database " todb) -4) (else (let ((stmts (make-hash-table)) ;; table-field => stmt (all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 )) (numrecs (make-hash-table)) @@ -607,11 +595,11 @@ (hash-table-set! field->num field count) (set! count (+ count 1))) fields) ;; read the source table - (dbi:for-each-row + (sqlite3:for-each-row (lambda (a . b) (set! fromdat (cons (apply vector a b) fromdat)) (if (> (length fromdat) batch-len) (begin (set! fromdats (cons fromdat fromdats)) @@ -626,25 +614,25 @@ (if (common:low-noise-print 120 "sync-records") (debug:print-info 4 *default-log-port* "found " totrecords " records to sync")) ;; read the target table - (dbi:for-each-row + (sqlite3:for-each-row (lambda (a . b) (hash-table-set! todat a (apply vector a b))) (db:dbdat-get-db todb) full-sel) ;; first pass implementation, just insert all changed rows (for-each (lambda (targdb) (let* ((db (db:dbdat-get-db targdb)) - (stmth (dbi:prepare db full-ins))) + (stmth (sqlite3:prepare db full-ins))) ;; (db:delay-if-busy targdb) ;; NO WAITING (for-each (lambda (fromdat-lst) - (dbi:with-transaction + (sqlite3:with-transaction db (lambda () (for-each ;; (lambda (fromrow) (let* ((a (vector-ref fromrow 0)) @@ -657,16 +645,16 @@ (if (and same (< i (- num-fields 1))) (loop (+ i 1)))) (if (not same) (begin - (apply dbi:exec stmth (vector->list fromrow)) + (apply sqlite3:execute stmth (vector->list fromrow)) (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0))))))) fromdat-lst)) )) fromdats) - (dbi:close stmth))) + (sqlite3:finalize! stmth))) (append (list todb) slave-dbs)))) tbls) (let* ((runtime (- (current-milliseconds) start-time)) (should-print (or (debug:debug-mode 12) (common:low-noise-print 120 "db sync" (> runtime 500))))) ;; low and high sync times treated as separate. @@ -690,17 +678,17 @@ (handle-exceptions exn (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn)) (debug:print 0 *default-log-port* "Column last_update already added to " table-name " table") (db:general-sqlite-error-dump exn "alter table " table-name " ..." #f "none")) - (dbi:exec + (sqlite3:execute frundb (conc "ALTER TABLE " table-name " ADD COLUMN last_update INTEGER DEFAULT 0"))) - (dbi:exec + (sqlite3:execute frundb (conc "DROP TRIGGER IF EXISTS update_" table-name "_trigger;")) - (dbi:exec + (sqlite3:execute frundb (conc "CREATE TRIGGER IF NOT EXISTS update_" table-name "_trigger AFTER UPDATE ON " table-name " FOR EACH ROW BEGIN UPDATE " table-name " SET last_update=(strftime('%s','now')) @@ -716,30 +704,30 @@ (handle-exceptions exn (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn)) (debug:print 0 *default-log-port* "Column last_update already added to runs table") (db:general-sqlite-error-dump exn "alter table runs ..." #f "none")) - (dbi:exec + (sqlite3:execute maindb "ALTER TABLE runs ADD COLUMN last_update INTEGER DEFAULT 0")) ;; these schema changes don't need exception handling - (dbi:exec + (sqlite3:execute maindb "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs FOR EACH ROW BEGIN UPDATE runs SET last_update=(strftime('%s','now')) WHERE id=old.id; END;") - (dbi:exec maindb "CREATE TABLE IF NOT EXISTS run_stats ( + (sqlite3:execute maindb "CREATE TABLE IF NOT EXISTS run_stats ( id INTEGER PRIMARY KEY, run_id INTEGER, state TEXT, status TEXT, count INTEGER, last_update INTEGER DEFAULT (strftime('%s','now')))") - (dbi:exec maindb "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats + (sqlite3:execute maindb "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats FOR EACH ROW BEGIN UPDATE run_stats SET last_update=(strftime('%s','now')) WHERE id=old.id; END;")) @@ -869,11 +857,11 @@ ;; (db:delay-if-busy mtdb) ;; (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id))) ;; ;; (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))) ;; (debug:print 0 *default-log-port* "INFO: Propagating " (length testrecs) " records for run-id=" run-id " to run specific db") ;; (db:replace-test-records dbstruct run-id testrecs) -;; (dbi:close (db:dbdat-get-db (dbr:dbstruct-rundb dbstruct))))) +;; (sqlite3:finalize! (db:dbdat-get-db (dbr:dbstruct-rundb dbstruct))))) ;; run-ids))) ;; now ensure all newdb data are synced to megatest.db ;; do not use the run-ids list passed in to the function ;; @@ -953,11 +941,11 @@ ;; (debug:print 0 *default-log-port* "Removing database file for deleted run " fullname) ;; (delete-file fullname))))) ;; dead-runs)))) ;; ;; (db:close-all dbstruct) - ;; (dbi:close mdb) + ;; (sqlite3:finalize! mdb) data-synced))) ;; keeping it around for debugging purposes only (define (open-run-close-no-exception-handling proc idb . params) (debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params) @@ -965,17 +953,17 @@ (exit) (if (or *db-write-access* (not #t)) ;; was: (member proc * db:all-write-procs *))) (let* ((db (cond ((pair? idb) (db:dbdat-get-db idb)) - ((dbi:database? idb) idb) + ((sqlite3:database? idb) idb) ((not idb) (debug:print-error 0 *default-log-port* "cannot open-run-close with #f anymore")) ((procedure? idb) (idb)) (else (debug:print-error 0 *default-log-port* "cannot open-run-close with #f anymore")))) (res #f)) (set! res (apply proc db params)) - (if (not idb)(dbi:close dbstruct)) + (if (not idb)(sqlite3:finalize! dbstruct)) (debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling END" ) res) #f)) (define (open-run-close-exception-handling proc idb . params) @@ -1017,18 +1005,18 @@ "pass_count")) (begin (print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table, you must remove your megatest.db and /.db before trying again.") (exit 1))))) keys) - (dbi:with-transaction + (sqlite3:with-transaction db (lambda () - (dbi:exec db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));") + (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) - (dbi:exec db "INSERT OR REPLACE INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT")) + (sqlite3:execute db "INSERT OR REPLACE INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT")) keys) - (dbi:exec db (conc + (sqlite3:execute db (conc "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, \n " fieldstr (if havekeys "," "") " runname TEXT DEFAULT 'norun', state TEXT DEFAULT '', status TEXT DEFAULT '', @@ -1037,30 +1025,30 @@ comment TEXT DEFAULT '', fail_count INTEGER DEFAULT 0, pass_count INTEGER DEFAULT 0, last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));")) - (dbi:exec db "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs + (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs FOR EACH ROW BEGIN UPDATE runs SET last_update=(strftime('%s','now')) WHERE id=old.id; END;") - (dbi:exec db "CREATE TABLE IF NOT EXISTS run_stats ( + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS run_stats ( id INTEGER PRIMARY KEY, run_id INTEGER, state TEXT, status TEXT, count INTEGER, last_update INTEGER DEFAULT (strftime('%s','now')))") - (dbi:exec db "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats + (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats FOR EACH ROW BEGIN UPDATE run_stats SET last_update=(strftime('%s','now')) WHERE id=old.id; END;") - (dbi:exec db "CREATE TABLE IF NOT EXISTS test_meta ( + (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 '', @@ -1069,11 +1057,11 @@ avg_runtime REAL, avg_disk REAL, tags TEXT DEFAULT '', jobgroup TEXT DEFAULT 'default', CONSTRAINT test_meta_constraint UNIQUE (testname));") - (dbi:exec db "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY, + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY, action TEXT DEFAULT '', owner TEXT, state TEXT DEFAULT 'new', target TEXT DEFAULT '', name TEXT DEFAULT '', @@ -1081,56 +1069,56 @@ keylock TEXT, params TEXT, creation_time TIMESTAMP DEFAULT (strftime('%s','now')), execution_time TIMESTAMP);") ;; archive disk areas, cached info from [archive-disks] - (dbi:exec db "CREATE TABLE IF NOT EXISTS archive_disks ( + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_disks ( id INTEGER PRIMARY KEY, archive_area_name TEXT, disk_path TEXT, last_df INTEGER DEFAULT -1, last_df_time TIMESTAMP DEFAULT (strftime('%s','now')), creation_time TIMESTAMP DEFAULT (strftime('%','now')));") ;; individual bup (or tar) data chunks - (dbi:exec db "CREATE TABLE IF NOT EXISTS archive_blocks ( + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_blocks ( id INTEGER PRIMARY KEY, archive_disk_id INTEGER, disk_path TEXT, last_du INTEGER DEFAULT -1, last_du_time TIMESTAMP DEFAULT (strftime('%s','now')), creation_time TIMESTAMP DEFAULT (strftime('%','now')));") ;; tests allocated to what chunks. reusing a chunk for a test/item_path is very efficient ;; NB// the per run/test recording of where the archive is stored is done in the test ;; record. - (dbi:exec db "CREATE TABLE IF NOT EXISTS archive_allocations ( + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_allocations ( id INTEGER PRIMARY KEY, archive_block_id INTEGER, testname TEXT, item_path TEXT, creation_time TIMESTAMP DEFAULT (strftime('%','now')));") ;; move this clean up call somewhere else - (dbi:exec db "DELETE FROM tasks_queue WHERE state='done' AND creation_time < ?;" (- (current-seconds)(* 24 60 60))) ;; remove older than 24 hrs - (dbi:exec db (conc "CREATE INDEX IF NOT EXISTS runs_index ON runs (runname" (if havekeys "," "") keystr ");")) - ;; (dbi:exec db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;") - (dbi:exec db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);") - (dbi:exec db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, + (sqlite3:execute db "DELETE FROM tasks_queue WHERE state='done' AND creation_time < ?;" (- (current-seconds)(* 24 60 60))) ;; remove older than 24 hrs + (sqlite3:execute db (conc "CREATE INDEX IF NOT EXISTS 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));") - (dbi:exec db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") + (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. ;; cannot use db:set-var since it will deadlock, hardwire the code here - (dbi:exec db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" (common:version-signature)) + (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" (common:version-signature)) (debug:print-info 11 *default-log-port* "db:initialize END"))))) ;;====================================================================== ;; R U N S P E C I F I C D B ;;====================================================================== (define (db:initialize-run-id-db db) - (dbi:with-transaction + (sqlite3:with-transaction db (lambda () - (dbi:exec db "CREATE TABLE IF NOT EXISTS tests + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tests (id INTEGER PRIMARY KEY, run_id INTEGER DEFAULT -1, testname TEXT DEFAULT 'noname', host TEXT DEFAULT 'n/a', cpuload REAL DEFAULT -1, @@ -1150,18 +1138,18 @@ fail_count INTEGER DEFAULT 0, pass_count INTEGER DEFAULT 0, archived INTEGER DEFAULT 0, -- 0=no, > 1=archive block id where test data can be found last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path));") - (dbi:exec db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path);") - (dbi:exec db "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests + (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path);") + (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests FOR EACH ROW BEGIN UPDATE tests SET last_update=(strftime('%s','now')) WHERE id=old.id; END;") - (dbi:exec db "CREATE TABLE IF NOT EXISTS test_steps + (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', @@ -1168,18 +1156,18 @@ event_time TIMESTAMP, comment TEXT DEFAULT '', logfile TEXT DEFAULT '', last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));") - (dbi:exec db "CREATE INDEX IF NOT EXISTS teststeps_index ON tests (run_id, testname, item_path);") - (dbi:exec db "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps + (sqlite3:execute db "CREATE INDEX IF NOT EXISTS teststeps_index ON tests (run_id, testname, item_path);") + (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps FOR EACH ROW BEGIN UPDATE test_steps SET last_update=(strftime('%s','now')) WHERE id=old.id; END;") - (dbi:exec db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, + (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, @@ -1188,26 +1176,26 @@ comment TEXT DEFAULT '', status TEXT DEFAULT 'n/a', type TEXT DEFAULT '', last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));") - (dbi:exec db "CREATE INDEX IF NOT EXISTS test_data_index ON test_data (test_id);") - (dbi:exec db "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data + (sqlite3:execute db "CREATE INDEX IF NOT EXISTS test_data_index ON test_data (test_id);") + (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data FOR EACH ROW BEGIN UPDATE test_data SET last_update=(strftime('%s','now')) WHERE id=old.id; END;") - (dbi:exec db "CREATE TABLE IF NOT EXISTS test_rundat ( + (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);") - (dbi:exec db "CREATE TABLE IF NOT EXISTS archives ( + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archives ( id INTEGER PRIMARY KEY, test_id INTEGER, state TEXT DEFAULT 'new', status TEXT DEFAULT 'n/a', archive_type TEXT DEFAULT 'bup', @@ -1226,11 +1214,11 @@ (define (db:archive-get-allocations dbstruct testname itempath dneeded) (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db (db (db:dbdat-get-db dbdat)) (res '()) (blocks '())) ;; a block is an archive chunck that can be added too if there is space - (dbi:for-each-row + (sqlite3:for-each-row (lambda (id archive-disk-id disk-path last-du last-du-time) (set! res (cons (vector id archive-disk-id disk-path last-du last-du-time) res))) db "SELECT b.id,b.archive_disk_id,b.disk_path,b.last_du,b.last_du_time FROM archive_blocks AS b INNER JOIN archive_allocations AS a ON a.archive_block_id=b.id @@ -1237,11 +1225,11 @@ WHERE a.testname=? AND a.item_path=?;" testname itempath) ;; Now res has list of candidate paths, look in archive_disks for candidate with potential free space (if (null? res) '() - (dbi:for-each-row + (sqlite3:for-each-row (lambda (id archive-area-name disk-path last-df last-df-time) (set! blocks (cons (vector id archive-area-name disk-path last-df last-df-time) blocks))) db (conc "SELECT d.id,d.archive_area_name,disk_path,last_df,last_df_time FROM archive_disks AS d @@ -1256,24 +1244,24 @@ ;; (define (db:archive-register-disk dbstruct bdisk-name bdisk-path df) (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db (db (db:dbdat-get-db dbdat)) (res #f)) - (dbi:for-each-row + (sqlite3:for-each-row (lambda (id) (set! res id)) db "SELECT id FROM archive_disks WHERE archive_area_name=? AND disk_path=?;" bdisk-name bdisk-path) (if res ;; record exists, update df and return id (begin - (dbi:exec db "UPDATE archive_disks SET last_df=?,last_df_time=(strftime('%s','now')) + (sqlite3:execute db "UPDATE archive_disks SET last_df=?,last_df_time=(strftime('%s','now')) WHERE archive_area_name=? AND disk_path=?;" df bdisk-name bdisk-path) res) (begin - (dbi:exec + (sqlite3:execute db "INSERT OR REPLACE INTO archive_disks (archive_area_name,disk_path,last_df) VALUES (?,?,?);" bdisk-name bdisk-path df) (db:archive-register-disk dbstruct bdisk-name bdisk-path df))))) @@ -1285,24 +1273,24 @@ (define (db:archive-register-block-name dbstruct bdisk-id archive-path #!key (du #f)) (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db (db (db:dbdat-get-db dbdat)) (res #f)) ;; first look to see if this path is already registered - (dbi:for-each-row + (sqlite3:for-each-row (lambda (id) (set! res id)) db "SELECT id FROM archive_blocks WHERE archive_disk_id=? AND disk_path=?;" bdisk-id archive-path) (if res ;; record exists, update du if applicable and return res (begin - (if du (dbi:exec db "UPDATE archive_blocks SET last_du=?,last_du_time=(strftime('%s','now')) + (if du (sqlite3:exectute db "UPDATE archive_blocks SET last_du=?,last_du_time=(strftime('%s','now')) WHERE archive_disk_id=? AND disk_path=?;" bdisk-id archive-path du)) res) (begin - (dbi:exec db "INSERT OR REPLACE INTO archive_blocks (archive_disk_id,disk_path,last_du) + (sqlite3:execute db "INSERT OR REPLACE INTO archive_blocks (archive_disk_id,disk_path,last_du) VALUES (?,?,?);" bdisk-id archive-path (or du 0)) (db:archive-register-block-name dbstruct bdisk-id archive-path du: du))))) @@ -1312,11 +1300,11 @@ (db:with-db dbstruct run-id #f (lambda (db) - (dbi:exec db "UPDATE tests SET archived=? WHERE id=?;" + (sqlite3:execute db "UPDATE tests SET archived=? WHERE id=?;" archive-block-id test-id)))) ;; Look up the archive block info given a block-id ;; (define (db:test-get-archive-block-info dbstruct archive-block-id) @@ -1324,11 +1312,11 @@ dbstruct #f #f (lambda (db) (let ((res #f)) - (dbi:for-each-row + (sqlite3:for-each-row ;; 0 1 2 3 4 5 (lambda (id archive-disk-id disk-path last-du last-du-time creation-time) (set! res (vector id archive-disk-id disk-path last-du last-du-time creation-time))) db "SELECT id,archive_disk_id,disk_path,last_du,last_du_time,creation_time FROM archive_blocks WHERE id=?;" @@ -1338,43 +1326,43 @@ ;; (define (db:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey) ;; (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db ;; (db (db:dbdat-get-db dbdat)) ;; (res '()) ;; (blocks '())) ;; a block is an archive chunck that can be added too if there is space -;; (dbi:for-each-row #f) +;; (sqlite3:for-each-row #f) ;;====================================================================== ;; L O G G I N G D B ;;====================================================================== (define (open-logging-db) (let* ((dbpath (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname) (dbexists (file-exists? dbpath)) - (db (dbi:open 'sqlite3 (cons (cons ('dbname dbpath) '())))) + (db (sqlite3:open-database dbpath)) (handler (make-busy-timeout (if (args:get-arg "-override-timeout") (string->number (args:get-arg "-override-timeout")) 136000)))) ;; 136000))) - ;;(sqlite3:set-busy-handler! db handler) + (sqlite3:set-busy-handler! db handler) (if (not dbexists) (begin - (dbi:exec 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);") - (db:set-sync db) ;; (dbi:exec db (conc "PRAGMA synchronous = 0;")) + (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);") + (db:set-sync db) ;; (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))) - (dbi:exec db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);" + (sqlite3:execute db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);" logline (current-directory) (string-intersperse (argv) " ") (current-process-id)) - (dbi:close db) + (sqlite3:finalize! db) logline)) ;;====================================================================== ;; D B U T I L S ;;====================================================================== @@ -1401,11 +1389,11 @@ ;; HOWEVER: this code in run:test seems to work fine ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) ;; (db:test-get-run_duration testdat))) ;; 600) ;; (db:delay-if-busy dbdat) - (dbi:for-each-row + (sqlite3:for-each-row (lambda (test-id run-dir uname testname item-path) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? (begin @@ -1417,11 +1405,11 @@ run-id deadtime) ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config ;; ;; (db:delay-if-busy dbdat) - (dbi:for-each-row + (sqlite3:for-each-row (lambda (test-id run-dir uname testname item-path) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) @@ -1465,11 +1453,11 @@ ;; HOWEVER: this code in run:test seems to work fine ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) ;; (db:test-get-run_duration testdat))) ;; 600) ;; (db:delay-if-busy dbdat) - (dbi:for-each-row + (sqlite3:for-each-row (lambda (test-id run-dir uname testname item-path) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? (begin @@ -1481,11 +1469,11 @@ run-id deadtime) ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config ;; ;; (db:delay-if-busy dbdat) - (dbi:for-each-row + (sqlite3:for-each-row (lambda (test-id run-dir uname testname item-path) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) @@ -1509,26 +1497,33 @@ (min-incompleted-ids (map car incompleted)) ;; do 'em all (all-ids (append min-incompleted-ids (map car oldlaunched)))) (if (> (length all-ids) 0) (begin (debug:print 0 *default-log-port* "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") " as INCOMPLETE") - (dbi:exec - db - (conc "UPDATE tests SET state='INCOMPLETE' WHERE run_id=? AND id IN (" - (string-intersperse (map conc all-ids) ",") - ");") - run-id)))) - - ;; Now do rollups for the toplevel tests - ;; - ;; (db:delay-if-busy dbdat) - (for-each - (lambda (toptest) - (let ((test-name (list-ref toptest 3))) -;; (run-id (list-ref toptest 5))) - (db:top-test-set-per-pf-counts dbstruct run-id test-name))) - toplevels))) + (for-each + (lambda (test-id) + (db:test-set-status-state dbstruct run-id test-id "COMPLETE" "DEAD" "Test failed to complete")) + all-ids)))))) + +;; ALL REPLACED BY THE BLOCK ABOVE +;; +;; (sqlite3:execute +;; db +;; (conc "UPDATE tests SET state='INCOMPLETE' WHERE run_id=? AND id IN (" +;; (string-intersperse (map conc all-ids) ",") +;; ");") +;; run-id)))) +;; +;; ;; Now do rollups for the toplevel tests +;; ;; +;; ;; (db:delay-if-busy dbdat) +;; (for-each +;; (lambda (toptest) +;; (let ((test-name (list-ref toptest 3))) +;; ;; (run-id (list-ref toptest 5))) +;; (db:top-test-set-per-pf-counts dbstruct run-id test-name))) +;; toplevels))) ;; BUG: Probably broken - does not explicitly use run-id in the query ;; (define (db:top-test-set-per-pf-counts dbstruct run-id test-name) (db:general-call (db:get-db dbstruct run-id) 'top-test-set-per-pf-counts (list test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name))) @@ -1546,14 +1541,14 @@ ;; b. .... ;; (define (db:clean-up dbdat) ;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") (let* ((db (db:dbdat-get-db dbdat)) - (count (dbi:get-one db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);")) + (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);")) (statements (map (lambda (stmt) - (dbi:exec db 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';" @@ -1563,25 +1558,25 @@ "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);" )))) ;; (db:delay-if-busy dbdat) - (dbi:with-transaction + (sqlite3:with-transaction db (lambda () - (dbi:for-each-row (lambda (tot) + (sqlite3:for-each-row (lambda (tot) (debug:print-info 0 *default-log-port* "Records count before clean: " tot)) count-stmt) - (map dbi:exec statements) - (dbi:for-each-row (lambda (tot) + (map sqlite3:execute statements) + (sqlite3:for-each-row (lambda (tot) (debug:print-info 0 *default-log-port* "Records count after clean: " tot)) count-stmt))) - (map dbi:close statements) - (dbi:close count-stmt) + (map sqlite3:finalize! statements) + (sqlite3:finalize! count-stmt) ;; (db:find-and-mark-incomplete db) ;; (db:delay-if-busy dbdat) - (dbi:exec db "VACUUM;"))) + (sqlite3:execute db "VACUUM;"))) ;; Clean out old junk and vacuum the database ;; ;; Ultimately do something like this: ;; @@ -1593,36 +1588,36 @@ ;; b. .... ;; (define (db:clean-up-rundb dbdat) ;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") (let* ((db (db:dbdat-get-db dbdat)) - (count-stmt (dbi:prepare db "SELECT (SELECT count(id) FROM tests);")) + (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests);")) (statements (map (lambda (stmt) - (dbi:prepare db stmt)) + (sqlite3:prepare db stmt)) (list ;; delete all tests that belong to runs that are 'deleted' ;; (conc "DELETE FROM tests WHERE run_id NOT IN (" (string-intersperse (map conc valid-runs) ",") ");") ;; delete all tests that are 'DELETED' "DELETE FROM tests WHERE state='DELETED';" )))) ;; (db:delay-if-busy dbdat) - (dbi:with-transaction + (sqlite3:with-transaction db (lambda () - (dbi:for-each-row (lambda (tot) + (sqlite3:for-each-row (lambda (tot) (debug:print-info 0 *default-log-port* "Records count before clean: " tot)) count-stmt) - (map dbi:exec statements) - (dbi:for-each-row (lambda (tot) + (map sqlite3:execute statements) + (sqlite3:for-each-row (lambda (tot) (debug:print-info 0 *default-log-port* "Records count after clean: " tot)) count-stmt))) - (map dbi:close statements) - (dbi:close count-stmt) + (map sqlite3:finalize! statements) + (sqlite3:finalize! count-stmt) ;; (db:find-and-mark-incomplete db) ;; (db:delay-if-busy dbdat) - (dbi:exec db "VACUUM;"))) + (sqlite3:execute db "VACUUM;"))) ;; Clean out old junk and vacuum the database ;; ;; Ultimately do something like this: ;; @@ -1634,42 +1629,42 @@ ;; b. .... ;; (define (db:clean-up-maindb dbdat) ;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") (let* ((db (db:dbdat-get-db dbdat)) - (count-stmt (dbi:prepare db "SELECT (SELECT count(id) FROM runs);")) + (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM runs);")) (statements (map (lambda (stmt) - (dbi:prepare db stmt)) + (sqlite3:prepare db stmt)) (list ;; delete all tests that belong to runs that are 'deleted' ;; (conc "DELETE FROM tests WHERE run_id NOT IN (" (string-intersperse (map conc valid-runs) ",") ");") ;; delete all tests that are 'DELETED' "DELETE FROM runs WHERE state='deleted';" ))) (dead-runs '())) - (dbi:for-each-row + (sqlite3:for-each-row (lambda (run-id) (set! dead-runs (cons run-id dead-runs))) db "SELECT id FROM runs WHERE state='deleted';") ;; (db:delay-if-busy dbdat) - (dbi:with-transaction + (sqlite3:with-transaction db (lambda () - (dbi:for-each-row (lambda (tot) + (sqlite3:for-each-row (lambda (tot) (debug:print-info 0 *default-log-port* "Records count before clean: " tot)) count-stmt) - (map dbi:exec statements) - (dbi:for-each-row (lambda (tot) + (map sqlite3:execute statements) + (sqlite3:for-each-row (lambda (tot) (debug:print-info 0 *default-log-port* "Records count after clean: " tot)) count-stmt))) - (map dbi:close statements) - (dbi:close count-stmt) + (map sqlite3:finalize! statements) + (sqlite3:finalize! count-stmt) ;; (db:find-and-mark-incomplete db) ;; (db:delay-if-busy dbdat) - (dbi:exec db "VACUUM;") + (sqlite3:execute db "VACUUM;") dead-runs)) ;;====================================================================== ;; M E T A G E T A N D S E T V A R S ;;====================================================================== @@ -1676,17 +1671,16 @@ ;; returns number if string->number is successful, string otherwise ;; also updates *global-delta* ;; (define (db:get-var dbstruct var) - (print dbstruct var) (let* ((res #f) (dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) - (dbi:for-each-row + (sqlite3:for-each-row (lambda (val) - (set! res (vector-ref val 0))) + (set! res val)) db "SELECT val FROM metadat WHERE var=?;" var) ;; convert to number if can (if (string? res) (let ((valnum (string->number res))) @@ -1706,34 +1700,33 @@ ;; (set! *last-global-delta-printed* *global-delta*))) (define (db:set-var dbstruct var val) (let* ((dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) - (dbi:exec db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val))) + (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val))) (define (db:del-var dbstruct var) ;; (db:delay-if-busy) (db:with-db dbstruct #f #t (lambda (db) - (dbi:exec db "DELETE FROM metadat WHERE var=?;" var)))) + (sqlite3:execute db "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) - (print dbstruct) (if *db-keys* *db-keys* (let ((res '())) (db:with-db dbstruct #f #f (lambda (db) - (dbi:for-each-row + (sqlite3:for-each-row (lambda (key) - (set! res (cons (vector-ref key 0) res))) + (set! res (cons key res))) db "SELECT fieldname FROM keys ORDER BY id DESC;"))) (set! *db-keys* res) res))) @@ -1762,13 +1755,12 @@ dbstruct #f ;; this is for the main runs db #f ;; does not modify db (lambda (db) (let ((res #f)) - (dbi:for-each-row + (sqlite3:for-each-row (lambda (runname) - (print runname) (set! res runname)) db "SELECT runname FROM runs WHERE id=?;" run-id) res)))) @@ -1778,13 +1770,12 @@ dbstruct #f #f (lambda (db) (let ((res #f)) - (dbi:for-each-row + (sqlite3:for-each-row (lambda (val) - (print val) (set! res val)) db (conc "SELECT " key " FROM runs WHERE id=?;") run-id) res)))) @@ -1827,23 +1818,23 @@ (debug:print 3 *default-log-port* "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str) (debug:print 2 *default-log-port* "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run") (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and" (let ((res #f)) ;; (db:delay-if-busy dbdat) - (apply dbi:exec db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");") + (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");") allvals) ;; (db:delay-if-busy dbdat) - (apply dbi:for-each-row + (apply sqlite3:for-each-row (lambda (id) (set! res id)) db (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");"))) ;(debug:print 4 *default-log-port* "qry: " qry) qry) qryvals) ;; (db:delay-if-busy dbdat) - (dbi:exec db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res) + (sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res) res) (begin (debug:print-error 0 *default-log-port* "Called without all necessary keys") #f)))) @@ -1879,11 +1870,11 @@ (conc " OFFSET " offset) "")))) (debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) (db:with-db dbstruct #f #f (lambda (db) - (dbi:for-each-row + (sqlite3:for-each-row (lambda (a . x) (set! res (cons (apply vector a x) res))) db qrystr ))) @@ -1920,11 +1911,11 @@ (db:with-db dbstruct #f #f (lambda (db) - (dbi:for-each-row + (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) @@ -1941,11 +1932,11 @@ #f #f (lambda (db) (let ((numruns 0)) (debug:print-info 11 *default-log-port* "db:get-num-runs START " runpatt) - (dbi:for-each-row + (sqlite3:for-each-row (lambda (count) (set! numruns count)) db "SELECT COUNT(id) FROM runs WHERE runname LIKE ? AND state != 'deleted';" runpatt) (debug:print-info 11 *default-log-port* "db:get-num-runs END " runpatt) @@ -1957,11 +1948,11 @@ (db:with-db dbstruct run-id #f (lambda (db) - (dbi:fold-row + (sqlite3:fold-row (lambda (res state status count) (cons (list state status count) res)) '() db "SELECT state,status,count(id) AS count FROM tests WHERE run_id=? AND NOT(uname='n/a' AND item_path='') GROUP BY state,status;;" @@ -1975,32 +1966,32 @@ dbstruct #f #f (lambda (db) ;; remove previous data - (let* ((stmt1 (dbi:prepare db "DELETE FROM run_stats WHERE run_id=? AND state=? AND status=?;")) - (stmt2 (dbi:prepare db "INSERT INTO run_stats (run_id,state,status,count) VALUES (?,?,?,?);")) + (let* ((stmt1 (sqlite3:prepare db "DELETE FROM run_stats WHERE run_id=? AND state=? AND status=?;")) + (stmt2 (sqlite3:prepare db "INSERT INTO run_stats (run_id,state,status,count) VALUES (?,?,?,?);")) (res - (dbi:with-transaction + (sqlite3:with-transaction db (lambda () (for-each (lambda (dat) - (dbi:exec stmt1 run-id (car dat)(cadr dat)) - (apply dbi:exec stmt2 run-id dat)) + (sqlite3:execute stmt1 run-id (car dat)(cadr dat)) + (apply sqlite3:execute stmt2 run-id dat)) stats))))) - (dbi:close stmt1) - (dbi:close stmt2) + (sqlite3:finalize! stmt1) + (sqlite3:finalize! stmt2) res)))) (define (db:get-main-run-stats dbstruct run-id) (db:with-db dbstruct #f ;; this data comes from main #f (lambda (db) - (dbi:fold-row + (sqlite3:fold-row (lambda (res state status count) (cons (list state status count) res)) '() db "SELECT state,status,count FROM run_stats WHERE run_id=? AND run_id IN (SELECT id FROM runs WHERE state NOT IN ('DELETED','deleted'));" @@ -2011,11 +2002,11 @@ dbstruct #f #f (lambda (db) (let ((run-ids '())) - (dbi:for-each-row + (sqlite3:for-each-row (lambda (run-id) (set! run-ids (cons run-id run-ids))) db "SELECT id FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;") (reverse run-ids))))) @@ -2031,11 +2022,11 @@ (curr (make-hash-table)) (res '()) (runs-info '())) ;; First get all the runname/run-ids ;; (db:delay-if-busy dbdat) - (dbi:for-each-row + (sqlite3:for-each-row (lambda (run-id runname) (set! runs-info (cons (list run-id runname) runs-info))) db "SELECT id,runname FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;") ;; If you change this to the more logical ASC please adjust calls to db:get-run-stats ;; for each run get stats data @@ -2047,11 +2038,11 @@ (db:with-db dbstruct run-id #f (lambda (db) - (dbi:for-each-row + (sqlite3:for-each-row (lambda (state status count) (let ((netstate (if (equal? state "COMPLETED") status state))) (if (string? netstate) (begin (hash-table-set! totals netstate (+ (hash-table-ref/default totals netstate 0) count)) @@ -2106,11 +2097,11 @@ (debug:print-info 4 *default-log-port* "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) (vector header (reverse (db:with-db dbstruct #f #f ;; reads db, does not write to it. (lambda (db) - (dbi:fold-row + (sqlite3:fold-row (lambda (res . r) (cons (list->vector r) res)) '() db qry-str @@ -2128,11 +2119,11 @@ (header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ",")))) (debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) ;; (db:delay-if-busy dbdat) - (dbi:for-each-row + (sqlite3:for-each-row (lambda (a . x) (set! res (apply vector a x))) db (conc "SELECT " keystr " FROM runs WHERE id=? AND state != 'deleted';") run-id) @@ -2145,11 +2136,11 @@ (db:with-db dbstruct #f #f (lambda (db) - (dbi:exec db "UPDATE runs SET comment=? WHERE id=?;" comment ;; (sdb:qry 'getid comment) + (sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment ;; (sdb:qry 'getid comment) run-id)))) ;; does not (obviously!) removed dependent data. But why not!!? (define (db:delete-run dbstruct run-id) ;; First set any related tests to DELETED @@ -2156,26 +2147,26 @@ (let* ((rdbdat (db:get-db dbstruct run-id)) (rdb (db:dbdat-get-db rdbdat)) (dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) ;; (db:delay-if-busy rdbdat) - (dbi:with-transaction + (sqlite3:with-transaction db (lambda () - (dbi:exec rdb "DELETE FROM test_steps WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);" run-id) - (dbi:exec rdb "DELETE FROM test_data WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);" run-id) - (dbi:exec rdb "UPDATE tests SET state='DELETED',comment='' WHERE run_id=?;" run-id) + (sqlite3:execute rdb "DELETE FROM test_steps WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);" run-id) + (sqlite3:execute rdb "DELETE FROM test_data WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);" run-id) + (sqlite3:execute rdb "UPDATE tests SET state='DELETED',comment='' WHERE run_id=?;" run-id) ;; (db:delay-if-busy dbdat) - (dbi:exec db "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id))))) + (sqlite3:execute db "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id))))) (define (db:update-run-event_time dbstruct run-id) (db:with-db dbstruct #f #t (lambda (db) - (dbi:exec db "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id)))) + (sqlite3:execute db "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id)))) (define (db:lock/unlock-run dbstruct run-id lock unlock user) (db:with-db dbstruct #f @@ -2183,31 +2174,31 @@ (lambda (db) (let ((newlockval (if lock "locked" (if unlock "unlocked" "locked")))) ;; semi-failsafe - (dbi:exec db "UPDATE runs SET state=? WHERE id=?;" newlockval run-id) - (dbi:exec db "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);" + (sqlite3:execute db "UPDATE runs SET state=? WHERE id=?;" newlockval run-id) + (sqlite3:execute db "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);" user (conc newlockval " " run-id)) (debug:print-info 1 *default-log-port* "" newlockval " run number " run-id))))) (define (db:set-run-status dbstruct run-id status msg) (let* ((dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) ;; (db:delay-if-busy dbdat) (if msg - (dbi:exec db "UPDATE runs SET status=?,comment=? WHERE id=?;" status msg run-id) - (dbi:exec db "UPDATE runs SET status=? WHERE id=?;" status run-id)))) + (sqlite3:execute db "UPDATE runs SET status=?,comment=? WHERE id=?;" status msg run-id) + (sqlite3:execute db "UPDATE runs SET status=? WHERE id=?;" status run-id)))) (define (db:get-run-status dbstruct run-id) (let ((res "n/a")) (db:with-db dbstruct #f #f (lambda (db) - (dbi:for-each-row + (sqlite3:for-each-row (lambda (status) (set! res status)) db "SELECT status FROM runs WHERE id=?;" run-id) @@ -2226,11 +2217,11 @@ (db (db:dbdat-get-db dbdat))) (for-each (lambda (key) (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) ;; (db:delay-if-busy dbdat) - (dbi:for-each-row + (sqlite3:for-each-row (lambda (key-val) (set! res (cons (list key key-val) res))) db qry run-id))) keys) (reverse res))) @@ -2243,11 +2234,11 @@ (db (db:dbdat-get-db dbdat))) (for-each (lambda (key) (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) ;; (db:delay-if-busy dbdat) - (dbi:for-each-row + (sqlite3:for-each-row (lambda (key-val) (set! res (cons key-val res))) db qry run-id))) keys) (let ((final-res (reverse res))) @@ -2268,11 +2259,11 @@ (keys (rmt:get-keys)) (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND "))) (let ((prev-run-ids '())) (db:with-db dbstruct #f #f ;; #f means work with the zeroth db - i.e. the runs db (lambda (db) - (apply dbi:for-each-row + (apply sqlite3:for-each-row (lambda (id) (set! prev-run-ids (cons id prev-run-ids))) db (conc "SELECT id FROM runs WHERE " qrystr " AND state != 'deleted' AND id != ?;") (append kvalues (list run-id))))) prev-run-ids))) @@ -2365,11 +2356,11 @@ ";" ))) (debug:print-info 8 *default-log-port* "db:get-tests-for-run run-id=" run-id ", qry=" qry) (db:with-db dbstruct run-id #f (lambda (db) - (dbi:for-each-row + (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 run-id @@ -2397,11 +2388,11 @@ (qry (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? " (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")))) (debug:print-info 8 *default-log-port* "db:get-tests-for-run qry=" qry) (db:with-db dbstruct run-id #f (lambda (db) - (dbi:for-each-row + (sqlite3:for-each-row (lambda (id testname item-path state status) ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment (set! res (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res))) db qry @@ -2410,11 +2401,11 @@ (define (db:get-testinfo-state-status dbstruct run-id test-id) (let ((res #f)) (db:with-db dbstruct run-id #f (lambda (db) - (dbi:for-each-row + (sqlite3:for-each-row (lambda (run-id testname item-path state status) ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment (set! res (vector test-id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-"))) db "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=?;" @@ -2449,11 +2440,11 @@ (let* ((dbdat (db:get-db dbstruct run-id)) (db (db:dbdat-get-db dbdat))) (db:general-call dbdat 'delete-test-step-records (list test-id)) ;; (db:delay-if-busy) (db:general-call dbdat 'delete-test-data-records (list test-id)) - (dbi:exec db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id))) + (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id))) ;; (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 @@ -2460,16 +2451,16 @@ (db:with-db dbstruct 0 #t (lambda (db) - (dbi:with-transaction + (sqlite3:with-transaction db (lambda () - (dbi:exec db "DELETE FROM test_steps WHERE test_id IN (SELECT id FROM tests WHERE state='DELETED' AND event_timelist rec)) ",") "\n") - (apply dbi:exec qry (vector->list rec))) + (apply sqlite3:execute qry (vector->list rec))) testrecs))) - (dbi:close qry))))) + (sqlite3:finalize! qry))))) ;; map a test-id into the proper range ;; (define (db:adj-test-id mtdb min-test-id test-id) (if (>= test-id min-test-id) test-id (let loop ((new-id min-test-id)) (let ((test-id-found #f)) - (dbi:for-each-row + (sqlite3:for-each-row (lambda (id) (set! test-id-found id)) (db:dbdat-get-db mtdb) "SELECT id FROM tests WHERE id=?;" new-id) @@ -2729,11 +2720,11 @@ ;; if test-id-found then need to try again (if test-id-found (loop (+ new-id 1)) (begin (debug:print-info 0 *default-log-port* "New test id " new-id " selected for test with id " test-id) - (dbi:exec mtdb "UPDATE tests SET id=? WHERE id=?;" new-id test-id))))))) + (sqlite3:execute mtdb "UPDATE tests SET id=? WHERE id=?;" new-id test-id))))))) ;; move test ids into the 30k * run_id range ;; (define (db:prep-megatest.db-adj-test-ids mtdb run-id testrecs) (debug:print-info 0 *default-log-port* "Adjusting test ids in megatest.db for run " run-id) @@ -2761,11 +2752,11 @@ dbstruct run-id #f (lambda (db) (let ((res #f)) - (dbi:for-each-row ;; attemptnum added to hold pid of top process (not Megatest) controlling a test + (sqlite3:for-each-row ;; attemptnum added to hold pid of top process (not Megatest) controlling a test (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived))) db (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=?;") @@ -2780,11 +2771,11 @@ dbstruct run-id #f (lambda (db) (let ((res '())) - (dbi:for-each-row + (sqlite3:for-each-row (lambda (a . b) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 (set! res (cons (apply vector a b) res))) db (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id in (" @@ -2796,11 +2787,11 @@ dbstruct run-id #f (lambda (db) (let ((res #f)) - (dbi:for-each-row + (sqlite3:for-each-row (lambda (a . b) (set! res (apply vector a b))) db (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=? AND run_id=?;") test-name item-path run-id) @@ -2826,11 +2817,11 @@ (db:with-db dbstruct run-id #t (lambda (db) - (dbi:exec + (sqlite3:execute db "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);" test-id teststep-name state-in status-in (current-seconds) (if comment comment "") (if logfile logfile ""))))) @@ -2841,11 +2832,11 @@ dbstruct run-id #f (lambda (db) (let* ((res '())) - (dbi:for-each-row + (sqlite3:for-each-row (lambda (id test-id stepname state status event-time logfile comment) (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment) res))) db "SELECT id,test_id,stepname,state,status,event_time,logfile,comment FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; test-id) @@ -2856,11 +2847,11 @@ dbstruct run-id #f (lambda (db) (let ((res '())) - (dbi:for-each-row + (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 "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; test-id) @@ -2879,11 +2870,11 @@ (let* ((dbdat (db:get-db dbstruct run-id)) (db (db:dbdat-get-db dbdat)) (fail-count 0) (pass-count 0)) ;; (db:delay-if-busy dbdat) - (dbi:for-each-row + (sqlite3:for-each-row (lambda (fcount pcount) (set! fail-count fcount) (set! pass-count pcount)) db "SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count, @@ -3029,11 +3020,11 @@ ((<=) (if (<= value expected) "pass" "fail")) (else (conc "ERROR: bad tol comparator " tol)))))) (debug:print 4 *default-log-port* "AFTER2: category: " category " variable: " variable " value: " value ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) ;; (db:delay-if-busy dbdat) - (dbi:exec db "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);" + (sqlite3:execute db "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))) ;; This routine moved from tdb.scm, tdb:read-test-data ;; @@ -3040,11 +3031,11 @@ (define (db:read-test-data dbstruct run-id test-id categorypatt) (let* ((dbdat (db:get-db dbstruct run-id)) (db (db:dbdat-get-db dbdat)) (res '())) ;; (db:delay-if-busy dbdat) - (dbi:for-each-row + (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 "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))) @@ -3062,17 +3053,17 @@ (conc key " like '" val "'")) keynames (string-split target "/")) " AND ")) ;; (testqry (tests:match->sqlqry testpatt)) - (runsqry (dbi:prepare db (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';")))) + (runsqry (sqlite3:prepare db (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';")))) ;; (debug:print 8 *default-log-port* "db:test-get-paths-matching-keynames-target-new\n runsqry=" runsqry "\n tstsqry=" testqry) - (dbi:for-each-row + (sqlite3:for-each-row (lambda (rid) (set! row-ids (cons rid row-ids))) runsqry) - (dbi:close runsqry) + (sqlite3:finalize! runsqry) row-ids)) ;; finds latest matching all patts for given run-id ;; (define (db:test-get-paths-matching-keynames-target-new dbstruct run-id keynames target res testpatt statepatt statuspatt runname) @@ -3081,11 +3072,11 @@ (db:with-db dbstruct run-id #f (lambda (db) - (dbi:for-each-row + (sqlite3:for-each-row (lambda (p) (set! res (cons p res))) db tstsqry run-id) @@ -3096,11 +3087,11 @@ dbstruct run-id #f (lambda (db) (let ((res 0)) - (dbi:for-each-row + (sqlite3:for-each-row (lambda (num-items) (set! res num-items)) db "SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND state NOT IN ('DELETED');" run-id @@ -3175,11 +3166,11 @@ (db:test-get-testname testdat) test-name)) (item-path (db:test-get-item-path testdat)) (tl-testdat (db:get-test-info dbstruct run-id test-name "")) (tl-test-id (db:test-get-id tl-testdat))) - (dbi:with-transaction + (sqlite3:with-transaction db (lambda () (db:test-set-state-status-by-id dbstruct run-id test-id state status comment) (if (not (equal? item-path "")) ;; only roll up IF incoming test is an item (let* ((state-status-counts (db:get-all-state-status-counts-for-test db run-id test-name item-path)) ;; item-path is used to exclude current state/status of THIS test @@ -3280,11 +3271,11 @@ dbstruct run-id #f (lambda (db) (let ((res #f)) - (dbi:for-each-row + (sqlite3:for-each-row (lambda (path final_logf) ;; (let ((path (sdb:qry 'getstr path-id)) ;; (final_logf (sdb:qry 'getstr final_logf-id))) (set! logf final_logf) (set! res (list path final_logf)) @@ -3469,26 +3460,44 @@ (string->symbol stmtname) stmtname) db:queries))) (if q (car q) #f)))) ;; (db:delay-if-busy dbdat) - (apply dbi:exec (db:dbdat-get-db dbdat) query params) + (apply sqlite3:execute (db:dbdat-get-db dbdat) query params) #t)) ;; get a summary of state and status counts to calculate a rollup ;; ;; NOTE: takes a db, not a dbstruct ;; (define (db:get-state-status-summary db run-id testname) (let ((res '())) - (dbi:for-each-row + (sqlite3:for-each-row (lambda (state status count) (set! res (cons (vector state status count) res))) db "SELECT state,status,count(state) FROM tests WHERE run_id=? AND testname=? AND item_path='' GROUP BY state,status;" run-id testname) res)) + + +(define (db:get-latest-host-load dbstruct raw-hostname) + (let* ((hostname (string-substitute "\\..*$" "" raw-hostname)) + (res (cons -1 0)) + (mydb (db:dbdat-get-db (db:get-db dbstruct 0))) + ) + (db:with-db + dbstruct + 0 + #f + (lambda (db) + (sqlite3:for-each-row + (lambda (cpuload update-time) (set! res (cons cpuload update-time))) + db + "SELECT tr.cpuload, tr.update_time FROM test_rundat tr, tests t WHERE t.host=? AND tr.cpuload != -1 AND tr.test_id=t.id ORDER BY tr.update_time DESC LIMIT 1;" + hostname))) res )) + (define (db:set-top-level-from-items dbstruct run-id testname) (let* ((dbdat (db:get-db dbstruct run-id)) (db (db:dbdat-get-db dbdat)) (summ (db:get-state-status-summary db run-id testname)) @@ -3527,19 +3536,19 @@ (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")) (keyvals #f) (tests-hash (make-hash-table))) ;; first look up the key values from the run selected by run-id ;; (db:delay-if-busy dbdat) - (dbi:for-each-row + (sqlite3:for-each-row (lambda (a . b) (set! keyvals (cons a b))) db (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id) (if (not keyvals) '() (let ((prev-run-ids '())) - (apply dbi:for-each-row + (apply sqlite3:for-each-row (lambda (id) (set! prev-run-ids (cons id prev-run-ids))) db (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id))) ;; collect all matching tests for the runs then @@ -3614,11 +3623,11 @@ (db:with-db dbstruct run-id #f (lambda (db) - (dbi:for-each-row + (sqlite3:for-each-row (lambda (id itempath state status run_duration logf comment) (set! res (cons (vector id itempath state status run_duration logf comment) res))) db "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE testname=? AND item_path != '';" test-name) @@ -3634,11 +3643,11 @@ (db:with-db dbstruct #f #f (lambda (db) - (dbi:for-each-row + (sqlite3:for-each-row (lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup) (set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup))) db "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE testname=?;" testname) @@ -3646,27 +3655,27 @@ ;; create a new record for a given testname (define (db:testmeta-add-record dbstruct testname) (db:with-db dbstruct #f #f (lambda (db) - (dbi:exec + (sqlite3:execute db "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) (db:with-db dbstruct #f #f (lambda (db) - (dbi:exec + (sqlite3:execute db (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname)))) (define (db:testmeta-get-all dbstruct) (db:with-db dbstruct #f #f (lambda (db) (let ((res '())) - (dbi:for-each-row + (sqlite3:for-each-row (lambda (a . b) (set! res (cons (apply vector a b) res))) db "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta;") res)))) @@ -3857,11 +3866,11 @@ (debug:print 2 *default-log-port* "Using " tempdir " for constructing the ods file. keyqry: " keyqry " keystr: " keysstr " with keys: " (map cadr keypatt-alist) "\n mainqry: " mainqry) ;; "Expected Value" ;; "Value Found" ;; "Tolerance" - (apply dbi:for-each-row + (apply sqlite3:for-each-row (lambda (test-id . b) (set! test-ids (cons test-id test-ids)) ;; test-id is now testname (set! results (append results ;; note, drop the test-id (list (if pathmod @@ -3901,11 +3910,11 @@ ;; now, for each test, collect the test_data info and add a new sheet (for-each (lambda (test-id) (let ((test-data (list testdata-header)) (curr-test-name #f)) - (dbi:for-each-row + (sqlite3:for-each-row (lambda (run-id testname item-path category variable value expected tol units status comment) (set! curr-test-name testname) (set! test-data (append test-data (list (list run-id testname item-path category variable value expected tol units status comment))))) db ;; "SELECT run_id,testname,item_path,category,variable,td.value AS value,expected,tol,units,td.status AS status,td.comment AS comment FROM test_data AS td INNER JOIN tests ON tests.id=td.test_id WHERE test_id=?;" Index: docs/manual/megatest_manual.html ================================================================== --- docs/manual/megatest_manual.html +++ docs/manual/megatest_manual.html @@ -1,10 +1,10 @@ - + The Megatest Users Manual