Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -18,10 +18,13 @@ (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)) @@ -82,11 +85,12 @@ 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 sqlite3:first-result db stmt params))) + ;;(apply dbi:get-one db stmt params))) + (apply dbi:get-one 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 @@ -131,11 +135,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))) @@ -193,11 +197,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"))) - (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 0) ";")))) + (dbi:exec 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 ;; @@ -205,28 +209,31 @@ (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 ))) + dir-writable )) + (dbdat (cons (cons 'dbname fname) '()))) (if file-write ;; dir-writable (let (;; (lock (obtain-dot-lock fname 1 5 10)) - (db (sqlite3:open-database fname))) - (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) + (db (dbi:open 'sqlite3 dbdat))) + ;;(db (sqlite3:open-database fname))) + ;;(sqlite3:set-busy-handler! db (make-busy-timeout 136000)) ;; (db:set-sync db) - (sqlite3:execute db "PRAGMA synchronous = 0;") + (dbi:exec db "PRAGMA synchronous = 0;") (if (not file-exists) (begin (if (string-match "^/tmp/.*" fname) ;; this is a file in /tmp - (sqlite3:execute db "PRAGMA journal_mode=WAL;") + (dbi:exec 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) - (sqlite3:open-database fname))))) ;; ) + (dbi:open 'sqlite3 dbdat))))) + ;;(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")) @@ -238,17 +245,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) -;; (sqlite3:execute +;; (dbi:exec ;; db ;; "INSERT OR IGNORE INTO tests (id,run_id,testname,event_time,item_path,state,status) VALUES (?,?,'bogustest',strftime('%s','now'),'nowherepath','DELETED','n/a');" ;; (* run-id 30000) ;; allow for up to 30k tests per run ;; run-id) ;; ;; do a dummy query to test that the table exists and the db is truly readable -;; (sqlite3:execute db "SELECT * FROM tests WHERE id=?;" (* run-id 30000)) +;; (dbi:exec 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) @@ -345,13 +352,16 @@ (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 (sqlite3:finalize! tdb)) - (if mdb (sqlite3:finalize! mdb)) - (if rdb (sqlite3:finalize! rdb)))))) + (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)))))) ;; (let ((locdbs (dbr:dbstruct-locdbs dbstruct))) ;; (if (hash-table? locdbs) ;; (for-each (lambda (run-id) ;; (db:close-run-db dbstruct run-id)) @@ -469,11 +479,12 @@ ;; 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))) + (fname (pathname-strip-directory dbpath)) + (dbdat '())) (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) @@ -501,24 +512,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 (sqlite3:open-database dbpath))) + (let ((db (dbi:open 'sqlite3 (cons (cons ('dbname dbpath) '()))))) (cond ((equal? fname "megatest.db") - (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';")) + (dbi:exec db "DELETE FROM tests WHERE state='DELETED';")) ((equal? fname "main.db") - (sqlite3:execute db "DELETE FROM runs WHERE state='deleted';")) + (dbi:exec db "DELETE FROM runs WHERE state='deleted';")) ((string-match "\\d.db" fname) - (sqlite3:execute db "UPDATE tests SET state='DELETED' WHERE state='DELETED';")) + (dbi:exec db "UPDATE tests SET state='DELETED' WHERE state='DELETED';")) ((equal? fname "monitor.db") - (sqlite3:execute "DELETE FROM servers WHERE state LIKE 'defunct%';")) + (dbi:exec "DELETE FROM servers WHERE state LIKE 'defunct%';")) (else - (sqlite3:execute db "vacuum;"))) + (dbi:exec db "vacuum;"))) - (finalize! db) + (dbi:close db) #t)))))) ;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) ) ;; db's are dbdat's ;; @@ -548,13 +559,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 (sqlite3:database? (db:dbdat-get-db fromdb))) + ((not (eq? 'sqlite3 (dbi:db-dbtype fromdb))) (debug:print-error 0 *default-log-port* "db:sync-tables called with fromdb not a database " fromdb) -3) - ((not (sqlite3:database? (db:dbdat-get-db todb))) + ((not (eq? 'sqlite3 (dbi:db-dbtype 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)) @@ -595,11 +606,11 @@ (hash-table-set! field->num field count) (set! count (+ count 1))) fields) ;; read the source table - (sqlite3:for-each-row + (dbi: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)) @@ -614,11 +625,11 @@ (if (common:low-noise-print 120 "sync-records") (debug:print-info 4 *default-log-port* "found " totrecords " records to sync")) ;; read the target table - (sqlite3:for-each-row + (dbi:for-each-row (lambda (a . b) (hash-table-set! todat a (apply vector a b))) (db:dbdat-get-db todb) full-sel) @@ -628,11 +639,11 @@ (let* ((db (db:dbdat-get-db targdb)) (stmth (sqlite3:prepare db full-ins))) ;; (db:delay-if-busy targdb) ;; NO WAITING (for-each (lambda (fromdat-lst) - (sqlite3:with-transaction + (dbi:with-transaction db (lambda () (for-each ;; (lambda (fromrow) (let* ((a (vector-ref fromrow 0)) @@ -645,16 +656,16 @@ (if (and same (< i (- num-fields 1))) (loop (+ i 1)))) (if (not same) (begin - (apply sqlite3:execute stmth (vector->list fromrow)) + (apply dbi:exec stmth (vector->list fromrow)) (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0))))))) fromdat-lst)) )) fromdats) - (sqlite3:finalize! stmth))) + (dbi:close 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. @@ -678,17 +689,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")) - (sqlite3:execute + (dbi:exec frundb (conc "ALTER TABLE " table-name " ADD COLUMN last_update INTEGER DEFAULT 0"))) - (sqlite3:execute + (dbi:exec frundb (conc "DROP TRIGGER IF EXISTS update_" table-name "_trigger;")) - (sqlite3:execute + (dbi:exec 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')) @@ -704,30 +715,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")) - (sqlite3:execute + (dbi:exec maindb "ALTER TABLE runs ADD COLUMN last_update INTEGER DEFAULT 0")) ;; these schema changes don't need exception handling - (sqlite3:execute + (dbi:exec 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;") - (sqlite3:execute maindb "CREATE TABLE IF NOT EXISTS run_stats ( + (dbi:exec 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')))") - (sqlite3:execute maindb "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats + (dbi:exec 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;")) @@ -857,11 +868,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) -;; (sqlite3:finalize! (db:dbdat-get-db (dbr:dbstruct-rundb dbstruct))))) +;; (dbi:close (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 ;; @@ -941,11 +952,11 @@ ;; (debug:print 0 *default-log-port* "Removing database file for deleted run " fullname) ;; (delete-file fullname))))) ;; dead-runs)))) ;; ;; (db:close-all dbstruct) - ;; (sqlite3:finalize! mdb) + ;; (dbi:close 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) @@ -953,17 +964,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)) - ((sqlite3:database? idb) idb) + ((dbi: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)(sqlite3:finalize! dbstruct)) + (if (not idb)(dbi:close 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) @@ -1005,18 +1016,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) - (sqlite3:with-transaction + (dbi:with-transaction db (lambda () - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));") + (dbi:exec 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 OR REPLACE INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT")) + (dbi:exec db "INSERT OR REPLACE INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT")) keys) - (sqlite3:execute db (conc + (dbi:exec 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 '', @@ -1025,30 +1036,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 "));")) - (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs + (dbi:exec 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;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS run_stats ( + (dbi:exec 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')))") - (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats + (dbi:exec 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;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta ( + (dbi:exec db "CREATE TABLE IF NOT EXISTS test_meta ( id INTEGER PRIMARY KEY, testname TEXT DEFAULT '', author TEXT DEFAULT '', owner TEXT DEFAULT '', description TEXT DEFAULT '', @@ -1057,11 +1068,11 @@ avg_runtime REAL, avg_disk REAL, tags TEXT DEFAULT '', jobgroup TEXT DEFAULT 'default', CONSTRAINT test_meta_constraint UNIQUE (testname));") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY, + (dbi:exec 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 '', @@ -1069,56 +1080,56 @@ keylock TEXT, params TEXT, creation_time TIMESTAMP DEFAULT (strftime('%s','now')), execution_time TIMESTAMP);") ;; archive disk areas, cached info from [archive-disks] - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_disks ( + (dbi:exec 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 - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_blocks ( + (dbi:exec 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. - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_allocations ( + (dbi:exec 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 - (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, + (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, 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);") + (dbi:exec 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 - (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" (common:version-signature)) + (dbi:exec 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) - (sqlite3:with-transaction + (dbi:with-transaction db (lambda () - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tests + (dbi:exec 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, @@ -1138,18 +1149,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));") - (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 + (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 FOR EACH ROW BEGIN UPDATE tests SET last_update=(strftime('%s','now')) WHERE id=old.id; END;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps + (dbi:exec 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', @@ -1156,18 +1167,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));") - (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 + (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 FOR EACH ROW BEGIN UPDATE test_steps SET last_update=(strftime('%s','now')) WHERE id=old.id; END;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, + (dbi:exec db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, test_id INTEGER, category TEXT DEFAULT '', variable TEXT, value REAL, expected REAL, @@ -1176,26 +1187,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));") - (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 + (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 FOR EACH ROW BEGIN UPDATE test_data SET last_update=(strftime('%s','now')) WHERE id=old.id; END;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat ( + (dbi:exec 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);") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archives ( + (dbi:exec 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', @@ -1214,11 +1225,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 - (sqlite3:for-each-row + (dbi: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 @@ -1225,11 +1236,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) '() - (sqlite3:for-each-row + (dbi: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 @@ -1244,24 +1255,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)) - (sqlite3:for-each-row + (dbi: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 - (sqlite3:execute db "UPDATE archive_disks SET last_df=?,last_df_time=(strftime('%s','now')) + (dbi:exec 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 - (sqlite3:execute + (dbi:exec 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))))) @@ -1273,24 +1284,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 - (sqlite3:for-each-row + (dbi: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 (sqlite3:exectute db "UPDATE archive_blocks SET last_du=?,last_du_time=(strftime('%s','now')) + (if du (dbi:exec 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 - (sqlite3:execute db "INSERT OR REPLACE INTO archive_blocks (archive_disk_id,disk_path,last_du) + (dbi:exec 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))))) @@ -1300,11 +1311,11 @@ (db:with-db dbstruct run-id #f (lambda (db) - (sqlite3:execute db "UPDATE tests SET archived=? WHERE id=?;" + (dbi:exec 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) @@ -1312,11 +1323,11 @@ dbstruct #f #f (lambda (db) (let ((res #f)) - (sqlite3:for-each-row + (dbi: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=?;" @@ -1326,43 +1337,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 -;; (sqlite3:for-each-row #f) +;; (dbi: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 (sqlite3:open-database dbpath)) + (db (dbi:open 'sqlite3 (cons (cons ('dbname 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 - (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;")) + (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;")) )) 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 (?,?,?,?);" + (dbi:exec db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);" logline (current-directory) (string-intersperse (argv) " ") (current-process-id)) - (sqlite3:finalize! db) + (dbi:close db) logline)) ;;====================================================================== ;; D B U T I L S ;;====================================================================== @@ -1389,11 +1400,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) - (sqlite3:for-each-row + (dbi: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 @@ -1405,11 +1416,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) - (sqlite3:for-each-row + (dbi: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)) @@ -1453,11 +1464,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) - (sqlite3:for-each-row + (dbi: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 @@ -1469,11 +1480,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) - (sqlite3:for-each-row + (dbi: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)) @@ -1497,11 +1508,11 @@ (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") - (sqlite3:execute + (dbi:exec db (conc "UPDATE tests SET state='INCOMPLETE' WHERE run_id=? AND id IN (" (string-intersperse (map conc all-ids) ",") ");") run-id)))) @@ -1534,14 +1545,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-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);")) + (count (dbi:get-one db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);")) (statements (map (lambda (stmt) - (sqlite3:prepare db stmt)) + (dbi:exec 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';" @@ -1551,25 +1562,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) - (sqlite3:with-transaction + (dbi:with-transaction db (lambda () - (sqlite3:for-each-row (lambda (tot) + (dbi:for-each-row (lambda (tot) (debug:print-info 0 *default-log-port* "Records count before clean: " tot)) count-stmt) - (map sqlite3:execute statements) - (sqlite3:for-each-row (lambda (tot) + (map dbi:exec statements) + (dbi:for-each-row (lambda (tot) (debug:print-info 0 *default-log-port* "Records count after clean: " tot)) count-stmt))) - (map sqlite3:finalize! statements) - (sqlite3:finalize! count-stmt) + (map dbi:close statements) + (dbi:close count-stmt) ;; (db:find-and-mark-incomplete db) ;; (db:delay-if-busy dbdat) - (sqlite3:execute db "VACUUM;"))) + (dbi:exec db "VACUUM;"))) ;; Clean out old junk and vacuum the database ;; ;; Ultimately do something like this: ;; @@ -1592,25 +1603,25 @@ ;; (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) - (sqlite3:with-transaction + (dbi:with-transaction db (lambda () - (sqlite3:for-each-row (lambda (tot) + (dbi:for-each-row (lambda (tot) (debug:print-info 0 *default-log-port* "Records count before clean: " tot)) count-stmt) - (map sqlite3:execute statements) - (sqlite3:for-each-row (lambda (tot) + (map dbi:exec statements) + (dbi:for-each-row (lambda (tot) (debug:print-info 0 *default-log-port* "Records count after clean: " tot)) count-stmt))) - (map sqlite3:finalize! statements) - (sqlite3:finalize! count-stmt) + (map dbi:close statements) + (dbi:close count-stmt) ;; (db:find-and-mark-incomplete db) ;; (db:delay-if-busy dbdat) - (sqlite3:execute db "VACUUM;"))) + (dbi:exec db "VACUUM;"))) ;; Clean out old junk and vacuum the database ;; ;; Ultimately do something like this: ;; @@ -1633,31 +1644,31 @@ ;; (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 '())) - (sqlite3:for-each-row + (dbi: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) - (sqlite3:with-transaction + (dbi:with-transaction db (lambda () - (sqlite3:for-each-row (lambda (tot) + (dbi:for-each-row (lambda (tot) (debug:print-info 0 *default-log-port* "Records count before clean: " tot)) count-stmt) - (map sqlite3:execute statements) - (sqlite3:for-each-row (lambda (tot) + (map dbi:exec statements) + (dbi:for-each-row (lambda (tot) (debug:print-info 0 *default-log-port* "Records count after clean: " tot)) count-stmt))) - (map sqlite3:finalize! statements) - (sqlite3:finalize! count-stmt) + (map dbi:close statements) + (dbi:close count-stmt) ;; (db:find-and-mark-incomplete db) ;; (db:delay-if-busy dbdat) - (sqlite3:execute db "VACUUM;") + (dbi:exec db "VACUUM;") dead-runs)) ;;====================================================================== ;; M E T A G E T A N D S E T V A R S ;;====================================================================== @@ -1667,11 +1678,11 @@ ;; (define (db:get-var dbstruct var) (let* ((res #f) (dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (val) (set! res val)) db "SELECT val FROM metadat WHERE var=?;" var) ;; convert to number if can @@ -1693,17 +1704,17 @@ ;; (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))) - (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val))) + (dbi:exec 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) - (sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var)))) + (dbi:exec 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 @@ -1713,11 +1724,11 @@ (define (db:get-keys dbstruct) (if *db-keys* *db-keys* (let ((res '())) (db:with-db dbstruct #f #f (lambda (db) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (key) (set! res (cons key res))) db "SELECT fieldname FROM keys ORDER BY id DESC;"))) (set! *db-keys* res) @@ -1748,11 +1759,11 @@ dbstruct #f ;; this is for the main runs db #f ;; does not modify db (lambda (db) (let ((res #f)) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (runname) (set! res runname)) db "SELECT runname FROM runs WHERE id=?;" run-id) @@ -1763,11 +1774,11 @@ dbstruct #f #f (lambda (db) (let ((res #f)) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (val) (set! res val)) db (conc "SELECT " key " FROM runs WHERE id=?;") run-id) @@ -1811,23 +1822,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 sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");") + (apply dbi:exec 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 sqlite3:for-each-row + (apply dbi: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) - (sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res) + (dbi:exec 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)))) @@ -1863,11 +1874,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) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (a . x) (set! res (cons (apply vector a x) res))) db qrystr ))) @@ -1904,11 +1915,11 @@ (db:with-db dbstruct #f #f (lambda (db) - (sqlite3:for-each-row + (dbi: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) @@ -1925,11 +1936,11 @@ #f #f (lambda (db) (let ((numruns 0)) (debug:print-info 11 *default-log-port* "db:get-num-runs START " runpatt) - (sqlite3:for-each-row + (dbi: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) @@ -1962,20 +1973,20 @@ (lambda (db) ;; remove previous data (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 - (sqlite3:with-transaction + (dbi:with-transaction db (lambda () (for-each (lambda (dat) - (sqlite3:execute stmt1 run-id (car dat)(cadr dat)) - (apply sqlite3:execute stmt2 run-id dat)) + (dbi:exec stmt1 run-id (car dat)(cadr dat)) + (apply dbi:exec stmt2 run-id dat)) stats))))) - (sqlite3:finalize! stmt1) - (sqlite3:finalize! stmt2) + (dbi:close stmt1) + (dbi:close stmt2) res)))) (define (db:get-main-run-stats dbstruct run-id) (db:with-db dbstruct @@ -1995,11 +2006,11 @@ dbstruct #f #f (lambda (db) (let ((run-ids '())) - (sqlite3:for-each-row + (dbi: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))))) @@ -2015,11 +2026,11 @@ (curr (make-hash-table)) (res '()) (runs-info '())) ;; First get all the runname/run-ids ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row + (dbi: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 @@ -2031,11 +2042,11 @@ (db:with-db dbstruct run-id #f (lambda (db) - (sqlite3:for-each-row + (dbi: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)) @@ -2112,11 +2123,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) - (sqlite3:for-each-row + (dbi: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) @@ -2129,11 +2140,11 @@ (db:with-db dbstruct #f #f (lambda (db) - (sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment ;; (sdb:qry 'getid comment) + (dbi:exec 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 @@ -2140,26 +2151,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) - (sqlite3:with-transaction + (dbi:with-transaction db (lambda () - (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) + (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) ;; (db:delay-if-busy dbdat) - (sqlite3:execute db "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id))))) + (dbi:exec 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) - (sqlite3:execute db "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id)))) + (dbi:exec 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 @@ -2167,31 +2178,31 @@ (lambda (db) (let ((newlockval (if lock "locked" (if unlock "unlocked" "locked")))) ;; semi-failsafe - (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'),?);" + (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'),?);" 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 - (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)))) + (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)))) (define (db:get-run-status dbstruct run-id) (let ((res "n/a")) (db:with-db dbstruct #f #f (lambda (db) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (status) (set! res status)) db "SELECT status FROM runs WHERE id=?;" run-id) @@ -2210,11 +2221,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) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (key-val) (set! res (cons (list key key-val) res))) db qry run-id))) keys) (reverse res))) @@ -2227,11 +2238,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) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (key-val) (set! res (cons key-val res))) db qry run-id))) keys) (let ((final-res (reverse res))) @@ -2252,11 +2263,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 sqlite3:for-each-row + (apply dbi: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))) @@ -2349,11 +2360,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) - (sqlite3:for-each-row + (dbi: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 @@ -2381,11 +2392,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) - (sqlite3:for-each-row + (dbi: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 @@ -2394,11 +2405,11 @@ (define (db:get-testinfo-state-status dbstruct run-id test-id) (let ((res #f)) (db:with-db dbstruct run-id #f (lambda (db) - (sqlite3:for-each-row + (dbi: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=?;" @@ -2433,11 +2444,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)) - (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id))) + (dbi:exec 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 @@ -2444,16 +2455,16 @@ (db:with-db dbstruct 0 #t (lambda (db) - (sqlite3:with-transaction + (dbi:with-transaction db (lambda () - (sqlite3:execute db "DELETE FROM test_steps WHERE test_id IN (SELECT id FROM tests WHERE state='DELETED' AND event_timelist rec)) ",") "\n") - (apply sqlite3:execute qry (vector->list rec))) + (apply dbi:exec qry (vector->list rec))) testrecs))) - (sqlite3:finalize! qry))))) + (dbi:close 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)) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (id) (set! test-id-found id)) (db:dbdat-get-db mtdb) "SELECT id FROM tests WHERE id=?;" new-id) @@ -2713,11 +2724,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) - (sqlite3:execute mtdb "UPDATE tests SET id=? WHERE id=?;" new-id test-id))))))) + (dbi:exec 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) @@ -2745,11 +2756,11 @@ dbstruct run-id #f (lambda (db) (let ((res #f)) - (sqlite3:for-each-row ;; attemptnum added to hold pid of top process (not Megatest) controlling a test + (dbi: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=?;") @@ -2764,11 +2775,11 @@ dbstruct run-id #f (lambda (db) (let ((res '())) - (sqlite3:for-each-row + (dbi: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 (" @@ -2780,11 +2791,11 @@ dbstruct run-id #f (lambda (db) (let ((res #f)) - (sqlite3:for-each-row + (dbi: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) @@ -2810,11 +2821,11 @@ (db:with-db dbstruct run-id #t (lambda (db) - (sqlite3:execute + (dbi:exec 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 ""))))) @@ -2825,11 +2836,11 @@ dbstruct run-id #f (lambda (db) (let* ((res '())) - (sqlite3:for-each-row + (dbi: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) @@ -2840,11 +2851,11 @@ dbstruct run-id #f (lambda (db) (let ((res '())) - (sqlite3:for-each-row + (dbi: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) @@ -2863,11 +2874,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) - (sqlite3:for-each-row + (dbi: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, @@ -3013,11 +3024,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) - (sqlite3:execute db "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);" + (dbi:exec 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 ;; @@ -3024,11 +3035,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) - (sqlite3:for-each-row + (dbi: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))) @@ -3048,15 +3059,15 @@ (string-split target "/")) " AND ")) ;; (testqry (tests:match->sqlqry testpatt)) (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) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (rid) (set! row-ids (cons rid row-ids))) runsqry) - (sqlite3:finalize! runsqry) + (dbi:close 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) @@ -3065,11 +3076,11 @@ (db:with-db dbstruct run-id #f (lambda (db) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (p) (set! res (cons p res))) db tstsqry run-id) @@ -3080,11 +3091,11 @@ dbstruct run-id #f (lambda (db) (let ((res 0)) - (sqlite3:for-each-row + (dbi: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 @@ -3159,11 +3170,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))) - (sqlite3:with-transaction + (dbi: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 @@ -3264,11 +3275,11 @@ dbstruct run-id #f (lambda (db) (let ((res #f)) - (sqlite3:for-each-row + (dbi: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)) @@ -3453,20 +3464,20 @@ (string->symbol stmtname) stmtname) db:queries))) (if q (car q) #f)))) ;; (db:delay-if-busy dbdat) - (apply sqlite3:execute (db:dbdat-get-db dbdat) query params) + (apply dbi:exec (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 '())) - (sqlite3:for-each-row + (dbi: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) @@ -3511,19 +3522,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) - (sqlite3:for-each-row + (dbi: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 sqlite3:for-each-row + (apply dbi: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 @@ -3598,11 +3609,11 @@ (db:with-db dbstruct run-id #f (lambda (db) - (sqlite3:for-each-row + (dbi: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) @@ -3618,11 +3629,11 @@ (db:with-db dbstruct #f #f (lambda (db) - (sqlite3:for-each-row + (dbi: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) @@ -3630,27 +3641,27 @@ ;; create a new record for a given testname (define (db:testmeta-add-record dbstruct testname) (db:with-db dbstruct #f #f (lambda (db) - (sqlite3:execute + (dbi:exec 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) - (sqlite3:execute + (dbi:exec 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 '())) - (sqlite3:for-each-row + (dbi: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)))) @@ -3841,11 +3852,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 sqlite3:for-each-row + (apply dbi: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 @@ -3885,11 +3896,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)) - (sqlite3:for-each-row + (dbi: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: portlogger.scm ================================================================== --- portlogger.scm +++ portlogger.scm @@ -10,25 +10,27 @@ (require-extension (srfi 18) extras tcp s11n) (use sqlite3 srfi-1 posix srfi-69 hostinfo dot-locking z3) (import (prefix sqlite3 sqlite3:)) +(import (prefix dbi dbi:)) (declare (unit portlogger)) (declare (uses db)) + ;; lsof -i (define (portlogger:open-db fname) (let* ((avail (tasks:wait-on-journal fname 5 remove: #t)) ;; wait up to about 10 seconds for the journal to go away (exists (file-exists? fname)) (db (if avail - (sqlite3:open-database fname) + (dbi:open 'sqlite3 '((dbname . fname))) (begin (system (conc "rm -f " fname)) - (sqlite3:open-database fname)))) + (dbi:open 'sqlite3 '((dbname . fname)))))) (handler (make-busy-timeout 136000)) (canwrite (file-write-access? fname))) ;; (db-init (lambda () ;; (sqlite3:execute ;; db @@ -35,14 +37,14 @@ ;; "CREATE TABLE IF NOT EXISTS ports ( ;; port INTEGER PRIMARY KEY, ;; state TEXT DEFAULT 'not-used', ;; fail_count INTEGER DEFAULT 0, ;; update_time TIMESTAMP DEFAULT (strftime('%s','now')) );")))) - (sqlite3:set-busy-handler! db handler) + ;;(sqlite3:set-busy-handler! db handler) (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") ;; (if (not exists) ;; needed with IF NOT EXISTS? - (sqlite3:execute + (dbi:exec db "CREATE TABLE IF NOT EXISTS ports ( port INTEGER PRIMARY KEY, state TEXT DEFAULT 'not-used', fail_count INTEGER DEFAULT 0, Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -9,10 +9,11 @@ ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format) (import (prefix sqlite3 sqlite3:)) +(import (prefix dbi dbi:)) (declare (unit tasks)) (declare (uses db)) (declare (uses rmt)) (declare (uses common)) @@ -94,20 +95,23 @@ (let* ((dbpath (tasks:get-task-db-path)) (dbfile (conc dbpath "/monitor.db")) (avail (tasks:wait-on-journal dbpath 10)) ;; wait up to about 10 seconds for the journal to go away (exists (file-exists? dbpath)) (write-access (file-write-access? dbpath)) + (dbdat '()) (mdb (cond ;; what the hek is *toppath* doing here? ((and (string? *toppath*)(file-write-access? *toppath*)) - (sqlite3:open-database dbfile)) - ((file-read-access? dbpath) (sqlite3:open-database dbfile)) - (else (sqlite3:open-database ":memory:")))) ;; (never-give-up-open-db dbpath)) + (set! dbdat (cons (cons 'dbname dbfile) dbdat)) + (dbi:open 'sqlite3 dbdat)) + ((file-read-access? dbpath) (dbi:open 'sqlite3 dbdat)) + (else (dbi:open 'sqlite3 '((dbname . ":memory:")))))) ;; (never-give-up-open-db dbpath)) (handler (make-busy-timeout 36000))) + (if (and exists (not write-access)) (set! *db-write-access* write-access)) ;; only unset so other db's also can use this control - (sqlite3:set-busy-handler! mdb handler) + ;;(sqlite3:set-busy-handler! mdb handler) (db:set-sync mdb) ;; (sqlite3:execute mdb (conc "PRAGMA synchronous = 0;")) ;; (if (or (and (not exists) ;; (file-write-access? *toppath*)) ;; (not (file-read-access? dbpath))) ;; (begin @@ -123,18 +127,18 @@ ;; testpatt TEXT DEFAULT '', ;; keylock TEXT, ;; params TEXT, ;; creation_time TIMESTAMP, ;; execution_time TIMESTAMP);") - (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS monitors (id INTEGER PRIMARY KEY, + (dbi:exec mdb "CREATE TABLE IF NOT EXISTS monitors (id INTEGER PRIMARY KEY, pid INTEGER, start_time TIMESTAMP, last_update TIMESTAMP, hostname TEXT, username TEXT, CONSTRAINT monitors_constraint UNIQUE (pid,hostname));") - (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS servers (id INTEGER PRIMARY KEY, + (dbi:exec mdb "CREATE TABLE IF NOT EXISTS servers (id INTEGER PRIMARY KEY, pid INTEGER, interface TEXT, hostname TEXT, port INTEGER, pubport INTEGER, @@ -144,11 +148,11 @@ mt_version TEXT, heartbeat TIMESTAMP, transport TEXT, run_id INTEGER);") ;; CONSTRAINT servers_constraint UNIQUE (pid,hostname,port));") - (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS clients (id INTEGER PRIMARY KEY, + (dbi:exec mdb "CREATE TABLE IF NOT EXISTS clients (id INTEGER PRIMARY KEY, server_id INTEGER, pid INTEGER, hostname TEXT, cmdline TEXT, login_time TIMESTAMP, Index: tdb.scm ================================================================== --- tdb.scm +++ tdb.scm @@ -15,10 +15,11 @@ (require-extension (srfi 18) extras tcp) (use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) +(import (prefix dbi dbi:)) (declare (unit tdb)) (declare (uses common)) (declare (uses keys)) (declare (uses ods)) @@ -52,22 +53,24 @@ (directory? work-area) (file-read-access? work-area)) (let* ((dbpath (conc work-area "/testdat.db")) (dbexists (file-exists? dbpath)) (work-area-writeable (file-write-access? work-area)) + (dbdat '()) (db (handle-exceptions ;; open the db if area writeable or db pre-existing. open in-mem otherwise. if exception, open in-mem exn (begin (print-call-chain (current-error-port)) (debug:print 2 *default-log-port* "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test" ((condition-property-accessor 'exn 'message) exn)) (set! dbexists #f) ;; must force re-creation of tables, more tom-foolery - (sqlite3:open-database ":memory:")) ;; open an in-memory db to allow readonly access + (set! dbdat (cons (cons 'dbname ":memory:") dbdat)) + (dbi:open 'sqlite3 dbdat)) ;; open an in-memory db to allow readonly access (if (or work-area-writeable dbexists) - (sqlite3:open-database dbpath) - (sqlite3:open-database ":memory:")))) + (set! dbdat (cons (cons 'dbname dbpath) dbdat)) + (set! dbdat (cons (cons 'dbname ":memory:") dbdat))))) (tdb-writeable (and (file-write-access? work-area) (file-write-access? dbpath))) (handler (make-busy-timeout (if (args:get-arg "-override-timeout") (string->number (args:get-arg "-override-timeout")) 136000))))