[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-serv13575/src

Modified Files:
	controller.lisp 
Log Message:
license, name changes, with-transaction* defaulters

Date: Fri Aug 27 10:31:59 2004
Author: blee

Index: elephant/src/controller.lisp
diff -u elephant/src/controller.lisp:1.2 elephant/src/controller.lisp:1.3
--- elephant/src/controller.lisp:1.2	Thu Aug 26 19:58:09 2004
+++ elephant/src/controller.lisp	Fri Aug 27 10:31:59 2004
@@ -1,12 +1,51 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;
+;;; controller.lisp -- Lisp interface to a Berkeley DB store
+;;; 
+;;; Initial version 8/26/2004 by Ben Lee
+;;; <blee at common-lisp.net>
+;;; 
+;;; part of
+;;;
+;;; Elephant: an object-oriented database for Common Lisp
+;;;
+;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee
+;;; <ablumberg at common-lisp.net> <blee at common-lisp.net>
+;;;
+;;; This program is free software; you can redistribute it
+;;; and/or modify it under the terms of the GNU General
+;;; Public License as published by the Free Software
+;;; Foundation; either version 2 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be
+;;; useful, but WITHOUT ANY WARRANTY; without even the
+;;; implied warranty of MERCHANTABILITY or FITNESS FOR A
+;;; PARTICULAR PURPOSE. See the GNU General Public License
+;;; for more details.
+;;;
+;;; The GNU General Public License can be found in the file
+;;; LICENSE which should have been distributed with this
+;;; code.  It can also be found at
+;;;
+;;; http://www.opensource.org/licenses/gpl-license.php
+;;;
+;;; You should have received a copy of the GNU General
+;;; Public License along with this program; if not, write
+;;; to the Free Software Foundation, Inc., 59 Temple Place,
+;;; Suite 330, Boston, MA 02111-1307 USA
+;;;
+
 (in-package "ELEPHANT")
 
 (defclass store-controller ()  
   ((path :type (or pathname string)
-	 :reader path
+	 :accessor controller-path
 	 :initarg :path)
-   (environment :type (or null pointer-void) :accessor environment)
-   (db :type (or null pointer-void) :accessor db)
-   (root :accessor root)
+   (environment :type (or null pointer-void) 
+		:accessor controller-environment)
+   (db :type (or null pointer-void) :accessor controller-db)
+   (root :reader controller-root)
    (instance-cache :accessor instance-cache
 		   :initform (make-cache-table :test 'eql)))
   (:documentation "Class of objects responsible for handling
@@ -20,11 +59,15 @@
 persistables as well (though note collection key semantics!)
 N.B. this means it (and everything it points to) won't get
 gc'd."
-  (setf (get-value key (root sc)) value))
+  (setf (get-value key (controller-root sc)) value))
 
 (defmethod get-from-root ((sc store-controller) key)
   "Get a persistent thing from the root."
-  (get-value key (root sc)))
+  (get-value key (controller-root sc)))
+
+(defmethod remove-from-root ((sc store-controller) key)
+  "Get a persistent thing from the root."
+  (remove-kv key (controller-root sc)))
 
 (defmethod cache-instance ((sc store-controller) obj)
   "Register an instance of a user persistent-class with the
@@ -32,38 +75,41 @@
   (setf (get-cache (oid obj) (instance-cache sc)) obj))
 
 (defmethod get-cached-instance ((sc store-controller) oid class-name)
-  (let ((obj (get-cache oid (instance-cache sc) nil)))
+  (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))))
 
-(defmethod open-controller ((sc store-controller))
+(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 (environment sc) env)
-    (db-env-open env (path sc) :create t :init-txn t :init-lock t 
-		 :init-mpool t :init-log t :thread t :recover-fatal t)
+    (setf (controller-environment sc) env)
+    (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)))
-      (setf (db sc) db)
-      (db-open db :auto-commit t :type DB-BTREE :create t :thread t)
+      (setf (controller-db sc) db)
+      (db-open db :file "%ELEPHANT" :database "%ELEPHANTDB" 
+	       :auto-commit t :type DB-BTREE :create t :thread thread)
       (let ((root (make-instance 'btree :from-oid -1)))
-	(setf (root sc) root)
+	(setf (slot-value sc 'root) root)
 	sc))))
 
 (defmethod close-controller ((sc store-controller))
   "Close the db handles and environment.  Tries to wipe out
 references to the db handles."
   ; no root
-  (setf (root sc) nil)
+  (setf (slot-value sc 'root) nil)
   ; clean instance cache
   (setf (instance-cache sc) (make-cache-table :test 'eql))
   ; close environment
-  (db-close (db sc))
-  (setf (db sc) nil)
-  (db-env-close (environment sc))
-  (setf (environment sc) nil)
+  (db-close (controller-db sc))
+  (setf (controller-db sc) nil)
+  (db-env-close (controller-environment sc))
+  (setf (controller-environment sc) nil)
   nil)
 
 (defmacro with-open-controller ((&optional (sc *store-controller*))
@@ -73,6 +119,43 @@
 	 (open-controller ,sc)
 	 , at body)
      (close-controller ,sc)))
+
+(defmacro with-transaction ((&key transaction 
+				  (environment (controller-environment
+						*store-controller*))
+				  (globally t)
+				  (parent *current-transaction*)
+				  dirty-read txn-nosync
+				  txn-nowait txn-sync)
+			    &body body)
+  `(sleepycat:with-transaction (:transaction ,transaction
+				:environment ,environment
+				:globally ,globally
+				:parent ,parent
+				:dirty-read ,dirty-read
+				:txn-nosync ,txn-nosync
+				:txn-nowait ,txn-nowait
+				:txn-sync ,txn-sync)
+    , at body))
+
+(defmacro with-transaction-retry ((&key transaction environment 
+					(globally t) 
+					(parent *current-transaction*)
+					(retries 100)
+					dirty-read txn-nosync 
+					txn-nowait txn-sync)
+				  &body body)
+  `(sleepycat:with-transaction-retry (:transaction ,transaction
+				      :environment ,environment
+				      :globally ,globally
+				      :parent ,parent
+				      :retries ,retries
+				      :dirty-read ,dirty-read
+				      :txn-nosync ,txn-nosync
+				      :txn-nowait ,txn-nowait
+				      :txn-sync ,txn-sync)
+    , at body))
+
 
 ;; This stuff is all a hack until sequences appear in Sleepycat 4.3
 (defconstant max-oid most-positive-fixnum)