Update of /project/elephant/cvsroot/elephant/src In directory common-lisp:/tmp/cvs-serv15072/src
Modified Files: Tag: ELEPHANT-0-4-1-rc1-IAN IAN-TODO classes.lisp collections.lisp controller.lisp elephant.lisp indexing.lisp metaclasses.lisp Log Message: First pass complete indexing solution including basic tests.
--- /project/elephant/cvsroot/elephant/src/classes.lisp 2006/01/27 18:52:49 1.16.2.3 +++ /project/elephant/cvsroot/elephant/src/classes.lisp 2006/01/29 04:57:20 1.16.2.4 @@ -120,6 +120,7 @@ (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) @@ -133,6 +134,8 @@ (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) (make-instances-obsolete instance))))
;; #+allegro @@ -153,6 +156,8 @@ ;; (setf (%persistent-slots instance) ;; (cons (persistent-slot-names instance) nil)))))
+;; ISE: Not necessary for allegro 7.0? Initial values are written twice when I traced (setf slot-value-using-class) +#-allegro (defmethod shared-initialize :around ((instance persistent-object) slot-names &rest initargs &key &allow-other-keys) "Initializes the persistent slots via initargs or forms. This seems to be necessary because it is typical for @@ -199,18 +204,16 @@ (apply #'call-next-method instance transient-slot-inits initargs))))))
(defmethod update-instance-for-redefined-class :around ((instance persistent-object) added-slots discarded-slots property-list &rest initargs &key &allow-other-keys) - ;; probably should delete discarded slots, but we'll worry about that later + ;; NOTE: probably should delete discarded slots, but we'll worry about that later (declare (ignore property-list discarded-slots added-slots)) (prog1 (call-next-method) -;; (format t "persisent-slots ~A~%" (persistent-slots (class-of instance))) -;; (format t "slot-boundp ~A~%" (slot-boundp instance '%persistent-slots)) (let* ((class (class-of instance)) (new-persistent-slots (set-difference (persistent-slots class) (old-persistent-slots class)))) - + ;; Update new persistent slots, the others we get for free (same oid!) + ;; Isn't this done by the default call-next-method? (apply #'shared-initialize instance new-persistent-slots initargs)) -;; (format t "slot-boundp ~A~%" (slot-boundp instance '%persistent-slots)) ) )
@@ -231,7 +234,9 @@ when (not (persistent-slot-boundp previous slot-name)) collect slot-name)) (retained-persistent-slots (set-difference raw-retained-persistent-slots retained-unbound-slots))) + ;; Apply default values for unbound & new slots (updates class index) (apply #'shared-initialize current (append new-persistent-slots retained-unbound-slots) initargs) + ;; Copy values from old class (NOTE: should delete discarded slots?) (updates class index) (loop for slot-def in (class-slots new-class) when (member (slot-definition-name slot-def) retained-persistent-slots) do (setf (slot-value-using-class new-class @@ -240,6 +245,9 @@ (slot-value-using-class old-class previous (find-slot-def-by-name old-class (slot-definition-name slot-def))))) + ;; Delete this instance from its old class index, if exists + (when (indexed old-class) + (remove-kv (oid previous) (find-class-index old-class))) (call-next-method)))
(defmethod slot-value-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) @@ -248,12 +256,21 @@ (let ((name (slot-definition-name slot-def))) (persistent-slot-reader instance name)))
+;; ORIGINAL METHOD +;; (defmethod (setf slot-value-using-class) :around (new-value (class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) +;; "Set the slot value in the database." +;; (declare (optimize (speed 3))) +;; (let ((name (slot-definition-name slot-def))) +;; (persistent-slot-writer new-value instance name))) + +;; SUPPORT FOR INVERTED INDEXES (defmethod (setf slot-value-using-class) :around (new-value (class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Set the slot value in the database." (declare (optimize (speed 3))) - (let ((name (slot-definition-name slot-def))) - (persistent-slot-writer new-value instance name) - (update-index-on-write class instance slot-def))) + (if (indexed class) + (indexed-slot-writer class instance slot-def new-value) + (let ((name (slot-definition-name slot-def))) + (persistent-slot-writer new-value instance name))))
(defmethod slot-boundp-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Checks if the slot exists in the database." @@ -275,6 +292,7 @@ (defmethod slot-makunbound-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Deletes the slot from the database." (declare (optimize (speed 3))) + ;; NOTE: call remove-indexed-slot here instead? (when (indexed slot-def) (unregister-indexed-slot class (slot-definition-name slot-def))) (if (sql-store-spec-p (:dbcn-spc-pst instance)) @@ -304,14 +322,3 @@ finally (if (typep slot 'persistent-slot-definition) (slot-makunbound-using-class class instance slot) (call-next-method)))) - -;; Index update interface (used in functions above) - -(defmethod update-index-on-write ((class persistent-metaclass) (instance persistent-object) (slot persistent-slot-definition)) - "Anything that side effects a persistent-object slot should call this to keep - the dependant indices in synch. Only classes with derived indices need to - update on writes to non-persistent slots. update-class-index is implemented - by the subsystem that maintains the index" - (when (or (slot-value slot 'indexed) - (> (indexing-record-derived-count (indexed-record class)) 0)) - (update-class-index class instance))) --- /project/elephant/cvsroot/elephant/src/collections.lisp 2006/01/26 04:03:44 1.13.2.1 +++ /project/elephant/cvsroot/elephant/src/collections.lisp 2006/01/29 04:57:20 1.13.2.2 @@ -297,6 +297,7 @@ (multiple-value-bind (index? secondary-key) (funcall (key-fn index) index key value) (when index? + ;; Manually write value into secondary index (buffer-write-int (oid index) secondary-buf) (serialize secondary-key secondary-buf) ;; should silently do nothing if the key/value already --- /project/elephant/cvsroot/elephant/src/controller.lisp 2006/01/26 04:03:44 1.14.2.1 +++ /project/elephant/cvsroot/elephant/src/controller.lisp 2006/01/29 04:57:20 1.14.2.2 @@ -130,6 +130,10 @@ "Close the db handles and environment. Tries to wipe out references to the db handles."))
+(defgeneric reset-instance-cache (sc) + (:documentation + "Creates an empty object cache by replacing the existing cache.")) + (defgeneric build-btree (sc) (:documentation "Construct a btree of the appropriate type corresponding to this store-controller.")) @@ -345,6 +349,10 @@
sc)))
+(defmethod reset-instance-cache ((sc store-controller)) + (setf (instance-cache sc) + (make-cache-table :test 'eql))) + (defmethod close-controller ((sc bdb-store-controller)) (when (slot-value sc 'root) ;; no root --- /project/elephant/cvsroot/elephant/src/elephant.lisp 2006/01/25 16:58:25 1.18 +++ /project/elephant/cvsroot/elephant/src/elephant.lisp 2006/01/29 04:57:20 1.18.2.1 @@ -113,6 +113,24 @@ #:db-env-set-timeout #:db-env-get-timeout #:db-env-set-flags #:db-env-get-flags #:run-elephant-thread + + ;; Class indexing management API + #:*default-indexed-class-synch-policy* + #:find-class-index #:find-inverted-index + #:enable-class-indexing #:disable-class-indexing + #:add-class-slot-index #:remove-class-slot-index + #:add-class-derived-index #:remove-class-derived-index + #:describe-db-class-index + + ;; Low level cursor API + #:make-inverted-cursor #:make-class-cursor + #:with-inverted-cursor #:with-class-cursor + + ;; Instance query API + #:get-instances-by-class + #:get-instances-by-value + #:get-instances-by-range + #:drop-instances ) #+cmu (:import-from :pcl --- /project/elephant/cvsroot/elephant/src/metaclasses.lisp 2006/01/27 18:52:49 1.10.2.3 +++ /project/elephant/cvsroot/elephant/src/metaclasses.lisp 2006/01/29 04:57:20 1.10.2.4 @@ -104,8 +104,7 @@ (defmethod persistent-slots ((class persistent-metaclass)) (if (slot-boundp class '%persistent-slots) (car (%persistent-slots class)) - nil) - (car (%persistent-slots class))) + nil))
(defmethod persistent-slots ((class standard-class)) nil) @@ -166,8 +165,10 @@ nil) (defmethod indexed-record ((class persistent-metaclass)) (car (%indexed-slots class))) + (defmethod old-indexed-record ((class persistent-metaclass)) (cdr (%indexed-slots class))) + (defmethod update-indexed-record ((class persistent-metaclass) new-slot-list) (let ((oldrec (if (slot-boundp class '%indexed-slots) (indexed-record class)