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)