Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv23599/src
Modified Files: classes.lisp Log Message: new MOP stuff
Date: Thu Aug 26 19:53:52 2004 Author: blee
Index: elephant/src/classes.lisp diff -u elephant/src/classes.lisp:1.1.1.1 elephant/src/classes.lisp:1.2 --- elephant/src/classes.lisp:1.1.1.1 Thu Aug 19 10:05:14 2004 +++ elephant/src/classes.lisp Thu Aug 26 19:53:52 2004 @@ -1,35 +1,26 @@ +;; TODO: slot-bound-p (check the database) + (in-package "ELEPHANT")
(defclass persistent () ((%oid :accessor oid - :initarg :from-oid) - (%oid-string :accessor oid-string) - (%store-controller :allocation :class - :accessor get-store-controller - :initform *store-controller* - :initarg :store-controller) - (%class-name :type string :accessor %class-name - :allocation :class) - (%persistent-slots)) + :initarg :from-oid)) (:documentation "Abstract superclass for all persistent classes (common -to user-defined classes and collections.)" )) +to user-defined classes and collections.)"))
(defmethod initialize-instance :before ((instance persistent) &rest initargs &key from-oid) (declare (ignore initargs)) - "Sets the OID, OID-STRING and registers with the store controller." - (let ((sc (get-store-controller instance))) - (setf (%class-name instance) (string (class-name (class-of instance)))) - (if (not from-oid) - (setf (oid instance) (next-oid sc)) + "Sets the OID." + (if (not from-oid) + (setf (oid instance) (next-oid *store-controller*)) (setf (oid instance) from-oid)) - (setf (oid-string instance) - (prin1-to-string (oid instance))) - (register-instance sc instance))) + (cache-instance *store-controller* instance))
-(defclass persistent-class (persistent) () +(defclass persistent-object (persistent) + ((%persistent-slots)) (:documentation "Superclass of all user-defined persistent classes"))
@@ -46,7 +37,7 @@ ())
(defmethod pcl::slot-definition-allocation ((slot-definition persistent-slot-definition)) - :class) + :instance)
(defmethod (setf pcl::slot-definition-allocation) (value (slot-definition persistent-slot-definition)) (declare (ignore value)) @@ -55,10 +46,9 @@ (defmethod pcl::initialize-internal-slot-functions ((slot persistent-slot-definition)) nil)
-(defmethod pcl::direct-slot-definition-class ((class persistent-metaclass) initargs) +(defmethod pcl::direct-slot-definition-class ((class persistent-metaclass) &rest initargs) (let ((allocation-key (getf initargs :allocation))) - (cond ((or (eq allocation-key :transient) - (eq allocation-key :class)) + (cond ((eq allocation-key :class) (call-next-method)) (t (find-class 'persistent-direct-slot-definition))))) @@ -66,12 +56,68 @@ (defmethod pcl:validate-superclass ((class elephant::persistent-metaclass) (super pcl::standard-class)) t)
-(defmethod pcl::effective-slot-definition-class ((class persistent-metaclass) initargs) - (let ((allocation (getf initargs :allocation))) - (if (eq allocation :persistent) - (find-class 'persistent-effective-slot-definition) - (call-next-method)))) +(defmethod persistent-p ((class t)) + nil) + +(defmethod persistent-p ((class persistent-metaclass)) + t) + +(defmethod pcl::effective-slot-definition-class ((class persistent-metaclass) &rest initargs) + (let ((allocation-key (getf initargs :allocation)) + (allocation-class (getf initargs :allocation-class))) + (cond ((eq allocation-key :class) + (call-next-method)) + ((not (persistent-p allocation-class)) + (call-next-method)) + (t + (find-class 'persistent-effective-slot-definition)))))
+(defmacro make-persistent-reader (name) + `(lambda (instance) + (declare (type persistent instance)) + (buffer-write-int (oid instance) *key-buf*) + (let ((key-length (serialize ,name *key-buf*))) + (handler-case + (deserialize (db-get-key-buffered (db *store-controller*) + (buffer-stream-buffer *key-buf*) + key-length)) + (db-error (err) + (if (= (db-error-errno err) DB_NOTFOUND) + (error 'unbound-slot :instance instance :slot ,name) + (error err))))))) + +(defmacro make-persistent-writer (name) + `(lambda (new-value instance) + (declare (type persistent instance)) + (buffer-write-int (oid instance) *key-buf*) + (let ((key-length (serialize ,name *key-buf*)) + (val-length (serialize new-value *out-buf*))) + (db-put-buffered (db *store-controller*) + (buffer-stream-buffer *key-buf*) key-length + (buffer-stream-buffer *out-buf*) val-length + :transaction *current-transaction* + :auto-commit *auto-commit*)))) + +#| +(defmethod pcl::compute-slots :around ((class persistent-metaclass)) + (call-next-method)) +|# + +(defmethod handle-optimized-accessors ((slot-def t)) + slot-def) + +(defmethod handle-optimized-accessors ((slot-def persistent-slot-definition)) + (let ((name (pcl::slot-definition-name slot-def))) + (setf (pcl::slot-definition-reader-function slot-def) + (make-persistent-reader name)) + (setf (pcl::slot-definition-writer-function slot-def) + (make-persistent-writer name))) + slot-def) + +(defmethod pcl::compute-effective-slot-definition ((class persistent-metaclass) name direct-slot-definitions) + (let ((object (call-next-method))) + (handle-optimized-accessors object))) + (defun persistent-slot-names (class) (let ((slot-definitions (pcl::class-slots class))) (loop for slot-definition in slot-definitions @@ -82,63 +128,16 @@ (let* ((persistent-metaclass (find-class 'persistent-metaclass)) (not-already-persistent (loop for superclass in direct-superclasses never (eq (class-of superclass) persistent-metaclass)))) - (prog1 - (if not-already-persistent - (apply #'call-next-method class :direct-superclasses (cons (find-class 'persistent-class) direct-superclasses) args) - (call-next-method)) - (register-class-slots *store-controller* (class-name class) (persistent-slot-names class))))) + (if not-already-persistent + (apply #'call-next-method class :direct-superclasses (cons (find-class 'persistent-object) direct-superclasses) args) + (call-next-method))))
-(defmethod pcl::slot-value-using-class :around (class (instance persistent-class) (slot-def persistent-slot-definition)) +(defmethod pcl::slot-value-using-class :around (class (instance persistent-object) (slot-def persistent-slot-definition)) (let ((slot-name (pcl::slot-definition-name slot-def))) - (let ((db-slot-name (call-next-method))) - (if db-slot-name - (deserialize (db-get db-slot-name - (oid-string instance)) - *store-controller*) - nil)))) + (format *standard-output* "Deserializing ~A ~%" slot-name)))
-(defmethod (setf pcl::slot-value-using-class) :around (new-value class (instance persistent-class) (slot-def persistent-slot-definition)) +(defmethod (setf pcl::slot-value-using-class) :around (new-value class (instance persistent-object) (slot-def persistent-slot-definition)) (let ((slot-name (pcl::slot-definition-name slot-def))) - (let ((db-slot-name (slot-value-using-class class instance slot-def))) - (if db-slot-name - (%db-put db-slot-name - (oid-string instance) (serialize new-value) - :transaction *transaction*) - (call-next-method))))) - -;;; Need a delete class method! here's a first cut. -;;; however this method begs the question as to what the -;;; right transaction API is! (this can't be right!) + (format *standard-output* "Serializing ~A into ~A ~%" new-value slot-name)))
-#| -(defmethod delete ((obj persistent-class) &key transaction parent) - "Remove object from the database. Transaction protected." - (if transaction - (use-transaction (transaction) - (loop for slot in (%persistent-slots obj) - with slot-name = (if (listp slot) (first slot) - slot) - do (%db-remove (db-slot slot-name obj) (oid-string obj)))) - (with-transaction (parent :environment ???) - delete-stuff))) - -(defun db-slot (slotname obj) - (funcall (symbol-function (db-slot-from-slot slotname)) obj)) - -|#
-;;; These need to be fixed, macro-fied? -;;; meant to check for a transaction, do auto-commit otherwise -;;; this is necessary for transaction protected DB handles - -(defun %db-put (db key value &rest args &key (transaction *transaction*) - &allow-other-keys) - (if transaction - (apply #'db-put db key value :transaction transaction args) - (apply #'db-put db key value :auto-commit t args))) - -(defun %db-remove (db key &rest args &key (transaction *transaction*) - &allow-other-keys) - (if transaction - (apply #'db-delete db key :transaction transaction args) - (apply #'db-delete db key :auto-commit t args))) \ No newline at end of file