[elephant-cvs] CVS elephant/src

[ieslick]

Update of /project/elephant/cvsroot/elephant/src
In directory common-lisp:/tmp/cvs-serv6576/src

Modified Files:
      Tag: ELEPHANT-0-4-1-rc1-IAN
	IAN-TODO classes.lisp controller.lisp index-utils.lisp 
	indexing.lisp 
Log Message:

There may be a bug or two left, but the major locking problems have been
resolved.  Interactions due to reconnecting to databases can be problematic
(i.e. indexing a new object when a cursor is walking the indices for that
object leads to deadlock in the bdb code where the cursor has a read lock
on an index that the persistent indexing wanted to write)

More tests needed, but the system appears largely stable now.


--- /project/elephant/cvsroot/elephant/src/classes.lisp	2006/01/30 04:55:00	1.16.2.5
+++ /project/elephant/cvsroot/elephant/src/classes.lisp	2006/02/02 21:48:38	1.16.2.6
@@ -79,20 +79,30 @@
 metaclass.")
   (:metaclass persistent-metaclass))
 
-(defmethod initialize-instance ((instance persistent-object) &rest initargs)
+;;(defmethod print-object ((obj persistent) stream)
+
+(defmethod initialize-instance ((instance persistent-object) &rest initargs &key from-oid &allow-other-keys)
   (declare (ignore initargs))
   (if (indexed (class-of instance))
-      (progn
-	(inhibit-indexing (oid instance))
-	(unwind-protect
-	     (progn
-	       (call-next-method)
-	       (uninhibit-indexing (oid instance))
-	       (let ((class-index (find-class-index (class-of instance))))
-		 (with-transaction ()
-		   (setf (get-value (oid instance) class-index) instance))))
-	  (uninhibit-indexing (oid instance))))
-      (call-next-method)))
+	(progn
+	  (let ((oid (oid instance)))
+	    (declare (type fixnum oid))
+	    (inhibit-indexing oid)
+	    (unwind-protect
+		 (call-next-method)
+	      (uninhibit-indexing oid))
+	    ;; Inhibit indexing if the object already was defined (ie being created from an oid)
+            ;;   as it should be indexed already.  This hack avoids a deadlock situation where we 
+            ;;   write the class or index page that we are currently reading via a cursor without 
+            ;;   going through the cursor abstraction. There has to be a better way to do this.
+	    (when (not from-oid)
+	      (let ((class-index (find-class-index (class-of instance))))
+		(when class-index
+;;		  (format t "Indexing initial instance: ~A :: ~A~%" oid instance)
+		  (with-transaction ()
+		    (setf (get-value oid class-index) instance)))))))
+	;; else
+	(call-next-method)))
 
 (defmethod shared-initialize :around ((class persistent-metaclass) slot-names &rest args &key direct-superclasses)
   "Ensures we inherit from persistent-object."
--- /project/elephant/cvsroot/elephant/src/controller.lisp	2006/01/29 04:57:20	1.14.2.2
+++ /project/elephant/cvsroot/elephant/src/controller.lisp	2006/02/02 21:48:38	1.14.2.3
@@ -56,15 +56,17 @@
   )
 
 (defun get-controller (spec)
-  (let ((store-controllers nil))
-    (dolist (s *strategies*)
-      (let ((sc (funcall s spec)))
-	(if sc
-	    (push sc store-controllers))))
-    (if (not (= (length store-controllers) 1))
-	(error "Strategy resolution for this spec completely failed!")
-	(car store-controllers))
-    ))
+  (let ((cached-sc (gethash spec *dbconnection-spec*)))
+    (if cached-sc cached-sc
+	(let ((store-controllers nil))
+	  (dolist (s *strategies*)
+	    (let ((sc (funcall s spec)))
+	      (if sc
+		  (push sc store-controllers))))
+	  (if (not (= (length store-controllers) 1))
+	      (error "Strategy resolution for this spec completely failed!")
+	      (car store-controllers))
+	  ))))
 
 
 (defclass store-controller ()  
@@ -359,7 +361,7 @@
     (setf (slot-value sc 'class-root) nil)
     (setf (slot-value sc 'root) nil)
     ;; clean instance cache
-    (setf (instance-cache sc) (make-cache-table :test 'eql))
+    (reset-instance-cache sc)
     ;; close handles / environment
     (db-sequence-close (controller-oid-seq sc))
     (setf (controller-oid-seq sc) nil)
@@ -375,7 +377,10 @@
     (setf (controller-db sc) nil)
     (db-env-close (controller-environment sc))
     (setf (controller-environment sc) nil)
-    nil))
+    nil)
+  ;; Delete connection spec so object ops on cached db info fail
+  (remhash (controller-path *store-controller*) *dbconnection-spec*))
+
 
 ;; Do these things need to take &rest arguments?
 (defmethod build-btree ((sc bdb-store-controller))
@@ -426,23 +431,25 @@
 the controller unconditionally on exit."
   `(unwind-protect
        (progn
-	 (let (*store-controller* (open-controller ,sc))
+	 (let ((*store-controller* (open-controller ,sc)))
 	   (declare (special *store-controller*))
 	   , at body))
      (close-controller ,sc)))
 
 (defun close-store ()
   "Conveniently close the store controller."
+  (declare (special *store-controller*))
   (if *store-controller*
-  (close-controller *store-controller*)))
+      (progn
+	(close-controller *store-controller*)
+	(setf *store-controller* nil))))
 
 (defmacro with-open-store ((spec) &body body)
   "Executes the body with an open controller,
 unconditionally closing the controller on exit."
-  `(let ((*store-controller* 
-	  (get-controller ,spec)))
+  `(let ((*store-controller* (get-controller ,spec)))
      (declare (special *store-controller*))
-;;     (open-controller *store-controller*)
+     (open-controller *store-controller*)
      (unwind-protect
 	  (progn , at body)
        (close-controller *store-controller*))))