ADDED   testdb.scm
Index: testdb.scm
==================================================================
--- /dev/null
+++ testdb.scm
@@ -0,0 +1,142 @@
+;;======================================================================
+;; Copyright 2006-2013, 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.
+;;======================================================================
+
+;;======================================================================
+;; Test Database access
+;;======================================================================
+
+(require-extension (srfi 18) extras)
+
+(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:))
+
+;; Note, try to remove this dependency 
+;; (use zmq)
+
+(declare (unit testdb))
+(declare (uses common))
+(declare (uses keys))
+(declare (uses ods))
+(declare (uses fs-transport))
+(declare (uses client))
+(declare (uses mt))
+
+(include "common_records.scm")
+(include "db_records.scm")
+(include "key_records.scm")
+(include "run_records.scm")
+
+;;======================================================================
+;; Functions to access test db files with some caching of handles
+;;======================================================================
+
+(define (db:get-db dbstruct run-id)
+  (let ((db (if run-id
+		(hash-table-ref/default (vector-ref dbstruct 1) run-id #f)
+		(vector-ref dbstruct 0))))
+    (if db
+	db
+	(let ((db (open-db run-id)))
+	  (if run-id
+	      (hash-table-set! (vector-ref dbstruct 1) run-id db)
+	      (vector-set! dbstruct 0 db))
+	  db))))
+
+;;======================================================================
+;; K E E P   F I L E D B   I N   dbstruct
+;;======================================================================
+
+(define (db:get-filedb dbstruct)
+  (let ((db (vector-ref dbstruct 2)))
+    (if db
+	db
+	(let ((fdb (filedb:open-db (conc *toplevel* "/db/files.db"))))
+	  (vector-set! dbstruct 2 fdb)
+	  fdb))))
+
+;; Can also be used to save arbitrary strings
+;;
+(define (db:save-path dbstruct path)
+  (let ((fdb (db:get-filedb dbstruct)))
+    (filedb:register-path fdb path)))
+
+;; Use to get a path. To get an arbitrary string see next define
+;;
+(define (db:get-path dbstruct id)
+  (let ((fdb (db:get-filedb dbstruct)))
+    (filedb:get-path db id)))
+
+;;======================================================================
+;;
+;; U S E   F I L E   D B   T O   S T O R E   S T R I N G S 
+;;
+;; N O T E ! !   T H I S   C L O B B E R S   M U L T I P L E  ////  T O  /
+;;
+;; Replace with something proper!
+;;
+;;======================================================================
+
+;; Use to save a stored string, pad with _ to deal with trimming the prepending of /
+;; 
+(define (db:save-string dbstruct str)
+  (let ((fdb (db:get-filedb dbstruct)))
+    (filedb:register-path fdb (conc "_" str))))
+
+;; Use to get a stored string
+;;
+(define (db:get-string dbstruct id)
+  (let ((fdb (db:get-filedb dbstruct)))
+    (string-drop (filedb:get-path fdb id) 2)))
+
+;; This routine creates the db. It is only called if the db is not already opened
+;;
+(define (open-db dbstruct test-id) ;;  (conc *toppath* "/megatest.db") (car *configinfo*)))
+  (if (not *toppath*)
+      (if (not (setup-for-run))
+	  (begin
+	    (debug:print 0 "ERROR: Attempted to open db when not in megatest area. Exiting.")
+	    (exit))))
+
+
+REWORKING open-db
+
+
+  (let* ((test-rec     (db:test-id->record test-id))
+	 (dbpath       (conc (db:test-get-test-path test-rec) "/testdat.db"))
+
+
+	 (dbexists     (file-exists? dbpath))
+	 (write-access (file-write-access? dbpath))
+	 (db           (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath))
+	 (handler      (make-busy-timeout (if (args:get-arg "-override-timeout")
+					      (string->number (args:get-arg "-override-timeout"))
+					      136000)))) ;; 136000))) ;; 136000 = 2.2 minutes
+    (if (and dbexists
+	     (not write-access))
+	(set! *db-write-access* write-access)) ;; only unset so other db's also can use this control
+    (debug:print-info 11 "open-db, dbpath=" dbpath " argv=" (argv))
+    (sqlite3:set-busy-handler! db handler)
+    (if (not dbexists)
+	(if (not run-id) ;; do the megatest.db
+	    (db:initialize-megatest-db db)
+	    (db:initialize-run-id-db   db run-id)))
+    (sqlite3:execute db "PRAGMA synchronous = 0;")
+    db))
+
+;; close all opened run-id dbs
+(define (db:close-all-db)
+  (for-each
+   (lambda (db)
+     (finalize! db))
+   (hash-table-values (vector-ref *open-dbs* 1)))
+  (finalize! (vector-ref *open-dbs* 0)))
+