[elephant-cvs] CVS elephant/src
ieslick
ieslick at common-lisp.net
Fri Jan 27 18:52:49 UTC 2006
Update of /project/elephant/cvsroot/elephant/src
In directory common-lisp:/tmp/cvs-serv21689/src
Modified Files:
Tag: ELEPHANT-0-4-1-rc1-IAN
IAN-TODO classes.lisp indexing.lisp metaclasses.lisp
Log Message:
Latest stable point for everything except change-class and synching classes
to pre-existing repositories. Significantly cleaned up indexed-slot handling
in the metaclass to be less impactful on existing code.
--- /project/elephant/cvsroot/elephant/src/classes.lisp 2006/01/27 00:03:49 1.16.2.2
+++ /project/elephant/cvsroot/elephant/src/classes.lisp 2006/01/27 18:52:49 1.16.2.3
@@ -114,10 +114,12 @@
#+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))
(loop with persistent-slots = (persistent-slots instance)
for slot-def in (class-direct-slots instance)
when (member (slot-definition-name slot-def) persistent-slots)
@@ -126,6 +128,7 @@
#+(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)
@@ -140,11 +143,7 @@
(setf (%persistent-slots class)
(cons (persistent-slot-names class) nil)))
(when (not (slot-boundp class '%indexed-slots))
- (setf (%indexed-slots class)
- (cons (indexed-slot-names class) nil)))
- (when (not (slot-boundp class '%derived-index-count))
- (setf (%derived-index-count class) 0))))
-
+ (update-indexed-record class (indexed-slot-names-from-defs class)))))
;; #+(or cmu sbcl)
;; (defmethod finalize-inheritance :around ((instance persistent-metaclass))
@@ -201,6 +200,7 @@
(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
+ (declare (ignore property-list discarded-slots added-slots))
(prog1
(call-next-method)
;; (format t "persisent-slots ~A~%" (persistent-slots (class-of instance)))
@@ -253,8 +253,7 @@
(declare (optimize (speed 3)))
(let ((name (slot-definition-name slot-def)))
(persistent-slot-writer new-value instance name)
- (when (%indexed-p class)
- (update-class-index class instance))))
+ (update-index-on-write class instance slot-def)))
(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,19 +274,20 @@
(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))
- (ignore class))
- (if (sql-store-spec-p (:dbcn-spc-pst instance))
- (progn
+ (declare (optimize (speed 3)))
+ (when (indexed slot-def)
+ (unregister-indexed-slot class (slot-definition-name slot-def)))
+ (if (sql-store-spec-p (:dbcn-spc-pst instance))
+ (progn
(let* ((sc (check-con (:dbcn-spc-pst instance)))
(con (controller-db sc)))
- (sql-remove-from-root
- (form-slot-key (oid instance) (slot-definition-name slot-def))
- sc
- con
- )
- ))
- (with-buffer-streams (key-buf)
+ (sql-remove-from-root
+ (form-slot-key (oid instance) (slot-definition-name slot-def))
+ sc
+ con
+ )
+ ))
+ (with-buffer-streams (key-buf)
(buffer-write-int (oid instance) key-buf)
(serialize (slot-definition-name slot-def) key-buf)
(db-delete-buffered
@@ -304,3 +304,14 @@
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/metaclasses.lisp 2006/01/27 00:03:49 1.10.2.2
+++ /project/elephant/cvsroot/elephant/src/metaclasses.lisp 2006/01/27 18:52:49 1.10.2.3
@@ -46,6 +46,7 @@
(make-hash-table :test 'equal))
(defun connection-is-indeed-open (con)
+ (declare (ignore con))
t ;; I don't yet know how to implement this
)
@@ -89,13 +90,16 @@
(defclass persistent-metaclass (standard-class)
((%persistent-slots :accessor %persistent-slots)
(%indexed-slots :accessor %indexed-slots)
- (%derived-index-count :accessor %derived-index-count)
- (%instance-index :accessor %instance-index))
+ (%index-cache :accessor %index-cache))
(:documentation
"Metaclass for persistent classes. Use this metaclass to
define persistent classes. All slots are persistent by
default; use the :transient flag otherwise. Slots can also
-be indexed for by-value retrieval"))
+be indexed for by-value retrieval."))
+
+;;
+;; Persistent slot maintenance
+;;
(defmethod persistent-slots ((class persistent-metaclass))
(if (slot-boundp class '%persistent-slots)
@@ -117,30 +121,9 @@
nil)
)))
-(defmethod %indexed-p ((class persistent-metaclass))
- (or (and (slot-boundp class '%indexed-slots)
- (car (%indexed-slots class)))
- (and (slot-boundp class '%derived-index-count)
- (> (%derived-index-count class) 0))))
-
-(defmethod indexed-slots ((class persistent-metaclass))
- (car (%indexed-slots class)))
-
-(defmethod indexed-slots ((class standard-class))
- nil)
-
-(defmethod old-indexed-slots ((class persistent-metaclass))
- (cdr (%indexed-slots class)))
-
-(defmethod update-indexed-slots ((class persistent-metaclass) new-slot-list)
- (setf (%indexed-slots class) (cons new-slot-list
- (if (slot-boundp class '%indexed-slots)
- (car (%indexed-slots class))
- nil))))
-
(defclass persistent-slot-definition (standard-slot-definition)
- ())
+ ((indexed :accessor indexed :initarg :indexed :initform nil :allocation :instance)))
(defclass persistent-direct-slot-definition (standard-direct-slot-definition persistent-slot-definition)
())
@@ -157,16 +140,6 @@
(defclass transient-effective-slot-definition (standard-effective-slot-definition transient-slot-definition)
())
-
-(defclass indexed-slot-definition (persistent-slot-definition)
- ((indexed :initform t :initarg :indexed :allocation :class)))
-
-(defclass indexed-direct-slot-definition (persistent-direct-slot-definition indexed-slot-definition)
- ())
-
-(defclass indexed-effective-slot-definition (persistent-effective-slot-definition indexed-slot-definition)
- ())
-
(defgeneric transient (slot))
(defmethod transient ((slot standard-direct-slot-definition))
@@ -175,13 +148,101 @@
(defmethod transient ((slot persistent-direct-slot-definition))
nil)
-(defgeneric indexed (slot))
+;;
+;; Indexed slots maintenance
+;;
+
+;; This just encapsulates record keeping a bit
+(defclass indexing-record ()
+ ((slots :accessor indexing-record-slots :initarg :slots :initform nil)
+ (derived-count :accessor indexing-record-derived-count :initarg :derived-count :initform 0)))
+
+(defmethod print-object ((obj indexing-record) stream)
+ (format stream "#INDEXING-RECORD<islt: ~A dslt: ~A>"
+ (length (indexing-record-slots obj))
+ (indexing-record-derived-count obj)))
-(defmethod indexed ((slot standard-direct-slot-definition))
+(defmethod indexed-record ((class standard-class))
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)
+ nil)))
+ (setf (%indexed-slots class)
+ (cons (make-instance 'indexing-record
+ :slots new-slot-list
+ :derived-count (if oldrec (indexing-record-derived-count oldrec) 0))
+ (if oldrec oldrec nil)))))
-(defmethod indexed ((slot indexed-direct-slot-definition))
- t)
+(defun indexed-slot-names-from-defs (class)
+ (let ((slot-definitions (class-slots class)))
+ (loop for slot-definition in slot-definitions
+ when (and (subtypep (type-of slot-definition) 'persistent-slot-definition)
+ (indexed slot-definition))
+ collect (slot-definition-name slot-definition))))
+
+(defmethod register-indexed-slot ((class persistent-metaclass) slot)
+ "This method allows for post-definition update of indexed status of
+ class slots. It changes the effective method so we can rely on
+ generic function dispatch for differentated behavior"
+ ;; update record
+ (let ((record (indexed-record class)))
+ (unless (member slot (car (%persistent-slots class)))
+ (error "Tried to index slot ~A which isn't a persistent slot" slot))
+ (unless (member slot (indexing-record-slots record))
+;; This is a normal startup case, but during other cases we'd like
+;; the duplicate wraning
+;; (warn "Tried to index slot ~A which is already indexed" slot))
+ (push slot (indexing-record-slots record))))
+ ;; change effective slot def
+ (let ((slot-def (find-slot-def-by-name class slot)))
+ (unless slot-def
+ (error "Slot definition for slot ~A not found, inconsistent state in
+ class ~A" slot (class-name class)))
+ (setf (slot-value slot-def 'indexed) t)))
+
+(defmethod unregister-indexed-slot (class slot)
+ "Revert an indexed slot to it's original state"
+ ;; update record
+ (let ((record (indexed-record class)))
+ (unless (member slot (indexing-record-slots record))
+ (error "Tried to unregister slot ~A which is not indexed" slot))
+ (setf (indexing-record-slots record) (remove slot (indexing-record-slots record))))
+ ;; change effective slot def status
+ (let ((slot-def (find-slot-def-by-name class slot)))
+ (unless slot-def
+ (error "Slot definition for slot ~A not found, inconsistent state in
+ class ~A" slot (class-name class)))
+ (setf (slot-value slot-def 'indexed) nil)))
+
+(defmethod register-derived-index (class name)
+ "Tell the class that it has derived indices defined against it
+ and keep a reference count"
+ (declare (ignore name))
+ (let ((record (indexed-record class)))
+ (incf (indexing-record-derived-count record))))
+
+(defmethod unregister-derived-index (class name)
+ (declare (ignore name))
+ (let ((record (indexed-record class)))
+ (decf (indexing-record-derived-count record))
+ (assert (>= (indexing-record-derived-count record) 0))))
+
+(defmethod indexed ((class persistent-metaclass))
+ (and (slot-boundp class '%indexed-slots )
+ (or (indexing-record-slots (indexed-record class))
+ (not (= (indexing-record-derived-count (indexed-record class)) 0)))))
+
+(defmethod indexed ((slot standard-slot-definition)) nil)
+(defmethod indexed ((class standard-class)) nil)
+
+;;
+;; Original support for persistent slot protocol
+;;
#+allegro
(defmethod excl::valid-slot-allocation-list ((class persistent-metaclass))
@@ -204,8 +265,6 @@
(error "Persistent class slots are not supported, try :transient t."))
((and indexed-p transient-p)
(error "Cannot declare slots to be both transient and indexed"))
- (indexed-p
- (find-class 'indexed-direct-slot-definition))
(transient-p
(find-class 'transient-direct-slot-definition))
(t
@@ -239,8 +298,6 @@
(when (consp indexed-p) (setq indexed-p (car indexed-p)))
(cond ((and indexed-p transient-p)
(error "Cannot declare a slot to be both indexed and transient"))
- (indexed-p
- (find-class 'indexed-effective-slot-definition))
(transient-p
(find-class 'transient-effective-slot-definition))
(t
@@ -293,7 +350,9 @@
(if (ensure-transient-chain slot-definitions initargs)
(setf initargs (append initargs '(:transient t)))
(setf (getf initargs :allocation) :database))
- (if (some #'indexed slot-definitions)
+ ;; Effective slots are indexed only if the most recent slot definition
+ ;; is indexed. NOTE: Need to think more about inherited indexed slots
+ (if (indexed (first slot-definitions))
(append initargs '(:indexed t))
initargs)))
@@ -387,8 +446,3 @@
(loop for slot-definition in slot-definitions
unless (persistent-p slot-definition)
collect (slot-definition-name slot-definition))))
-
-(defun indexed-slot-names (class)
- (loop for slot-definition in (class-slots class)
- when (subtypep (type-of slot-definition) 'indexed-effective-slot-definition)
- collect (slot-definition-name slot-definition)))
More information about the Elephant-cvs
mailing list