[elephant-cvs] CVS update: elephant/src/controller.lisp
blee at common-lisp.net
blee at common-lisp.net
Thu Sep 16 04:15:33 UTC 2004
Update of /project/elephant/cvsroot/elephant/src
In directory common-lisp.net:/tmp/cvs-serv25325/src
Modified Files:
controller.lisp
Log Message:
doc-strings
table-layout for btrees
better with-open-store macro
Date: Thu Sep 16 06:15:32 2004
Author: blee
Index: elephant/src/controller.lisp
diff -u elephant/src/controller.lisp:1.9 elephant/src/controller.lisp:1.10
--- elephant/src/controller.lisp:1.9 Sat Sep 4 10:28:44 2004
+++ elephant/src/controller.lisp Thu Sep 16 06:15:31 2004
@@ -49,12 +49,16 @@
(environment :type (or null pointer-void)
:accessor controller-environment)
(db :type (or null pointer-void) :accessor controller-db)
+ (btrees :type (or null pointer-void) :accessor controller-btrees)
+ (indices :type (or null pointer-void) :accessor controller-indices)
+ (indices-assoc :type (or null pointer-void)
+ :accessor controller-indices-assoc)
(root :reader controller-root)
(instance-cache :accessor instance-cache
:initform (make-cache-table :test 'eql)))
- (:documentation "Class of objects responsible for handling
-the book-keeping of holding DB handles, the cache, table
-creation, counters, locks, the root and garbage collection,
+ (:documentation "Class of objects responsible for the
+book-keeping of holding DB handles, the cache, table
+creation, counters, locks, the root (for garbage collection,)
et cetera."))
(defgeneric cache-instance (sc obj))
@@ -65,26 +69,24 @@
(defun add-to-root (key value &key (store-controller *store-controller*))
"Add an arbitrary persistent thing to the root, so you can
-retrieve it in a later session. Keys may be arbitrary
-persistables as well (though note collection key semantics!)
-N.B. this means it (and everything it points to) won't get
-gc'd."
+retrieve it in a later session. N.B. this means it (and
+everything it points to) won't get gc'd."
(setf (get-value key (controller-root store-controller)) value))
-(defmethod get-from-root (key &key (store-controller *store-controller*))
- "Get a persistent thing from the root."
+(defun get-from-root (key &key (store-controller *store-controller*))
+ "Get a something from the root."
(get-value key (controller-root store-controller)))
-(defmethod remove-from-root (key &key (store-controller *store-controller*))
- "Get a persistent thing from the root."
+(defun remove-from-root (key &key (store-controller *store-controller*))
+ "Remove something from the root."
(remove-kv key (controller-root store-controller)))
(defmethod cache-instance ((sc store-controller) obj)
- "Register an instance of a user persistent-class with the
-controller."
+ "Cache a persistent object with the controller."
(setf (get-cache (oid obj) (instance-cache sc)) obj))
(defmethod get-cached-instance ((sc store-controller) oid class-name)
+ "Get a cached instance, or instantiate!"
(let ((obj (get-cache oid (instance-cache sc))))
(if obj obj
;; Should get cached since make-instance calls cache-instance
@@ -111,6 +113,7 @@
(defvar %oid-lock-length 16)
(defmethod next-oid ((sc store-controller))
+ "Get the next OID."
(sleepycat::next-counter (controller-environment sc)
(controller-db sc)
*current-transaction*
@@ -128,19 +131,46 @@
(db-env-open env (controller-path sc) :create t :init-txn t :init-lock t
:init-mpool t :init-log t :thread thread
:recover recover :recover-fatal recover-fatal)
- (let ((db (db-create env)))
+ (let ((db (db-create env))
+ (btrees (db-create env))
+ (indices (db-create env))
+ (indices-assoc (db-create env)))
(setf (controller-db sc) db)
(db-open db :file "%ELEPHANT" :database "%ELEPHANTDB"
:auto-commit t :type DB-BTREE :create t :thread thread)
+
+ (setf (controller-btrees sc) btrees)
+ (sleepycat::db-set-lisp-compare btrees)
+ (db-open btrees :file "%ELEPHANT" :database "%ELEPHANTBTREES"
+ :auto-commit t :type DB-BTREE :create t :thread thread)
+
+ (setf (controller-indices sc) indices)
+ (sleepycat::db-set-lisp-compare indices)
+ (sleepycat::db-set-lisp-dup-compare indices)
+ (db-set-flags indices :dup-sort t)
+ (db-open indices :file "%ELEPHANT" :database "%ELEPHANTINDICES"
+ :auto-commit t :type DB-BTREE :create t :thread thread)
+
+ (setf (controller-indices-assoc sc) indices-assoc)
+ (sleepycat::db-set-lisp-compare indices-assoc)
+ (sleepycat::db-set-lisp-dup-compare indices-assoc)
+ (db-set-flags indices-assoc :dup-sort t)
+ (db-open indices-assoc :file "%ELEPHANT" :database "%ELEPHANTINDICES"
+ :auto-commit t :type DB-UNKNOWN :thread thread :rdonly t)
+ (sleepycat::db-fake-associate btrees indices-assoc :auto-commit t)
+
(let ((root (make-instance 'btree :from-oid -1)))
(setf (slot-value sc 'root) root)
- (let ((*auto-commit* t))
- (unless (db-get-key-buffered db %oid-entry %oid-entry-length)
- (buffer-write-int 0 *out-buf*)
- (db-put-buffered db %oid-entry %oid-entry-length
- (buffer-stream-buffer *out-buf*) 4
- :auto-commit t)
- (finish-buffer *out-buf*)))
+ (with-transaction ()
+ (with-buffer-streams (key-buf value-buf)
+ (let ((key-b (buffer-stream-buffer key-buf)))
+ (setf (buffer-stream-buffer key-buf) %oid-entry)
+ (setf (sleepycat::buffer-stream-size key-buf) %oid-entry-length)
+ (unless (db-get-key-buffered db key-buf value-buf)
+ (reset-buffer-stream value-buf)
+ (buffer-write-int 0 value-buf)
+ (db-put-buffered db key-buf value-buf))
+ (setf (buffer-stream-buffer key-buf) key-b))))
sc))))
(defmethod close-controller ((sc store-controller))
@@ -151,7 +181,13 @@
(setf (slot-value sc 'root) nil)
;; clean instance cache
(setf (instance-cache sc) (make-cache-table :test 'eql))
- ;; close environment
+ ;; close handles / environment
+ (db-close (controller-indices-assoc sc))
+ (setf (controller-indices-assoc sc) nil)
+ (db-close (controller-indices sc))
+ (setf (controller-indices sc) nil)
+ (db-close (controller-btrees sc))
+ (setf (controller-btrees sc) nil)
(db-close (controller-db sc))
(setf (controller-db sc) nil)
(db-env-close (controller-environment sc))
@@ -160,6 +196,8 @@
(defmacro with-open-controller ((&optional (sc '*store-controller*))
&body body)
+ "Executes body with the specified controller open, closing
+the controller unconditionally on exit."
`(unwind-protect
(progn
(let (*store-controller* (open-controller ,sc))
@@ -167,21 +205,24 @@
, at body))
(close-controller ,sc)))
-(defun open-store (path)
+(defun open-store (path &key (recover nil)
+ (recover-fatal nil) (thread t))
+ "Conveniently open a store controller."
(setq *store-controller* (make-instance 'store-controller :path path))
- (open-controller *store-controller*))
+ (open-controller *store-controller* :recover recover
+ :recover-fatal recover-fatal :thread thread))
(defun close-store ()
+ "Conveniently close the store controller."
(close-controller *store-controller*))
(defmacro with-open-store ((path) &body body)
- (let ((sc (gensym)))
- `(let ((,sc (make-instance 'store-controller :path ,path)))
- (unwind-protect
- (progn
- (let ((*store-controller* ,sc))
- (declare (special *store-controller*))
- (open-controller *store-controller*)
- , at body))
- (close-controller ,sc)))))
+ "Executes the body with an open controller,
+unconditionally closing the controller on exit."
+ `(let ((*store-controller* (make-instance 'store-controller :path ,path)))
+ (declare (special *store-controller*))
+ (open-controller *store-controller*)
+ (unwind-protect
+ (progn , at body)
+ (close-controller *store-controller*))))
More information about the Elephant-cvs
mailing list