[elephant-cvs] CVS elephant/src/elephant

[ieslick]

Update of /project/elephant/cvsroot/elephant/src/elephant
In directory clnet:/tmp/cvs-serv556/src/elephant

Modified Files:
	classindex.lisp controller.lisp 
Log Message:
Added legacy upgrade support, fixed some store-controller base class functionality for SQL to properly delete connections on close

--- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp	2006/03/01 18:57:34	1.6
+++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp	2006/03/07 14:12:22	1.7
@@ -368,9 +368,9 @@
   (get-instances-by-value (find-class class) slot-name value))
 
 (defmethod get-instances-by-value ((class persistent-metaclass) slot-name value)
-  (declare 
-   (optimize (speed 3) (safety 1) (space 1))
-   (type (or string symbol) slot-name))
+;;  (declare 
+;;   (optimize (speed 3) (safety 1) (space 1))
+;;   (type (or string symbol) slot-name))
   (let ((instances nil))
     (with-btree-cursor (cur (find-inverted-index class slot-name))
       (multiple-value-bind (exists? skey val pkey) (cursor-pset cur value)
@@ -388,9 +388,9 @@
   (get-instances-by-range (find-class class) slot-name start end))
 
 (defmethod get-instances-by-range ((class persistent-metaclass) idx-name start end)
-  (declare (optimize speed (safety 1) (space 1))
-	   (type fixnum start end)
-	   (type string idx-name))
+;;  (declare (optimize speed (safety 1) (space 1))
+;;	   (type fixnum start end)
+;;	   (type string idx-name))
   (with-inverted-cursor (cur class idx-name)
     (labels ((next-range (instances)
 	       (multiple-value-bind (exists? skey val pkey) (cursor-pnext-nodup cur)
--- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp	2006/02/21 19:40:03	1.6
+++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp	2006/03/07 14:12:22	1.7
@@ -178,7 +178,8 @@
   (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 :sc sc))))
+	(make-instance (handle-legacy-classes class-name)
+		       :from-oid oid :sc sc))))
 
 (defmethod flush-instance-cache ((sc store-controller))
   "Reset the instance cache (flush object lookups).  Useful 
@@ -187,6 +188,24 @@
   (setf (instance-cache sc)
 	(make-cache-table :test 'eql)))
 
+(defun handle-legacy-classes (name)
+  (let ((entry (assoc (symbol->string-pair name) *legacy-conversions-db* :test #'equal)))
+    (if entry
+	(string-pair->symbol (cdr entry))
+	name)))
+
+(defun symbol->string-pair (name)
+  (cons (string-downcase (package-name (symbol-package name)))
+	(string-downcase (symbol-name name))))
+
+(defun string-pair->symbol (name)
+  (intern (string-upcase (cdr name)) (car name)))
+
+(defparameter *legacy-conversions-db*
+  '((("elephant" . "bdb-btree") . ("sleepycat" . "bdb-btree"))
+    (("elephant" . "bdb-indexed-btree") . ("sleepycat" . "bdb-indexed-btree"))
+    (("elephant" . "bdb-btree-index") . ("sleepycat" . "bdb-btree-index"))))
+
 ;;
 ;; STORE CONTROLLER PROTOCOL
 ;; 
@@ -212,6 +231,12 @@
   (:documentation
    "Provides a persistent source of unique id's"))
 
+;; Handling dbconnection specs
+
+(defmethod close-controller :after ((sc store-controller))
+  "Delete connection spec so object ops on cached db info fail"
+  (remhash (controller-spec sc) *dbconnection-spec*))
+
 ;; Low-level support for metaclass protocol 
 
 (defgeneric persistent-slot-reader (sc instance name)
@@ -262,4 +287,23 @@
   "Map over all key-value pairs in the root"
   (map-btree fn (controller-root store-controller)))
 
+;;
+;; Explicit storage reclamation
+;;
+
+(defmethod drop-pobject ((inst persistent-object))
+  "Reclaim persistent object storage by unbinding slot values.
+   This also drops references to the instance from any index
+   it partipates in.  This does not delete the cached object
+   instance or any serialized references still in the db. 
+   Need a migration or GC for that!"
+  (when (indexed (class-of inst))
+    (drop-instances (list inst)))
+  (let ((pslots (persistent-slots (class-of inst))))
+    (dolist (slot pslots)
+      (slot-makunbound inst slot))))
+;;      (slot-makunbound-using-class (class-of inst)
+;;				   inst
+;;				   (find-effective-slot-def (class-of inst) slot)))))
+