[elephant-cvs] CVS update: elephant/src/classes.lisp
blee at common-lisp.net
blee at common-lisp.net
Fri Aug 27 02:53:53 UTC 2004
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
More information about the Elephant-cvs
mailing list