;======================================================================
;; Copyright 2006-2016, Matthew Welland.
;;
;; This file is part of Megatest.
;;
;; Megatest is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; Megatest is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;
;;======================================================================
;;======================================================================
;; Database access
;;======================================================================
;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc
(declare (unit db))
(module db
(
db:setup
)
(import scheme posix chicken data-structures ports)
(use (prefix sqlite3 sqlite3:)
(srfi 18) extras tcp stack srfi-1 posix regex regex-case srfi-69
csv-xml s11n md5 message-digest base64 format dot-locking z3
typed-records matchable
(prefix base64 base64:))
;;======================================================================
;;
;;======================================================================
(defstruct dbinfo
(mtrah #f)
(dbpath #f)
(maindb #f)
(dbfile #f)
(writeable #f)
(rundbs (make-hash-table)) ;; id => #(dbhandle readq writeq)
(stats (make-hash-table))
(mreadq (make-queue)) ;; read queue for main.db
(mwriteq (make-queue)) ;; write queue for main.db
(localq (make-queue)) ;; queue for cpuload, numcores and other OS requests
(respq (make-queue)) ;; queue for responses
)
(defstruct rundbinfo
(rundb #f) ;; db handle
(dbfile #f)
(readq (make-queue))
(writeq (make-queue))
(sdbcache (make-hash-table)) ;; cache the id => strings as we read them
(stats (make-hash-table))
)
(defstruct request
(srchost #f)
(srcport #f)
(reqtype #f) ;; read, write, local
(response #f)
(status 'new)
(start (current-milliseconds)))
;; create a dbinfo record initialized to a specific Megatest area
;;
(define (db:create-dbinfo mtrah)
(make-dbinfo mtrah: mtrah dbpath: (conc mtrah "/.mtdb")))
(define (db:get-open-db dbinfo run-id #!key (dbpath #f))
(let* ((dbpath (dbinfo-dbpath dbinfo))
(ismain (if (number? run-id) #f #t))
(dbname (if run-id (conc run-id ".db") "main.db")) ;; can use string for run-id
(dbfile (conc dbpath "/" dbname))
(dbexists (file-exists? dbfile))
(readable (file-read-access? dbpath)) ;; should be safe to assume can read db file
(writeable (file-write-access? dbpath)))
;; handle error conditions
(cond
((and (not dbexists) (not writeable))(values #f "No db file and no write access"))
((not readable) (values #f "No read access"))
(else
;; TODO - transfer over the error handling from MT1.65 db:lock-create-open
(let ((db (sqlite3:open-database dbfile)))
(if (not dbexists)(db:initialize-db db))
;; now deal with the added structure for run-id based db if needed
(if ismain
(begin
(dbinfo-maindb-set! dbinfo db)
(dbinfo-writeable-set! dbinfo writeable))
(let ((runrec (or (hash-table-ref/default (dbinfo-rundbs dbinfo) run-id (make-rundbinfo rundb: db dbfile: dbfile)))))
(hash-table-set! (dbinfo-rundbs dbinfo) run-id runrec)))
(values #t "Success"))))))
;; dbinfo must have been initiatized with the dbpath
;;
#;(define (db:with-db dbinfo run-id proc . params)
(let* ((db (db:get-open-db dbinfo run-id))
(use-mutex (> *api-process-request-count* 25)))
(if (and use-mutex
(common:low-noise-print 120 "over-50-parallel-api-requests"))
(debug:print-info 0 *default-log-port* *api-process-request-count* " parallel api requests being processed in process " (current-process-id) ", throttling access"))
(if (common:low-noise-print 600 (conc "parallel-api-requests" *max-api-process-requests*))
(debug:print-info 2 *default-log-port* "Parallel api request count: " *api-process-request-count* " max parallel requests: " *max-api-process-requests*))
(handle-exceptions
exn
(begin
(print-call-chain (current-error-port))
(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))
;; there is no recovering at this time. exit
(exit 50))
(if use-mutex (mutex-lock! *db-with-db-mutex*))
(let ((res (apply proc db params)))
(if use-mutex (mutex-unlock! *db-with-db-mutex*))
;; (if (vector? dbstruct)(db:done-with dbstruct run-id r/w))
(if dbdat (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat))
res))))
(define (db:initialize-db db)
(sqlite3:with-transaction
db
(lambda ()
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS ttype (
id SERIAL PRIMARY KEY,
target_spec TEXT DEFAULT '');")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS runs (
id INTEGER PRIMARY KEY,
target TEXT DEFAULT 'nodata',
ttype_id INTEGER DEFAULT 0,
run_name TEXT DEFAULT 'norun',
contour TEXT DEFAULT '',
state TEXT DEFAULT '',
status TEXT DEFAULT '',
owner TEXT DEFAULT '',
event_time TIMESTAMP DEFAULT (strftime('%s','now')),
comment TEXT DEFAULT '',
fail_count INTEGER DEFAULT 0,
pass_count INTEGER DEFAULT 0,
last_update INTEGER DEFAULT (strftime('%s','now')),
CONSTRAINT runsconstraint UNIQUE (target,ttype_id,run_name, area_id));")
(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;")
(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')))")
(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;")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta (
id INTEGER PRIMARY KEY,
testname TEXT DEFAULT '',
author TEXT DEFAULT '',
owner TEXT DEFAULT '',
description TEXT DEFAULT '',
reviewed TIMESTAMP,
iterated TEXT DEFAULT '',
avg_runtime REAL,
avg_disk REAL,
tags TEXT DEFAULT '',
jobgroup TEXT DEFAULT 'default',
CONSTRAINT test_meta_constraint UNIQUE (testname));")
(sqlite3:execute db "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 '',
testpatt TEXT DEFAULT '',
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 (
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 (
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 (
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,
CONSTRAINT metadat_constraint UNIQUE (var));")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);")
;; Must do this *after* running patch db !! No more.
;; cannot use db:set-var since it will deadlock, hardwire the code here
;; ERROR: Cannot do this here - must update from Megatest itself, not from mtserver
;; (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" (common:version-signature))
;;======================================================================
;; R U N S P E C I F I C D B
;;======================================================================
(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,
diskfree INTEGER DEFAULT -1,
uname TEXT DEFAULT 'n/a',
rundir TEXT DEFAULT '/tmp/badname',
shortdir TEXT DEFAULT '/tmp/badname',
item_path TEXT DEFAULT '',
state TEXT DEFAULT 'NOT_STARTED',
status TEXT DEFAULT 'FAIL',
attemptnum INTEGER DEFAULT 0,
final_logf TEXT DEFAULT 'logs/final.log',
logdat TEXT DEFAULT '',
run_duration INTEGER DEFAULT 0,
comment TEXT DEFAULT '',
event_time TIMESTAMP DEFAULT (strftime('%s','now')),
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));")
;; deprecated -- (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path, uname);")
(sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_run_id_index ON tests (run_id);") ;; new
(sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_testname_index ON tests (testname,item_path);") ;; new
(sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_state_status_index ON tests (state, status); ") ;; new
(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;")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps
(id INTEGER PRIMARY KEY,
test_id INTEGER,
stepname TEXT,
state TEXT DEFAULT 'NOT_STARTED',
status TEXT DEFAULT 'n/a',
event_time TIMESTAMP,
comment TEXT DEFAULT '',
logfile TEXT DEFAULT '',
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
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,
test_id INTEGER,
category TEXT DEFAULT '',
variable TEXT,
value REAL,
expected REAL,
tol REAL,
units TEXT,
comment TEXT DEFAULT '',
status TEXT DEFAULT 'n/a',
type TEXT DEFAULT '',
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
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 (
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 (
id INTEGER PRIMARY KEY,
test_id INTEGER,
state TEXT DEFAULT 'new',
status TEXT DEFAULT 'n/a',
archive_type TEXT DEFAULT 'bup',
du INTEGER,
archive_path TEXT);")))
db)
(define (db:general-sqlite-error-dump . args)
#t
(print "Got here: db:general-sqlite-error-dump"))
(define (db:first-result-default . args)
#t
(print "Got here: db:first-result-default"))
(define (db:get-db . args)
#t
(print "Got here: db:get-db"))
(define (db:dbdat-get-db . args)
#t
(print "Got here: db:dbdat-get-db"))
(define (db:dbdat-get-path . args)
#t
(print "Got here: db:dbdat-get-path"))
(define (db:with-db . args)
#t
(print "Got here: db:with-db"))
(define (db:set-sync . args)
#t
(print "Got here: db:set-sync"))
(define (db:lock-create-open . args)
#t
(print "Got here: db:lock-create-open"))
(define (db:open-db . args)
#t
(print "Got here: db:open-db"))
(define (db:get-last-update-time . args)
#t
(print "Got here: db:get-last-update-time"))
(define (db:setup . args)
#t
(print "Got here: db:setup"))
(define (db:open-megatest-db . args)
#t
(print "Got here: db:open-megatest-db"))
(define (db:sync-touched . args)
#t
(print "Got here: db:sync-touched"))
(define (db:safely-close-sqlite3-db . args)
#t
(print "Got here: db:safely-close-sqlite3-db"))
(define (db:close-all . args)
#t
(print "Got here: db:close-all"))
(define (db:sync-main-list . args)
#t
(print "Got here: db:sync-main-list"))
(define (db:sync-all-tables-list . args)
#t
(print "Got here: db:sync-all-tables-list"))
(define (db:move-and-recreate-db . args)
#t
(print "Got here: db:move-and-recreate-db"))
(define (db:repair-db . args)
#t
(print "Got here: db:repair-db"))
(define (db:sync-tables . args)
#t
(print "Got here: db:sync-tables"))
(define (db:patch-schema-rundb . args)
#t
(print "Got here: db:patch-schema-rundb"))
(define (db:patch-schema-maindb . args)
#t
(print "Got here: db:patch-schema-maindb"))
(define (db:adj-target . args)
#t
(print "Got here: db:adj-target"))
(define (db:get-access-mode . args)
#t
(print "Got here: db:get-access-mode"))
(define (db:dispatch-query . args)
#t
(print "Got here: db:dispatch-query"))
(define (db:cache-for-read-only . args)
#t
(print "Got here: db:cache-for-read-only"))
(define (db:multi-db-sync . args)
#t
(print "Got here: db:multi-db-sync"))
(define (db:tmp->megatest.db-sync . args)
#t
(print "Got here: db:tmp->megatest.db-sync"))
(define (db:sync-to-megatest.db . args)
#t
(print "Got here: db:sync-to-megatest.db"))
(define (open-run-close-no-exception-handling . args)
#t
(print "Got here: open-run-close-no-exception-handling"))
(define (open-run-close-exception-handling . args)
#t
(print "Got here: open-run-close-exception-handling"))
(define (db:initialize-main-db . args)
#t
(print "Got here: db:initialize-main-db"))
(define (db:archive-get-allocations . args)
#t
(print "Got here: db:archive-get-allocations"))
(define (db:archive-register-disk . args)
#t
(print "Got here: db:archive-register-disk"))
(define (db:archive-register-block-name . args)
#t
(print "Got here: db:archive-register-block-name"))
(define (db:test-set-archive-block-id . args)
#t
(print "Got here: db:test-set-archive-block-id"))
(define (db:test-get-archive-block-info . args)
#t
(print "Got here: db:test-get-archive-block-info"))
(define (open-logging-db . args)
#t
(print "Got here: open-logging-db"))
(define (db:log-local-event . args)
#t
(print "Got here: db:log-local-event"))
(define (db:log-event . args)
#t
(print "Got here: db:log-event"))
(define (db:have-incompletes? . args)
#t
(print "Got here: db:have-incompletes?"))
(define (db:find-and-mark-incomplete . args)
#t
(print "Got here: db:find-and-mark-incomplete"))
(define (db:top-test-set-per-pf-counts . args)
#t
(print "Got here: db:top-test-set-per-pf-counts"))
(define (db:clean-up . args)
#t
(print "Got here: db:clean-up"))
(define (db:clean-up-rundb . args)
#t
(print "Got here: db:clean-up-rundb"))
(define (db:clean-up-maindb . args)
#t
(print "Got here: db:clean-up-maindb"))
(define (db:get-var . args)
#t
(print "Got here: db:get-var"))
(define (db:set-var . args)
#t
(print "Got here: db:set-var"))
(define (db:del-var . args)
#t
(print "Got here: db:del-var"))
(define (db:open-no-sync-db . args)
#t
(print "Got here: db:open-no-sync-db"))
(define (db:no-sync-db . args)
#t
(print "Got here: db:no-sync-db"))
(define (db:no-sync-set . args)
#t
(print "Got here: db:no-sync-set"))
(define (db:no-sync-del! . args)
#t
(print "Got here: db:no-sync-del!"))
(define (db:no-sync-get/default . args)
#t
(print "Got here: db:no-sync-get/default"))
(define (db:no-sync-close-db . args)
#t
(print "Got here: db:no-sync-close-db"))
(define (db:no-sync-get-lock . args)
#t
(print "Got here: db:no-sync-get-lock"))
(define (db:get-keys . args)
#t
(print "Got here: db:get-keys"))
(define (db:get-value-by-header . args)
#t
(print "Got here: db:get-value-by-header"))
(define (db:get-header . args)
#t
(print "Got here: db:get-header"))
(define (db:get-rows . args)
#t
(print "Got here: db:get-rows"))
(define (db:get-run-times . args)
#t
(print "Got here: db:get-run-times"))
(define (db:get-run-name-from-id . args)
#t
(print "Got here: db:get-run-name-from-id"))
(define (db:get-run-key-val . args)
#t
(print "Got here: db:get-run-key-val"))
(define (runs:get-std-run-fields . args)
#t
(print "Got here: runs:get-std-run-fields"))
(define (db:patt->like . args)
#t
(print "Got here: db:patt->like"))
(define (db:register-run . args)
#t
(print "Got here: db:register-run"))
(define (db:get-runs . args)
#t
(print "Got here: db:get-runs"))
(define (db:simple-get-runs . args)
#t
(print "Got here: db:simple-get-runs"))
(define (db:get-changed-run-ids . args)
#t
(print "Got here: db:get-changed-run-ids"))
(define (db:get-targets . args)
#t
(print "Got here: db:get-targets"))
(define (db:get-num-runs . args)
#t
(print "Got here: db:get-num-runs"))
(define (db:get-runs-cnt-by-patt . args)
#t
(print "Got here: db:get-runs-cnt-by-patt"))
(define (db:get-raw-run-stats . args)
#t
(print "Got here: db:get-raw-run-stats"))
(define (db:update-run-stats . args)
#t
(print "Got here: db:update-run-stats"))
(define (db:get-main-run-stats . args)
#t
(print "Got here: db:get-main-run-stats"))
(define (db:print-current-query-stats . args)
#t
(print "Got here: db:print-current-query-stats"))
(define (db:get-all-run-ids . args)
#t
(print "Got here: db:get-all-run-ids"))
(define (db:get-run-stats . args)
#t
(print "Got here: db:get-run-stats"))
(define (db:get-runs-by-patt . args)
#t
(print "Got here: db:get-runs-by-patt"))
(define (db:get-run-info . args)
#t
(print "Got here: db:get-run-info"))
(define (db:set-comment-for-run . args)
#t
(print "Got here: db:set-comment-for-run"))
(define (db:delete-run . args)
#t
(print "Got here: db:delete-run"))
(define (db:update-run-event_time . args)
#t
(print "Got here: db:update-run-event_time"))
(define (db:lock/unlock-run . args)
#t
(print "Got here: db:lock/unlock-run"))
(define (db:set-run-status . args)
#t
(print "Got here: db:set-run-status"))
(define (db:get-run-status . args)
#t
(print "Got here: db:get-run-status"))
(define (db:get-key-val-pairs . args)
#t
(print "Got here: db:get-key-val-pairs"))
(define (db:get-key-vals . args)
#t
(print "Got here: db:get-key-vals"))
(define (db:get-target . args)
#t
(print "Got here: db:get-target"))
(define (db:get-prev-run-ids . args)
#t
(print "Got here: db:get-prev-run-ids"))
(define (db:get-tests-for-run . args)
#t
(print "Got here: db:get-tests-for-run"))
(define (db:test-short-record->norm . args)
#t
(print "Got here: db:test-short-record->norm"))
(define (db:get-tests-for-run-state-status . args)
#t
(print "Got here: db:get-tests-for-run-state-status"))
(define (db:get-testinfo-state-status . args)
#t
(print "Got here: db:get-testinfo-state-status"))
(define (db:get-tests-for-run-mindata . args)
#t
(print "Got here: db:get-tests-for-run-mindata"))
(define (db:get-tests-for-runs . args)
#t
(print "Got here: db:get-tests-for-runs"))
(define (db:delete-test-records . args)
#t
(print "Got here: db:delete-test-records"))
(define (db:delete-old-deleted-test-records . args)
#t
(print "Got here: db:delete-old-deleted-test-records"))
(define (db:set-tests-state-status . args)
#t
(print "Got here: db:set-tests-state-status"))
(define (db:test-set-state-status . args)
#t
(print "Got here: db:test-set-state-status"))
(define (db:get-count-tests-running . args)
#t
(print "Got here: db:get-count-tests-running"))
(define (db:get-count-tests-actually-running . args)
#t
(print "Got here: db:get-count-tests-actually-running"))
(define (db:get-count-tests-running-for-run-id . args)
#t
(print "Got here: db:get-count-tests-running-for-run-id"))
(define (db:get-count-tests-running-for-testname . args)
#t
(print "Got here: db:get-count-tests-running-for-testname"))
(define (db:get-count-tests-running-in-jobgroup . args)
#t
(print "Got here: db:get-count-tests-running-in-jobgroup"))
(define (db:estimated-tests-remaining . args)
#t
(print "Got here: db:estimated-tests-remaining"))
(define (db:get-test-id . args)
#t
(print "Got here: db:get-test-id"))
(define (db:test-set-top-process-pid . args)
#t
(print "Got here: db:test-set-top-process-pid"))
(define (db:test-get-top-process-pid . args)
#t
(print "Got here: db:test-get-top-process-pid"))
(define (db:field->number . args)
#t
(print "Got here: db:field->number"))
(define (db:get-all-tests-info-by-run-id . args)
#t
(print "Got here: db:get-all-tests-info-by-run-id"))
(define (db:replace-test-records . args)
#t
(print "Got here: db:replace-test-records"))
(define (db:adj-test-id . args)
#t
(print "Got here: db:adj-test-id"))
(define (db:prep-megatest.db-adj-test-ids . args)
#t
(print "Got here: db:prep-megatest.db-adj-test-ids"))
(define (db:prep-megatest.db-for-migration . args)
#t
(print "Got here: db:prep-megatest.db-for-migration"))
(define (db:get-test-info-by-id . args)
#t
(print "Got here: db:get-test-info-by-id"))
(define (db:get-test-info-by-ids . args)
#t
(print "Got here: db:get-test-info-by-ids"))
(define (db:get-test-info . args)
#t
(print "Got here: db:get-test-info"))
(define (db:test-get-rundir-from-test-id . args)
#t
(print "Got here: db:test-get-rundir-from-test-id"))
(define (db:get-test-times . args)
#t
(print "Got here: db:get-test-times"))
(define (db:get-test-times . args)
#t
(print "Got here: db:get-test-times"))
(define (db:teststep-set-status! . args)
#t
(print "Got here: db:teststep-set-status!"))
(define (db:get-steps-for-test . args)
#t
(print "Got here: db:get-steps-for-test"))
(define (db:get-steps-info-by-id . args)
#t
(print "Got here: db:get-steps-info-by-id"))
(define (db:get-steps-data . args)
#t
(print "Got here: db:get-steps-data"))
(define (db:get-data-info-by-id . args)
#t
(print "Got here: db:get-data-info-by-id"))
(define (db:test-data-rollup . args)
#t
(print "Got here: db:test-data-rollup"))
(define (db:logpro-dat->csv . args)
#t
(print "Got here: db:logpro-dat->csv"))
(define (db:csv->test-data . args)
#t
(print "Got here: db:csv->test-data"))
(define (db:read-test-data . args)
#t
(print "Got here: db:read-test-data"))
(define (db:read-test-data* . args)
#t
(print "Got here: db:read-test-data*"))
(define (db:get-run-ids-matching-target . args)
#t
(print "Got here: db:get-run-ids-matching-target"))
(define (db:test-get-paths-matching-keynames-target-new . args)
#t
(print "Got here: db:test-get-paths-matching-keynames-target-new"))
(define (db:test-toplevel-num-items . args)
#t
(print "Got here: db:test-toplevel-num-items"))
(define (db:obj->string . args)
#t
(print "Got here: db:obj->string"))
(define (db:string->obj . args)
#t
(print "Got here: db:string->obj"))
(define (db:set-state-status-and-roll-up-items . args)
#t
(print "Got here: db:set-state-status-and-roll-up-items"))
(define (db:get-all-state-status-counts-for-test . args)
#t
(print "Got here: db:get-all-state-status-counts-for-test"))
(define (db:test-get-logfile-info . args)
#t
(print "Got here: db:test-get-logfile-info"))
(define (db:lookup-query . args)
#t
(print "Got here: db:lookup-query"))
(define (db:login . args)
#t
(print "Got here: db:login"))
(define (db:general-call . args)
#t
(print "Got here: db:general-call"))
(define (db:get-state-status-summary . args)
#t
(print "Got here: db:get-state-status-summary"))
(define (db:get-latest-host-load . args)
#t
(print "Got here: db:get-latest-host-load"))
(define (db:set-top-level-from-items . args)
#t
(print "Got here: db:set-top-level-from-items"))
(define (db:get-matching-previous-test-run-records . args)
#t
(print "Got here: db:get-matching-previous-test-run-records"))
(define (db:delay-if-busy . args)
#t
(print "Got here: db:delay-if-busy"))
(define (db:test-get-records-for-index-file . args)
#t
(print "Got here: db:test-get-records-for-index-file"))
(define (db:get-tests-tags . args)
#t
(print "Got here: db:get-tests-tags"))
(define (db:testmeta-get-record . args)
#t
(print "Got here: db:testmeta-get-record"))
(define (db:testmeta-add-record . args)
#t
(print "Got here: db:testmeta-add-record"))
(define (db:testmeta-update-field . args)
#t
(print "Got here: db:testmeta-update-field"))
(define (db:testmeta-get-all . args)
#t
(print "Got here: db:testmeta-get-all"))
(define (db:compare-itempaths . args)
#t
(print "Got here: db:compare-itempaths"))
(define (db:convert-test-itempath . args)
#t
(print "Got here: db:convert-test-itempath"))
(define (db:multi-pattern-apply . args)
#t
(print "Got here: db:multi-pattern-apply"))
(define (db:get-prereqs-not-met . args)
#t
(print "Got here: db:get-prereqs-not-met"))
(define (db:get-run-record-ids . args)
#t
(print "Got here: db:get-run-record-ids"))
(define (db:get-changed-record-ids . args)
#t
(print "Got here: db:get-changed-record-ids"))
(define (db:extract-ods-file . args)
#t
(print "Got here: db:extract-ods-file"))
;;======================================================================
;; Strings table (kept in the <runid>.db)
;;======================================================================
;; Move this into the runid db init
;;
(define (db:sdb-initialize sdb)
(sqlite3:execute sdb "CREATE TABLE IF NOT EXISTS strs
(id INTEGER PRIMARY KEY,
str TEXT,
CONSTRAINT str UNIQUE (str));")
(sqlite3:execute sdb "CREATE INDEX IF NOT EXISTS strindx ON strs (str);"))
;; (define sumup (let ((a 0))(lambda (x)(set! a (+ x a)) a)))
(define (db:sdb-register-string sdb str)
(sqlite3:execute sdb "INSERT OR IGNORE INTO strs (str) VALUES (?);" str))
(define (db:sdb-string->id sdb str-cache str)
(let ((id (hash-table-ref/default str-cache str #f)))
(if (not id)
(sqlite3:for-each-row
(lambda (sid)
(set! id sid)
(hash-table-set! str-cache str id))
sdb
"SELECT id FROM strs WHERE str=?;" str))
id))
(define (db:sdb-id->string sdb id-cache id)
(let ((str (hash-table-ref/default id-cache id #f)))
(if (not str)
(sqlite3:for-each-row
(lambda (istr)
(set! str istr)
(hash-table-set! id-cache id str))
sdb
"SELECT str FROM strs WHERE id=?;" id))
str))
;; Numbers get passed though in both directions
;;
#;(define (db:sdb-qry fname)
(let ((sdb #f)
(scache (make-hash-table))
(icache (make-hash-table)))
(lambda (cmd var)
(case cmd
((setup) (set! sdb (if (not sdb)
(db:sdb-open (if var var fname)))))
((setdb) (set! sdb var))
((getdb) sdb)
((finalize) (if sdb
(begin
(sqlite3:finalize! sdb)
(set! sdb #f))))
((getid) (let ((id (if (or (number? var)
(string->number var))
var
(db:sdb-string->id sdb scache var))))
(if id
id
(begin
(db:sdb-register-string sdb var)
(db:sdb-string->id sdb scache var)))))
((getstr) (if (or (number? var)
(string->number var))
(db:sdb-id->string sdb icache var)
var))
((passid) var)
((passstr) var)
(else #f)))))
)