[elephant-cvs] CVS update: elephant/src/controller.lisp

[blee at common-lisp.net]

Update of /project/elephant/cvsroot/elephant/src
In directory common-lisp.net:/tmp/cvs-serv28007/src

Modified Files:
	controller.lisp 
Log Message:
docstring fix, some easy transaction functions

Date: Sun Sep 19 19:49:25 2004
Author: blee

Index: elephant/src/controller.lisp
diff -u elephant/src/controller.lisp:1.10 elephant/src/controller.lisp:1.11
--- elephant/src/controller.lisp:1.10	Thu Sep 16 06:15:31 2004
+++ elephant/src/controller.lisp	Sun Sep 19 19:49:25 2004
@@ -61,38 +61,47 @@
 creation, counters, locks, the root (for garbage collection,)
 et cetera."))
 
-(defgeneric cache-instance (sc obj))
-(defgeneric get-cached-instance (sc oid class-name))
-(defgeneric next-oid (sc))
-(defgeneric open-controller (sc &key recover recover-fatal thread))
-(defgeneric close-controller (sc))
+(defgeneric open-controller (sc &key recover recover-fatal thread)
+  (:documentation 
+   "Opens the underlying environment and all the necessary
+database tables."))
+
+(defgeneric close-controller (sc)
+  (:documentation 
+   "Close the db handles and environment.  Tries to wipe out
+references to the db handles."))
 
 (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.  N.B. this means it (and
 everything it points to) won't get gc'd."
+  (declare (type store-controller store-controller))
   (setf (get-value key (controller-root store-controller)) value))
 
 (defun get-from-root (key &key (store-controller *store-controller*))
   "Get a something from the root."
+  (declare (type store-controller store-controller))
   (get-value key (controller-root store-controller)))
 
 (defun remove-from-root (key &key (store-controller *store-controller*))
   "Remove something from the root."
+  (declare (type store-controller store-controller))
   (remove-kv key (controller-root store-controller)))
 
-(defmethod cache-instance ((sc store-controller) obj)
+(defun cache-instance (sc obj)
   "Cache a persistent object with the controller."
+  (declare (type store-controller sc))
   (setf (get-cache (oid obj) (instance-cache sc)) obj))
 
-(defmethod get-cached-instance ((sc store-controller) oid class-name)
+(defun get-cached-instance (sc oid class-name)
   "Get a cached instance, or instantiate!"
+  (declare (type store-controller sc)
+	   (type fixnum oid))
   (let ((obj (get-cache oid (instance-cache sc))))
     (if obj obj
 	;; Should get cached since make-instance calls cache-instance
 	(make-instance class-name :from-oid oid))))
 
-
 ;; OID stuff
 ;; This stuff is all a hack until sequences appear in Sleepycat 4.3
 (defvar %oid-entry (uffi:allocate-foreign-object :char 12))
@@ -112,8 +121,9 @@
 (defvar %oid-entry-length 12)
 (defvar %oid-lock-length 16)
 
-(defmethod next-oid ((sc store-controller))
+(defun next-oid (sc)
   "Get the next OID."
+  (declare (type store-controller sc))
   (sleepycat::next-counter (controller-environment sc)
 			   (controller-db sc)
 			   *current-transaction*
@@ -123,8 +133,6 @@
 ;; Open/close     
 (defmethod open-controller ((sc store-controller) &key (recover nil)
 			    (recover-fatal nil) (thread t))
-  "Opens the underlying environment and all the necessary
-database tables."
   (let ((env (db-env-create)))
     ;; thread stuff?
     (setf (controller-environment sc) env)
@@ -174,8 +182,6 @@
 	sc))))
 
 (defmethod close-controller ((sc store-controller))
-  "Close the db handles and environment.  Tries to wipe out
-references to the db handles."
   (when (slot-value sc 'root)
     ;; no root
     (setf (slot-value sc 'root) nil)
@@ -226,3 +232,19 @@
 	 (progn , at body)
       (close-controller *store-controller*))))
 
+(defun start-transaction (&key (parent *current-transaction*))
+  "Start a transaction.  May be nested but not interleaved."
+  (vector-push-extend *current-transaction* *transaction-stack*)
+  (setq *current-transaction* 
+	(db-transaction-begin (controller-environment *store-controller*)
+			      :parent parent)))
+
+(defun commit-transaction ()
+  "Commit the current transaction."
+  (db-transaction-commit)
+  (setq *current-transaction* (vector-pop *transaction-stack*)))
+
+(defun abort-transaction ()
+  "Abort the current transaction."
+  (db-transaction-abort)
+  (setq *current-transaction* (vector-pop *transaction-stack*)))