[bknr-cvs] r2167 - trunk/bknr/src/data

[bknr at bknr.net]

Author: hhubner
Date: 2007-07-07 08:40:47 -0400 (Sat, 07 Jul 2007)
New Revision: 2167

Modified:
   trunk/bknr/src/data/TODO
   trunk/bknr/src/data/object.lisp
Log:
Fix for a problem reported by Kamen Tomov:  When restoring, slots marked
as transient would be re-initialized with whatever initarg they received
when the object was first created.  While the correct behavior could
be debated, it is certainly not right to persist the initialization values.
Thus, this patch filters out initargs for transient slots upon restore.


Modified: trunk/bknr/src/data/TODO
===================================================================
--- trunk/bknr/src/data/TODO	2007-07-04 18:18:40 UTC (rev 2166)
+++ trunk/bknr/src/data/TODO	2007-07-07 12:40:47 UTC (rev 2167)
@@ -4,9 +4,13 @@
 
 - tutorial fertig schreiben
 
-x die ganzen funktionen mit multiple stores mal zurecht refaktoren
-  fuer einen single store
+- import-image anschauen, nicht mehr failsafe
 
-- relaxed-references bei objekten
+- Revise and document make-object und initargs behaviour.  Upon
+restore, initargs for transient slots are ignored now, but this is not
+completely thought out.  It would better not to log initargs for
+transient slots in the first place.
 
-- import-image anschauen, nicht mehr failsafe
+- tx-persistent-change-class does not maintain indices
+
+- XXXX broken initialize-persistent-instance (?)

Modified: trunk/bknr/src/data/object.lisp
===================================================================
--- trunk/bknr/src/data/object.lisp	2007-07-04 18:18:40 UTC (rev 2166)
+++ trunk/bknr/src/data/object.lisp	2007-07-07 12:40:47 UTC (rev 2167)
@@ -1,7 +1,5 @@
 ;;; MOP based object subsystem for the BKNR datastore
 
-;;; XXX tx-persistent-change-class does not maintain indices
-
 (in-package :bknr.datastore)
 
 (cl-interpol:enable-interpol-syntax)
@@ -18,10 +16,19 @@
       (error "Could not find a store-object-subsystem in the current store ~a." *store*))
     subsystem))
 
-;;; eval-when in order to have store-object-with-id on compilation
 (defclass persistent-class (indexed-class)
-  ())
+  ((transient-slot-initargs :initform nil
+			    :accessor persistent-class-transient-slot-initargs)))
 
+(defmethod determine-transient-slot-initargs ((class persistent-class))
+  (with-slots (transient-slot-initargs) class
+    (setf transient-slot-initargs nil)
+    (dolist (slot (class-slots class))
+      (when (and (typep slot 'persistent-effective-slot-definition)
+		 (persistent-effective-slot-definition-transient slot)
+		 (slot-definition-initargs slot))
+	(pushnew (car (slot-definition-initargs slot)) transient-slot-initargs)))))
+
 (defmethod validate-superclass ((sub persistent-class) (super indexed-class))
   t)
 
@@ -32,8 +39,13 @@
     (warn "updating ~A instances of ~A for class changes" (length (class-instances class)) class))
   (mapc #'reinitialize-instance (class-instances class)))
 
+(defmethod instance :after ((class persistent-class) &rest args)
+  (declare (ignore args))
+  (determine-transient-slot-initargs class))
+
 (defmethod reinitialize-instance :after ((class persistent-class) &rest args)
   (declare (ignore args))
+  (determine-transient-slot-initargs class)
   (when *store*
     (update-instances-for-changed-class (class-name class))
     (unless *suppress-schema-warnings*
@@ -45,8 +57,11 @@
    (relaxed-object-reference :initarg :relaxed-object-reference :initform nil)))
 
 (defclass persistent-effective-slot-definition (index-effective-slot-definition)
-  ((transient :initarg :transient :initform nil)
-   (relaxed-object-reference :initarg :relaxed-object-reference :initform nil)))
+  ((transient :initarg :transient
+	      :initform nil
+	      :reader persistent-effective-slot-definition-transient)
+   (relaxed-object-reference :initarg :relaxed-object-reference
+			     :initform nil)))
 
 (defmethod persistent-slot-p ((slot standard-effective-slot-definition))
   nil)
@@ -130,7 +145,6 @@
 
 (defmethod initialize-instance :around
     ((object store-object) &key &allow-other-keys)
-  ;; XXXX broken initialize-persistent-instance
   (if (in-anonymous-transaction-p)
       (prog1
 	  (call-next-method)
@@ -536,17 +550,28 @@
 			     (format t "clearing indices for class ~A~%" (class-name class-name))
 			     (clear-class-indices class-name)))
 		       class-layouts))))))))
+
+(defun remove-transient-slot-initargs (class initializers)
+  "Remove all initializers for transient slots"
+  (loop for (keyword value) on initializers by #'cddr
+       unless (find keyword (persistent-class-transient-slot-initargs class))
+       collect keyword
+       and
+       collect value))
 	      
 ;;; create object transaction, should not be called from user code, as we have to give it
 ;;; a unique id in the initargs. After the object is created, the persistent and the
 ;;; transient instances are initialized
-(defun tx-make-object (class &rest initargs)
+(defun tx-make-object (class-name &rest initargs)
   (let (obj
 	(error t))
     (unwind-protect
-	 (progn
-	   (setf obj (apply #'make-instance class initargs))
-	   (unless (eq (store-state *store*) :restore)
+	 (let ((restoring (eq (store-state *store*) :restore)))
+	   (setf obj (apply #'make-instance class-name
+			    (if restoring
+				(remove-transient-slot-initargs (find-class class-name) initargs)
+				initargs)))
+	   (unless restoring
 	     (initialize-persistent-instance obj))
 	   (initialize-transient-instance obj)
 	   (setf error nil)
@@ -554,11 +579,11 @@
       (when (and error obj)
 	(destroy-object obj)))))
 
-(defun make-object (class &rest initargs)
-  "Make a persistent object of class CLASS. Calls MAKE-INSTANCE with INITARGS."
+(defun make-object (class-name &rest initargs)
+  "Make a persistent object of class named CLASS-NAME. Calls MAKE-INSTANCE with INITARGS."
   (execute (make-instance 'transaction
 			  :function-symbol 'tx-make-object
-			  :args (append (list class
+			  :args (append (list class-name
 					      :id (id-counter (store-object-subsystem)))
 					initargs))))