[elephant-cvs] CVS elephant/src
ieslick
ieslick at common-lisp.net
Sun Jan 29 04:57:21 UTC 2006
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)
More information about the Elephant-cvs
mailing list