[elephant-cvs] CVS elephant/src/elephant
ieslick
ieslick at common-lisp.net
Sat Feb 25 20:53:57 UTC 2006
Update of /project/elephant/cvsroot/elephant/src/elephant
In directory clnet:/tmp/cvs-serv26146/src/elephant
Modified Files:
classes.lisp classindex.lisp metaclasses.lisp
Log Message:
Fixed indexing bugs and SQL backend secondary index abstraction
--- /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2006/02/25 17:04:56 1.6
+++ /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2006/02/25 20:53:57 1.7
@@ -20,7 +20,6 @@
(defvar *debug-si* nil)
-
(defmethod initialize-instance :before ((instance persistent)
&rest initargs
&key from-oid
@@ -68,10 +67,35 @@
(when (not (slot-boundp instance '%indexed-slots))
(update-indexed-record instance (indexed-slot-names-from-defs instance)))))
+(defmethod reinitialize-instance :around ((instance persistent-metaclass) &rest initargs &key &allow-other-keys)
+ (declare (ignore initargs))
+ (prog1
+ (call-next-method)
+ (when (class-finalized-p instance)
+ (update-persistent-slots instance (persistent-slot-names instance))
+ (update-indexed-record instance (indexed-slot-names-from-defs instance))
+ (if (removed-indexing? instance)
+ (progn
+ (let ((class-idx (get-value (class-name instance) (controller-class-root *store-controller*))))
+ (when class-idx
+ (wipe-class-indexing instance class-idx)))
+ (setf (%index-cache instance) nil))
+ (set-db-synch instance :class))
+ #+allegro
+ (loop with persistent-slots = (persistent-slots instance)
+ for slot-def in (class-direct-slots instance)
+ when (member (slot-definition-name slot-def) persistent-slots)
+ do (initialize-accessors slot-def instance))
+ (make-instances-obsolete instance))))
+
;; ================================================
;; PERSISTENT OBJECT MAINTENANCE
;; ================================================
+;;
+;; CLASS INSTANCE INITIALIZATION
+;;
+
(defmethod shared-initialize :around ((instance persistent-object) slot-names &rest initargs &key from-oid &allow-other-keys)
"Initializes the persistent slots via initargs or forms.
This seems to be necessary because it is typical for
@@ -90,45 +114,51 @@
(transient-slot-names class)
(remove-if #'persistent-slot-p slot-names)))
(persistent-slot-inits
- (if (eq slot-names t) persistent-slot-names
+ (if (eq slot-names t)
+ persistent-slot-names
(remove-if-not #'persistent-slot-p slot-names))))
(inhibit-indexing oid)
(unwind-protect
- ;; initialize the persistent slots
- (flet ((initialize-from-initarg (slot-def)
- (loop for initarg in initargs
- with slot-initargs = (slot-definition-initargs slot-def)
- when (member initarg slot-initargs :test #'eq)
- do
- (setf (slot-value-using-class class instance slot-def)
- (getf initargs initarg))
- (return t))))
- (with-transaction (:store-controller (get-con instance))
- (loop for slot-def in (class-slots class)
- unless (initialize-from-initarg slot-def)
- when (member (slot-definition-name slot-def) persistent-slot-inits :test #'eq)
- unless (slot-boundp-using-class class instance slot-def)
- do
- (let ((initfun (slot-definition-initfunction slot-def)))
- (when initfun
- (setf (slot-value-using-class class instance slot-def)
- (funcall initfun))))))
-;; (format t "transient-slot-inits ~A~%" transient-slot-inits)
-;; (format t "indices boundp ~A~%" (slot-boundp instance 'indices))
-;; (format t "indices-caches boundp ~A~%" (slot-boundp instance 'indices-cache))
- ;; let the implementation initialize the transient slots
- (apply #'call-next-method instance transient-slot-inits initargs))
+ (progn
+ ;; initialize the persistent slots ourselves
+ (initialize-persistent-slots class instance persistent-slot-inits initargs)
+ ;; let the implementation initialize the transient slots
+ (apply #'call-next-method instance transient-slot-inits initargs))
(uninhibit-indexing oid))
- ;; Inhibit indexing altogether 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 (and (indexed class) (not from-oid))
- (let ((class-index (find-class-index class)))
- (when class-index
- (setf (get-value oid class-index) instance))))
- ))))
+ ;; Inhibit indexing altogether 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 (and (indexed class) (not from-oid))
+ (let ((class-index (find-class-index class)))
+ (when class-index
+ (setf (get-value oid class-index) instance))))
+ ))))
+
+(defun initialize-persistent-slots (class instance persistent-slot-inits initargs)
+ (flet ((initialize-from-initarg (slot-def)
+ (loop for initarg in initargs
+ with slot-initargs = (slot-definition-initargs slot-def)
+ when (member initarg slot-initargs :test #'eq)
+ do
+ (setf (slot-value-using-class class instance slot-def)
+ (getf initargs initarg))
+ (return t))))
+ (with-transaction (:store-controller (get-con instance))
+ (loop for slot-def in (class-slots class)
+ unless (initialize-from-initarg slot-def)
+ when (member (slot-definition-name slot-def) persistent-slot-inits :test #'eq)
+ unless (slot-boundp-using-class class instance slot-def)
+ do
+ (let ((initfun (slot-definition-initfunction slot-def)))
+ (when initfun
+ (setf (slot-value-using-class class instance slot-def)
+ (funcall initfun))))))))
+
+;;
+;; CLASS REDEFINITION PROTOCOL
+;;
(defmethod update-instance-for-redefined-class :around ((instance persistent-object) added-slots discarded-slots property-list &rest initargs &key &allow-other-keys)
;; NOTE: probably should delete discarded slots, but we'll worry about that later
@@ -144,6 +174,10 @@
(apply #'shared-initialize instance new-persistent-slots initargs))
))
+;;
+;; CLASS CHANGE PROTOCOL
+;;
+
(defmethod update-instance-for-different-class :around ((previous persistent) (current persistent) &rest initargs &key)
(let* ((old-class (class-of previous))
(new-class (class-of current))
@@ -174,6 +208,10 @@
(call-next-method)))
+;;
+;; SLOT ACCESS PROTOCOLS
+;;
+
(defmethod slot-value-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition))
"Get the slot value from the database."
(declare (optimize (speed 3)))
@@ -256,21 +294,6 @@
(loop for writer in writers
do (make-persistent-writer writer slot-definition class class-name))))
-#+allegro
-(defmethod reinitialize-instance :around ((instance persistent-metaclass) &rest initargs &key &allow-other-keys)
- (declare (ignore initargs))
- (prog1
- (call-next-method)
- (when (class-finalized-p instance)
- (update-persistent-slots instance (persistent-slot-names instance))
- (update-indexed-record instance (indexed-slot-names-from-defs instance))
- (set-db-synch instance :class)
- (loop with persistent-slots = (persistent-slots instance)
- for slot-def in (class-direct-slots instance)
- when (member (slot-definition-name slot-def) persistent-slots)
- do (initialize-accessors slot-def instance))
- (make-instances-obsolete instance))))
-
;;
;; CMU / SBCL
;;
@@ -318,15 +341,3 @@
(make-persistent-slot-boundp name)))
slot-def)
-#+(or cmu sbcl openmcl)
-(defmethod reinitialize-instance :around ((instance persistent-metaclass) &rest initargs &key &allow-other-keys)
- (declare (ignore initargs))
- (prog1
- (call-next-method)
- (when (class-finalized-p instance)
- (update-persistent-slots instance (persistent-slot-names instance))
- (update-indexed-record instance (indexed-slot-names-from-defs instance))
- (set-db-synch instance :class)
-;; (initialize-internal-slot-functions
- (make-instances-obsolete instance))))
-
--- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2006/02/22 20:18:51 1.4
+++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2006/02/25 20:53:57 1.5
@@ -175,12 +175,14 @@
;; =============================
(defmethod enable-class-indexing ((class persistent-metaclass) indexed-slot-names &key (sc *store-controller*))
+ (assert (not (= 0 (length indexed-slot-names))))
(let ((croot (controller-class-root sc)))
(multiple-value-bind (btree found)
(get-value (class-name class) croot)
(declare (ignore btree))
(when found (error "Class is already enabled for indexing! Run disable class indexing to clean up.")))
;; Put class instance index into the class root & cache it in the class object
+ (update-indexed-record class indexed-slot-names)
(with-transaction (:store-controller sc)
(let ((class-idx (build-indexed-btree sc)))
(setf (get-value (class-name class) croot) class-idx)
@@ -200,31 +202,40 @@
(disable-class-indexing class :sc sc))))
(defmethod disable-class-indexing ((class persistent-metaclass) &key (sc *store-controller*) (errorp nil))
+ "Disable any class indices from the database, even if the current class object is not
+ officially indexed. This ensures there is no persistent trace of a class index. Storage
+ is reclaimed also"
(let ((class-idx (find-class-index class :sc sc :errorp errorp)))
- (unless class-idx (return-from disable-class-indexing nil))
- ;; Remove all instance key/value data from the class index (& secondary indices)
- (with-transaction (:store-controller sc)
- (with-btree-cursor (cur class-idx)
- (when (cursor-first cur)
- (loop while (cursor-delete cur)))))
- ;; Get the names of all indices & remove them
- (let ((names nil))
- (map-indices (lambda (name secondary-index)
- (declare (ignore secondary-index))
- (push name names))
- class-idx)
- (dolist (name names)
- (if (member name (class-slots class))
- (remove-class-slot-index class name)
- (with-transaction (:store-controller sc)
- (remove-index class-idx name)))))
- ;; Drop the class instance index from the class root
- (with-transaction (:store-controller sc)
- (remove-kv (class-name class) (controller-class-root sc)))
- (setf (%index-cache class) nil)
- ;; Clear out the current class
- (update-indexed-record class nil)
- ))
+ (if class-idx
+ (progn
+ (wipe-class-indexing class class-idx :sc sc)
+ (update-indexed-record class nil))
+ (when errorp
+ (error "No class index exists in persistent store ~A" sc)
+ (return-from disable-class-indexing nil)))))
+
+(defmethod wipe-class-indexing ((class persistent-metaclass) class-idx &key (sc *store-controller*))
+ ;; Clear out the current class record
+ (with-transaction (:store-controller sc)
+ (with-btree-cursor (cur class-idx)
+ (when (cursor-first cur)
+ (loop while (cursor-delete cur)))))
+ ;; Get the names of all indices & remove them
+ (let ((names nil))
+ (map-indices (lambda (name secondary-index)
+ (declare (ignore secondary-index))
+ (push name names))
+ class-idx)
+ (dolist (name names)
+ (if (member name (class-slots class))
+ (remove-class-slot-index class name)
+ (with-transaction (:store-controller sc)
+ (remove-index class-idx name)))))
+ ;; Drop the class instance index from the class root
+ (with-transaction (:store-controller sc)
+ (remove-kv (class-name class) (controller-class-root sc)))
+ (setf (%index-cache class) nil)
+ )
(defmethod add-class-slot-index ((class symbol) slot-name &key (sc *store-controller*))
(add-class-slot-index (find-class class) slot-name :sc sc))
--- /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2006/02/22 21:03:47 1.4
+++ /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2006/02/25 20:53:57 1.5
@@ -116,11 +116,14 @@
(defmethod indexed-record ((class standard-class))
nil)
+
(defmethod indexed-record ((class persistent-metaclass))
- (car (%indexed-slots class)))
+ (when (slot-boundp class '%indexed-slots)
+ (car (%indexed-slots class))))
(defmethod old-indexed-record ((class persistent-metaclass))
- (cdr (%indexed-slots class)))
+ (when (slot-boundp class '%indexed-slots)
+ (cdr (%indexed-slots class))))
(defmethod update-indexed-record ((class persistent-metaclass) new-slot-list)
(let ((oldrec (if (slot-boundp class '%indexed-slots)
@@ -132,6 +135,10 @@
:derived (when oldrec (indexing-record-derived oldrec)))
(if oldrec oldrec nil)))))
+(defmethod removed-indexing? ((class persistent-metaclass))
+ (and (not (indexed class))
+ (previously-indexed class)))
+
(defun indexed-slot-names-from-defs (class)
(let ((slot-definitions (class-slots class)))
(loop for slot-definition in slot-definitions
@@ -188,6 +195,14 @@
(or (indexing-record-slots (indexed-record class))
(indexing-record-derived (indexed-record class)))))
+(defmethod previously-indexed ((class persistent-metaclass))
+ (and (slot-boundp class '%indexed-slots)
+ (not (null (%indexed-slots class)))
+ (let ((old (old-indexed-record class)))
+ (when (not (null old))
+ (or (indexing-record-slots old)
+ (indexing-record-derived old))))))
+
(defmethod indexed ((slot standard-slot-definition)) nil)
(defmethod indexed ((class standard-class)) nil)
More information about the Elephant-cvs
mailing list