Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -65,22 +65,21 @@ (set! *transport-type* (if hostinfo (string->symbol (tasks:hostinfo-get-transport hostinfo)) 'fs)) (debug:print-info 11 "Using transport type of " *transport-type* (if hostinfo (conc " to connect to " hostinfo) "")) (case *transport-type* - ((fs)(if (not *megatest-db*)(set! *megatest-db* (open-db)))) + ;; ((fs)(if (not *megatest-db*)(set! *megatest-db* (open-db)))) ((http) (http-transport:client-connect (tasks:hostinfo-get-interface hostinfo) (tasks:hostinfo-get-port hostinfo))) ((zmq) (zmq-transport:client-connect (tasks:hostinfo-get-interface hostinfo) (tasks:hostinfo-get-port hostinfo) (tasks:hostinfo-get-pubport hostinfo))) (else ;; default to fs - (debug:print 0 "ERROR: unrecognised transport type " *transport-type* " attempting to continue with fs") - (set! *transport-type* 'fs) - (set! *megatest-db* (open-db)))) + (debug:print 0 "ERROR: unrecognised transport type " *transport-type* " exiting now.") + (exit))) (pop-directory))) ;; client:signal-handler (define (client:signal-handler signum) (handle-exceptions Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -445,12 +445,12 @@ ;;====================================================================== ;; ;;====================================================================== (define (examine-test test-id) ;; run-id run-key origtest) - (let* ((db-path (conc *toppath* "/megatest.db")) - (db (open-db)) + (let* ((db-path (conc *toppath* "db/main.db")) + (db (make-dbr:dbstruct path: *toppath*)) (tdb (tdb:open-test-db-by-test-id-local test-id)) (testdat (db:get-test-info-by-id db test-id)) (db-mod-time 0) ;; (file-modification-time db-path)) (last-update 0) ;; (current-seconds)) (request-update #t)) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -86,11 +86,11 @@ (if (not (setup-for-run)) (begin (print "Failed to find megatest.config, exiting") (exit 1))) -(define *db* (open-db)) +(define *db* (make-dbr:dbstruct path: *toppath*)) ;; (define sdb:qry (make-sdb:qry)) ;; 'init #f) ;; (if (args:get-arg "-host") ;; (begin Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -37,10 +37,12 @@ (include "db_records.scm") (include "key_records.scm") (include "run_records.scm") (define *rundb-mutex* (make-mutex)) ;; prevent problems opening/closing rundb's +(define *number-of-writes* 0) +(define *number-non-write-queries* 0) ;; Get/open a database ;; if run-id => get run specific db ;; if #f => get main db ;; if db already open - return inmem @@ -128,11 +130,11 @@ (dbpath (let ((dbdir (conc *toppath* "/db"))) ;; use this opportunity to create our db dir (if (not (directory-exists? dbdir)) (create-direcory dbdir)) (conc *toppath* "/db/main.db"))) (dbexists (file-exists? dbpath)) - (db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath)) + (db (sqlite3:open-database dbpath)) (write-access (file-write-access? dbpath)) (handler (make-busy-timeout 136000))) (if (and dbexists (not write-access)) (set! *db-write-access* #f)) (if write-access @@ -364,13 +366,13 @@ (debug:print-info 11 "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params) (if (or *db-write-access* (not (member proc *db:all-write-procs*))) (let* ((db (cond ((sqlite3:database? idb) idb) - ((not idb) (open-db)) + ((not idb) (make-dbr:dbstruct path: *toppath*)) ((procedure? idb) (idb)) - (else (open-db)))) + (else (make-dbr:dbstruct path: *toppath*)))) (res #f)) (set! res (apply proc db params)) (if (not idb)(sqlite3:finalize! db)) (debug:print-info 11 "open-run-close-no-exception-handling END" ) res) @@ -523,11 +525,11 @@ ;;====================================================================== (define (open-logging-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) (let* ((dbpath (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname) (dbexists (file-exists? dbpath)) - (db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath)) + (db (sqlite3:open-database dbpath)) (handler (make-busy-timeout (if (args:get-arg "-override-timeout") (string->number (args:get-arg "-override-timeout")) 136000)))) ;; 136000))) (sqlite3:set-busy-handler! db handler) (if (not dbexists) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -384,36 +384,13 @@ ((http) (set! *transport-type 'http) (server:ensure-running) (client:launch)) (else ;; (fs) + (debug:print 0 "ERROR: Should NOT be getting here! fs transport is no longer supported") (set! *transport-type* 'fs) - (set! *megatest-db* (open-db)))))))))) -;; (cond -;; ;; command line overrides other mechanisms -;; (transport-from-cmdln -;; (if (equal? transport-from-cmdln "fs") -;; (set! *transport-type* 'fs) -;; (begin -;; (server:ensure-running) -;; (client:launch)))) -;; ;; cmdinfo is second priority -;; (transport-from-cmdinfo -;; (if (equal? transport-from-cmdinfo "fs") -;; (set! *transport-type* 'fs) -;; (begin -;; (server:ensure-running) -;; (client:launch)))) -;; ;; config file is next highest priority for determinining transport -;; (transport-from-config -;; (if (equal? transport-from-config "fs") -;; (set! *transport-type* 'fs) -;; (begin -;; (server:ensure-running) -;; (client:launch)))) -;; (else -;; (set! *transport-type* 'fs))))))))) + (set! *megatest-db* (make-dbr:dbstruct path: *toppath* local: #t)))))))))) (if (or (args:get-arg "-list-servers") (args:get-arg "-stop-server")) (let ((tl (setup-for-run))) (if tl @@ -435,11 +412,11 @@ (pubport (vector-ref server 5)) (start-time (vector-ref server 6)) (priority (vector-ref server 7)) (state (vector-ref server 8)) (mt-ver (vector-ref server 9)) - (last-update (vector-ref server 10)) ;; (open-run-close tasks:server-alive? tasks:open-db #f hostname: hostname port: port)) + (last-update (vector-ref server 10)) (transport (vector-ref server 11)) (killed #f) (status (< last-update 20))) ;; (zmq-sockets (if status (server:client-connect hostname port) #f))) ;; no need to login as status of #t indicates we are connecting to correct @@ -584,11 +561,11 @@ ;; NOTE: list-runs and list-db-targets operate on local db!!! ;; (if (or (args:get-arg "-list-runs") (args:get-arg "-list-db-targets")) (if (setup-for-run) - (let* ((db (open-db)) + (let* ((db (make-dbr:dbstruct path: *toppath* local: #t)) (runpatt (args:get-arg "-list-runs")) (testpatt (if (args:get-arg "-testpatt") (args:get-arg "-testpatt") "%")) (runsdat (db:get-runs db runpatt #f #f '())) @@ -809,11 +786,11 @@ (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) - (db (open-db)) + ;; (db (make-dbr:dbstruct path: *)) (state (args:get-arg ":state")) (status (args:get-arg ":status")) (target (args:get-arg "-target"))) (change-directory testpath) ;; (set! *runremote* runremote) @@ -826,22 +803,23 @@ (begin (debug:print 0 "Failed to setup, giving up on -archive, exiting") (exit 1))) (let* ((keys (db:get-keys db)) ;; DO NOT run remote - (paths (db:test-get-paths-matching db keys target))) + (paths (rmt:test-get-paths-matching keys target))) (set! *didsomething* #t) (for-each (lambda (path) (print path)) paths)) - (if (sqlite3:database? db)(sqlite3:finalize! db))) + ;; (if (sqlite3:database? db)(sqlite3:finalize! db)) + ) ;; else do a general-run-call (general-run-call "-test-paths" "Get paths to tests" (lambda (target runname keys keyvals) - (let* ((db (open-db)) + (let* ((db (make-dbr:dbstruct path: *toppath* local: #t)) ;; DO NOT run remote (paths (db:test-get-paths-matching db keys target))) (for-each (lambda (path) (print path)) paths) @@ -854,11 +832,11 @@ (if (args:get-arg "-extract-ods") (general-run-call "-extract-ods" "Make ods spreadsheet" (lambda (target runname keys keyvals) - (let ((db (open-db)) + (let ((db (make-dbr:dbstruct path: *toppath* local: #t)) (outputfile (args:get-arg "-extract-ods")) (runspatt (args:get-arg ":runname")) (pathmod (args:get-arg "-pathmod"))) ;; (keyvalalist (keys->alist keys "%"))) (debug:print 2 "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvals: " keyvals) @@ -1150,17 +1128,18 @@ ;;====================================================================== (if (or (args:get-arg "-repl") (args:get-arg "-load")) (let* ((toppath (setup-for-run)) - (db (if toppath (open-db) #f))) + (db (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))) (if db (begin (set! *db* db) (set! *client-non-blocking-mode* #t) (import readline) (import apropos) + ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... (gnu-history-install-file-manager (string-append (or (get-environment-variable "HOME") ".") "/.megatest_history")) (current-input-port (make-gnu-readline-port "megatest> ")) (if (args:get-arg "-repl") @@ -1169,11 +1148,11 @@ (exit)) (set! *didsomething* #t))) (if (args:get-arg "-convert-to-norm") (let* ((toppath (setup-for-run)) - (db (if toppath (open-db) #f))) + (db (if toppath (make-dbr:dbstruct path: toppath local: #t)))) (for-each (lambda (field) (let ((dat '())) (debug:print-info 0 "Getting data for field " field) (sqlite3:for-each-row Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -58,15 +58,10 @@ (runconfig #f) (serverdat (if (args:get-arg "-server") *runremote* #f)) ;; to be used later (transport (or (args:get-arg "-transport") 'http)) - (db (if (and mconfig - (or (args:get-arg "-server") - (eq? transport 'fs))) - (open-db) - #f)) (run-id #f)) ;; Set all the environment vars we know so far, start with keys (for-each (lambda (keyval) (setenv (car keyval)(cadr keyval))) keyvals) @@ -214,13 +209,10 @@ (test-records (make-hash-table)) (all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names (all-test-names (hash-table-keys all-tests-registry)) (test-names (tests:filter-test-names all-test-names test-patts))) - ;; Update the synchronous setting in the db based on the default or what is set by the user - ;; This is done once here on a call to run tests rather than on every call to open-db - (set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process (if (file-exists? runconfigf) (setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals "pre-launch-env-vars") (debug:print 0 "WARNING: You do not have a run config file: " runconfigf))