Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -4,11 +4,11 @@ INSTALL=install SRCFILES = common.scm items.scm launch.scm \ ods.scm runconfig.scm server.scm configf.scm \ db.scm keys.scm margs.scm megatest-version.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ - fs-transport.scm http-transport.scm \ + fs-transport.scm http-transport.scm filedb.scm \ client.scm gutils.scm synchash.scm daemon.scm mt.scm dcommon.scm \ tree.scm ezsteps.scm lock-queue.scm sdb.scm GUISRCF = dashboard-tests.scm dashboard-guimonitor.scm Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -89,10 +89,12 @@ (set! *env-vars-by-run-id* (make-hash-table)) (set! *test-id-cache* (make-hash-table))) ;; Generic string database (normalization of sorts) (define sdb:qry #f) ;; (make-sdb:qry)) ;; 'init #f) +;; Generic path database (normalization of sorts) +(define *fdb* #f) ;;====================================================================== ;; S T A T E S A N D S T A T U S E S ;;====================================================================== Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -26,10 +26,11 @@ (declare (uses common)) (declare (uses db)) (declare (uses gutils)) (declare (uses ezsteps)) (declare (uses sdb)) +(declare (uses filedb)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") @@ -384,11 +385,11 @@ (cond ((and need-update newtestdat) (set! testdat newtestdat) (set! teststeps (db:get-compressed-steps test-id work-area: rundir)) (set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat))) - (set! rundir (sdb:qry 'getstr (db:test-get-rundir testdat))) + (set! rundir (filedb:get-path *fdb* (db:test-get-rundir testdat))) (set! testfullname (db:test-get-fullname testdat)) ;; (debug:print 0 "INFO: teststeps=" (intersperse teststeps "\n ")) (if (eq? curr-mod-time db-mod-time) ;; do only once if same (set! db-mod-time (+ curr-mod-time 1)) (set! db-mod-time curr-mod-time)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -29,10 +29,11 @@ (declare (uses ods)) (declare (uses fs-transport)) (declare (uses client)) (declare (uses mt)) (declare (uses sdb)) +(declare (uses filedb)) (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") (include "run_records.scm") @@ -85,10 +86,11 @@ (sqlite3:set-busy-handler! db handler) (if (not dbexists) (db:initialize db)) (db:set-sync db) (set! sdb:qry (make-sdb:qry)) ;; we open the normalization helpers here + (set! *fdb* (filedb:open-db (conc *toppath* "/db/paths.db"))) db)) ;; keeping it around for debugging purposes only (define (open-run-close-no-exception-handling proc idb . params) (debug:print-info 11 "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params) @@ -293,11 +295,11 @@ ;; find and open the testdat.db file for an existing test (define (db:open-test-db-by-test-id db test-id #!key (work-area #f)) (let* ((test-path (if work-area work-area - (sdb:qry 'getstr (cdb:remote-run db:test-get-rundir-from-test-id db test-id))))) + (filedb:get-path *fdb* (cdb:remote-run db:test-get-rundir-from-test-id db test-id))))) (debug:print 3 "TEST PATH: " test-path) (open-test-db test-path))) (define (db:testdb-initialize db) (debug:print 11 "db:testdb-initialize START") Index: ezsteps.scm ================================================================== --- ezsteps.scm +++ ezsteps.scm @@ -17,18 +17,19 @@ (declare (uses db)) (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) (declare (uses sdb)) +(declare (uses filedb)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (define (ezsteps:run-from testdat start-step-name run-one) - (let* ((test-run-dir (db:test-get-rundir testdat)) + (let* ((test-run-dir (filedb:get-path *fdb* (db:test-get-rundir testdat))) (testconfig (read-config (conc test-run-dir "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) (ezstepslst (hash-table-ref/default testconfig "ezsteps" '())) (run-mutex (make-mutex)) (rollup-status 0) (exit-info (vector #t #t #t)) Index: filedb.scm ================================================================== --- filedb.scm +++ filedb.scm @@ -23,11 +23,11 @@ (filedb:fdb-set-db! fdb db) (filedb:fdb-set-dbpath! fdb dbpath) (filedb:fdb-set-pathcache! fdb (make-hash-table)) (filedb:fdb-set-idcache! fdb (make-hash-table)) (filedb:fdb-set-partcache! fdb (make-hash-table)) - ;(sqlite3:set-busy-timeout! db 1000000) + (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) (if (not dbexists) (begin (sqlite3:execute db "PRAGMA synchronous = OFF;") (sqlite3:execute db "CREATE TABLE names (id INTEGER PRIMARY KEY,name TEST);") ;; for future use - change path in paths table to path_id (sqlite3:execute db "CREATE INDEX name_index ON names (name);") @@ -42,10 +42,15 @@ mtime INTEGER DEFAULT -1);") (sqlite3:execute db "CREATE INDEX path_index ON paths (path,parent_id);") (sqlite3:execute db "CREATE TABLE bases (id INTEGER PRIMARY KEY,base TEXT, updated TIMESTAMP);"))) fdb)) +(define (filedb:reopen-db fdb) + (let ((db (sqlite3:open-database (filedb:fdb-get-dbpath fdb)))) + (filedb:fdb-set-db! fdb db) + (sqlite3:set-busy-handler! db (make-busy-timeout 136000)))) + (define (filedb:finalize-db! fdb) (sqlite3:finalize! (filedb:fdb-get-db fdb))) (define (filedb:get-current-time-string) (string-chomp (time->string (seconds->local-time (current-seconds))))) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -20,10 +20,11 @@ (declare (unit launch)) (declare (uses common)) (declare (uses configf)) (declare (uses db)) (declare (uses sdb)) +(declare (uses filedb)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") @@ -495,11 +496,11 @@ (lnkbase (conc linktree "/" target "/" runname)) (lnkpath (conc lnkbase "/" testname)) (lnkpathf (conc lnkpath (if not-iterated "" "/") item-path))) ;; Update the rundir path in the test record for all - (cdb:test-set-rundir-by-test-id *runremote* test-id (sdb:qry 'getid lnkpathf)) + (cdb:test-set-rundir-by-test-id *runremote* test-id (filedb:register-path *fdb* lnkpathf)) (debug:print 2 "INFO:\n lnkbase=" lnkbase "\n lnkpath=" lnkpath "\n toptest-path=" toptest-path "\n test-path=" test-path) (if (not (file-exists? linktree)) (begin (debug:print 0 "WARNING: linktree did not exist! Creating it now at " linktree) @@ -516,14 +517,14 @@ ;; NB - This is not working right - some top tests are not getting the path set!!! (if (not (hash-table-ref/default *toptest-paths* testname #f)) (let* ((testinfo (cdb:get-test-info-by-id *runremote* test-id)) ;; run-id testname item-path)) - (curr-test-path (if testinfo (sdb:qry 'getstr (db:test-get-rundir testinfo)) #f))) + (curr-test-path (if testinfo (filedb:get-path *fdb* (db:test-get-rundir testinfo)) #f))) (hash-table-set! *toptest-paths* testname curr-test-path) ;; NB// Was this for the test or for the parent in an iterated test? - (cdb:test-set-rundir! *runremote* run-id testname "" (sdb:qry 'getid lnkpath)) ;; toptest-path) + (cdb:test-set-rundir! *runremote* run-id testname "" (filedb:register-path *fdb* lnkpath)) ;; toptest-path) (if (or (not curr-test-path) (not (directory-exists? toptest-path))) (begin (debug:print-info 2 "Creating " toptest-path " and link " lnkpath) (create-directory toptest-path #t) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -26,10 +26,11 @@ (declare (uses tests)) (declare (uses genexample)) (declare (uses daemon)) (declare (uses db)) (declare (uses sdb)) +(declare (uses filedb)) (define *db* #f) ;; this is only for the repl, do not use in general!!!! (include "common_records.scm") (include "key_records.scm") @@ -627,11 +628,11 @@ (equal? (db:test-get-state test) "NOT_STARTED"))) (begin (print " cpuload: " (db:test-get-cpuload test) "\n diskfree: " (db:test-get-diskfree test) "\n uname: " (sdb:qry 'getstr (db:test-get-uname test)) - "\n rundir: " (sdb:qry 'getstr (db:test-get-rundir test)) + "\n rundir: " (filedb:get-path *fdb* (db:test-get-rundir test)) ) ;; Each test ;; DO NOT remote run (let ((steps (db:get-steps-for-test #f (db:test-get-id test)))) (for-each @@ -1194,11 +1195,12 @@ ;; this is the socket if we are a client ;; (if (and *runremote* ;; (socket? *runremote*)) ;; (close-socket *runremote*)) -(sdb:qry 'finalize! #f) +(if sdb:qry (sdb:qry 'finalize #f)) +(if *fdb* (filedb:finalize-db! *fdb*)) (if (not *didsomething*) (debug:print 0 help)) ;; (if *runremote* (rpc:close-all-connections!)) Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -17,10 +17,11 @@ (declare (uses items)) (declare (uses runconfig)) (declare (uses tests)) (declare (uses server)) (declare (uses runs)) +(declare (uses filedb)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") @@ -112,11 +113,11 @@ ;; T R I G G E R S ;;====================================================================== (define (mt:process-triggers test-id newstate newstatus) (let* ((test-dat (mt:lazy-get-test-info-by-id test-id)) - (test-rundir (sdb:qry 'getstr (db:test-get-rundir test-dat))) + (test-rundir (filedb:get-path *fdb* (db:test-get-rundir test-dat))) (test-name (db:test-get-testname test-dat)) (tconfig #f) (state (if newstate newstate (db:test-get-state test-dat))) (status (if newstatus newstatus (db:test-get-status test-dat)))) (if (and (file-exists? test-rundir) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -19,10 +19,11 @@ (declare (uses items)) (declare (uses runconfig)) (declare (uses tests)) (declare (uses server)) (declare (uses mt)) +(declare (uses filedb)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") @@ -1211,12 +1212,12 @@ action) ((run-wait) (debug:print 1 "Waiting for run " runkey ", run=" runnamepatt " to complete")) (else (debug:print-info 0 "action not recognised " action))) - (let ((sorted-tests (sort tests (lambda (a b)(let ((dira (sdb:qry 'getstr (db:test-get-rundir a))) - (dirb (sdb:qry 'getstr (db:test-get-rundir b)))) + (let ((sorted-tests (sort tests (lambda (a b)(let ((dira (filedb:get-path *fdb* (db:test-get-rundir a))) + (dirb (filedb:get-path *fdb* (db:test-get-rundir b)))) (if (and (string? dira)(string? dirb)) (> (string-length dira)(string-length dirb)) #f))))) (test-retry-time (make-hash-table)) (allow-run-time 10)) ;; seconds to allow for killing tests before just brutally killing 'em @@ -1229,11 +1230,11 @@ (debug:print 0 "ERROR: We have a test-id of " test-id " but no record was found. NOTE: No locking of records is done between processes, do not simultaneously remove the same run from two processes!") (if (not (null? tal)) (loop (car tal)(cdr tal)))) (let* ((item-path (db:test-get-item-path new-test-dat)) (test-name (db:test-get-testname new-test-dat)) - (run-dir (sdb:qry 'getstr (db:test-get-rundir new-test-dat))) ;; run dir is from the link tree + (run-dir (filedb:get-path *fdb* (db:test-get-rundir new-test-dat))) ;; run dir is from the link tree (real-dir (if (file-exists? run-dir) (resolve-pathname run-dir) #f)) (test-state (db:test-get-state new-test-dat)) (test-fulln (db:test-get-fullname new-test-dat))) Index: sdb.scm ================================================================== --- sdb.scm +++ sdb.scm @@ -34,13 +34,11 @@ fe (begin (create-directory (conc *toppath* "/db") #t) #f)))) (sdb (sqlite3:open-database dbpath)) - (handler (make-busy-timeout (if (args:get-arg "-override-timeout") - (string->number (args:get-arg "-override-timeout")) - 136000)))) + (handler (make-busy-timeout 136000))) (sqlite3:set-busy-handler! sdb handler) (if (not dbexists) (sdb:initialize sdb)) (sqlite3:execute sdb "PRAGMA synchronous = 1;") sdb)) @@ -80,18 +78,20 @@ str)) ;; Numbers get passed though in both directions ;; (define (make-sdb:qry #!key (fname #f)) - (let ((sdb (sdb:open fname: fname)) + (let ((sdb #f) ;; (sdb:open fname: fname)) (scache (make-hash-table)) (icache (make-hash-table))) (lambda (cmd var) - ;; (if (not sdb)(set! sdb (sdb:open))) + (if (not sdb)(set! sdb (sdb:open fname: fname))) (case cmd - ;; ((init) (if (not sdb)(set! sdb (sdb:open)))) - ((finalize!) (if sdb (sqlite3:finalize! sdb))) + ((finalize) (if sdb + (begin + (sqlite3:finalize! sdb) + (set! sdb #f)))) ((getid) (let ((id (if (or (number? var) (string->number var)) var (sdb:string->id sdb scache var)))) (if id Index: zmq-transport.scm ================================================================== --- zmq-transport.scm +++ zmq-transport.scm @@ -1,14 +1,15 @@ - +;;====================================================================== ;; Copyright 2006-2012, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. +;;====================================================================== (require-extension (srfi 18) extras tcp s11n) (use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest) (import (prefix sqlite3 sqlite3:))