[bknr-cvs] hans changed trunk/
BKNR Commits
bknr at bknr.net
Wed Jul 30 09:36:20 UTC 2008
Revision: 3689
Author: hans
URL: http://bknr.net/trac/changeset/3689
Remove INITIALIZE-PERSISTENT-INSTANCE, use INITIALIZE-INSTANCE
instead. During restore, use ALLOCATE-INSTANCE to reinstantiate
persistent objects.
U trunk/bknr/datastore/src/data/object.lisp
U trunk/bknr/datastore/src/data/package.lisp
U trunk/bknr/datastore/src/data/tutorial.lisp
U trunk/bknr/modules/feed/feed.lisp
U trunk/bknr/modules/text/article.lisp
U trunk/bknr/web/src/rss/rss.lisp
U trunk/bknr/web/src/sysclasses/user.lisp
U trunk/projects/bos/m2/allocation.lisp
U trunk/projects/bos/m2/m2.lisp
U trunk/projects/bos/m2/poi.lisp
U trunk/projects/lisp-ecoop/src/participant.lisp
U trunk/projects/unmaintained/raw-data/mcp/bluetooth.lisp
U trunk/projects/unmaintained/raw-data/mcp/sensors.lisp
Modified: trunk/bknr/datastore/src/data/object.lisp
===================================================================
--- trunk/bknr/datastore/src/data/object.lisp 2008-07-30 08:42:31 UTC (rev 3688)
+++ trunk/bknr/datastore/src/data/object.lisp 2008-07-30 09:36:20 UTC (rev 3689)
@@ -190,36 +190,32 @@
#+allegro
(aclmop::finalize-inheritance (find-class 'store-object))
-(defmethod initialize-instance :around
- ((object store-object) &key &allow-other-keys)
+(defmethod initialize-instance :around ((object store-object) &rest initargs &key)
(if (in-anonymous-transaction-p)
(prog1
(call-next-method)
(encode (make-instance 'transaction
:function-symbol 'make-instance
:timestamp (get-universal-time)
- :args (cons (class-name (class-of object))
- (loop for slotd in (class-slots (class-of object))
- for slot-name = (slot-definition-name slotd)
- for slot-initarg = (first (slot-definition-initargs slotd))
- when (and slot-initarg
- (slot-boundp object slot-name))
- appending (list slot-initarg (slot-value object slot-name)))))
+ :args (cons (class-name (class-of object)) initargs))
(anonymous-transaction-log-buffer *current-transaction*)))
(call-next-method)))
-(defmethod initialize-instance :after ((object store-object) &key id &allow-other-keys)
- (let ((subsystem (store-object-subsystem)))
- (cond (id
- ;; during restore, use the given ID
- (when (>= id (next-object-id subsystem))
- (setf (next-object-id subsystem) (1+ id))))
- (t
- ;; normal transaction: assign a new ID
- (setf id (next-object-id subsystem))
- (incf (next-object-id subsystem))
- (setf (slot-value object 'id) id)))))
+(defmethod allocate-instance :around ((class persistent-class) &key)
+ (let* ((object (call-next-method))
+ (subsystem (store-object-subsystem))
+ (id (next-object-id subsystem)))
+ (incf (next-object-id subsystem))
+ (setf (slot-value object 'id) id)
+ object))
+(defmethod initialize-instance :after ((object store-object) &key)
+ ;; This is called only when initially creating the (persistent)
+ ;; instance, not during restore. During restore, the
+ ;; INITIALIZE-TRANSIENT-INSTANCE function is called after the
+ ;; snapshot has been read, but before running the transaction log.
+ (initialize-transient-instance object))
+
(defmethod print-object ((object store-object) stream)
(print-unreadable-object (object stream :type t)
(format stream "ID: ~D" (store-object-id object))))
@@ -244,19 +240,13 @@
:timestamp (get-universal-time)
:args (append (list object (if (symbolp class) class (class-name class))) args))))
-(defgeneric initialize-persistent-instance (store-object &key &allow-other-keys)
- (:documentation
- "Initializes the persistent aspects of a persistent object. This
-method is called at the creation of a persistent object, but not when
-the object is loaded from a snapshot."))
-
(defgeneric initialize-transient-instance (store-object)
(:documentation
"Initializes the transient aspects of a persistent object. This
-method is called whenever a persistent object is initialized, also
-when the object is loaded from a snapshot."))
+method is called after a persistent object has been initialized, also
+when the object is loaded from a snapshot, but before reading the
+transaction log."))
-(defmethod initialize-persistent-instance ((object store-object) &key))
(defmethod initialize-transient-instance ((object store-object)))
(defmethod store-object-persistent-slots ((object store-object))
@@ -464,7 +454,10 @@
;; If the class is NIL, it was not found in the currently
;; running Lisp image and objects of this class will be ignored.
(when class
- (make-instance class :id object-id)))))
+ (let ((object (allocate-instance class)))
+ (dolist (index (class-slot-indices class 'id))
+ (assert (= object-id (slot-value object 'id)))
+ (index-add index object)))))))
(defun snapshot-read-slots (stream layouts)
(let* ((layout-id (%decode-integer stream))
@@ -641,15 +634,13 @@
(if restoring
(remove-transient-slot-initargs (find-class class-name) initargs)
initargs)))
- (apply #'initialize-persistent-instance obj initargs)
- (initialize-transient-instance obj)
(setf error nil)
obj)
(when (and error obj)
(destroy-object obj)))))
(defun make-object (class-name &rest initargs)
- "Make a persistent object of class named CLASS-NAME. Calls MAKE-INSTANCE with INITARGS."
+ "Make a persistent object of class named CLASS-NAME. Calls MAKE-INSTANCE with INITARGS."
(with-store-guard ()
(execute (make-instance 'transaction
:function-symbol 'tx-make-object
Modified: trunk/bknr/datastore/src/data/package.lisp
===================================================================
--- trunk/bknr/datastore/src/data/package.lisp 2008-07-30 08:42:31 UTC (rev 3688)
+++ trunk/bknr/datastore/src/data/package.lisp 2008-07-30 09:36:20 UTC (rev 3689)
@@ -51,7 +51,6 @@
#:cascade-delete-p
#:cascading-delete-object
- #:initialize-persistent-instance
#:initialize-transient-instance
#:store-object-with-id
Modified: trunk/bknr/datastore/src/data/tutorial.lisp
===================================================================
--- trunk/bknr/datastore/src/data/tutorial.lisp 2008-07-30 08:42:31 UTC (rev 3688)
+++ trunk/bknr/datastore/src/data/tutorial.lisp 2008-07-30 09:36:20 UTC (rev 3689)
@@ -458,14 +458,13 @@
;;; Persistent objects have the metaclass `PERSISTENT-CLASS', and have
;;; to be created using the function `MAKE-OBJECT'. This creates an
;;; instance of the object inside a transaction, sets its ID slot
-;;; appropriately, and then calls `INITIALIZE-PERSISTENT-INSTANCE' and
-;;; `INITIALIZE-TRANSIENT-INSTANCE'. The first method is called when
-;;; the object is created inside a transaction, but not if the object
-;;; is being restored from the snapshot file. This method has to be
-;;; overridden in order to initialize persistent
-;;; slots. `INITIALIZE-TRANSIENT-INSTANCE' is called at object
-;;; creation inside a transaction and at object creation during
-;;; restore. It is used to initialize the transient slots (not logged
+;;; appropriately, and then calls `INITIALIZE-TRANSIENT-INSTANCE'. The
+;;; standard CLOS function `INITIALIZE-INSTANCE' is called when the
+;;; object is created inside a transaction, but not if the object is
+;;; being restored from the snapshot file.
+;;; `INITIALIZE-TRANSIENT-INSTANCE' is called at object creation
+;;; inside a transaction and at object creation during restore. It
+;;; must be specialized to initialize the transient slots (not logged
;;; to the snapshot file) of a persistent object.
;;;
;;; We can define the following class with a transient and a
@@ -816,9 +815,7 @@
;;; resolved (check the section about relaxed references). Finally,
;;; after each slot value has been set, the method
;;; `INITIALIZE-TRANSIENT-INSTANCE' is called for each created
-;;; object. The method `INITIALIZE-PERSISTENT-INSTANCE' is not called,
-;;; as it has to be executed only once at the time the persistent
-;;; object is created.
+;;; object.
;;;## Garbage collecting blobs
Modified: trunk/bknr/modules/feed/feed.lisp
===================================================================
--- trunk/bknr/modules/feed/feed.lisp 2008-07-30 08:42:31 UTC (rev 3688)
+++ trunk/bknr/modules/feed/feed.lisp 2008-07-30 09:36:20 UTC (rev 3689)
@@ -24,9 +24,6 @@
(type :update :documentation "(or :rss091 :rss10 :rss20 :atom)")
(encoding :update :initform :iso-8859-1 :documentation "(or :utf8 :iso-8859-1)")))
-;(defmethod initialize-transient-instance ((feed feed))
-; (ignore-errors (update-feed feed)))
-
(defmethod print-object ((object feed) stream)
(format stream "#<~a ID: ~A \"~a\">"
(class-name (class-of object))
Modified: trunk/bknr/modules/text/article.lisp
===================================================================
--- trunk/bknr/modules/text/article.lisp 2008-07-30 08:42:31 UTC (rev 3688)
+++ trunk/bknr/modules/text/article.lisp 2008-07-30 09:36:20 UTC (rev 3689)
@@ -36,7 +36,7 @@
(article-subject article) " "
(article-text article))))
-(defmethod initialize-persistent-instance :after ((article article) &key)
+(defmethod initialize-instance :after ((article article) &key)
(setf (article-search-vector article)
(article-to-search-vector article)))
Modified: trunk/bknr/web/src/rss/rss.lisp
===================================================================
--- trunk/bknr/web/src/rss/rss.lisp 2008-07-30 08:42:31 UTC (rev 3688)
+++ trunk/bknr/web/src/rss/rss.lisp 2008-07-30 09:36:20 UTC (rev 3689)
@@ -176,7 +176,7 @@
(:method ((channel (eql nil)) item)
(warn "no RSS channel defined for item ~A" item)))
-(defmethod initialize-persistent-instance :after ((rss-item rss-item) &key)
+(defmethod initialize-instance :after ((rss-item rss-item) &key)
(add-item (rss-item-channel rss-item) rss-item))
(defmethod destroy-object :before ((rss-item rss-item))
Modified: trunk/bknr/web/src/sysclasses/user.lisp
===================================================================
--- trunk/bknr/web/src/sysclasses/user.lisp 2008-07-30 08:42:31 UTC (rev 3688)
+++ trunk/bknr/web/src/sysclasses/user.lisp 2008-07-30 09:36:20 UTC (rev 3689)
@@ -60,7 +60,7 @@
(user-login object)
"unbound"))))
-(defmethod initialize-persistent-instance ((user user) &key)
+(defmethod initialize-instance ((user user) &key)
(let* ((plaintext-password (slot-value user 'password))
(password (when plaintext-password (crypt-md5 plaintext-password (make-salt)))))
(setf (slot-value user 'password) password)))
@@ -72,7 +72,7 @@
(define-persistent-class smb-user (user)
())
-(defmethod initialize-persistent-instance ((user smb-user) &key)
+(defmethod initialize-instance ((user smb-user) &key)
(let* ((plaintext-password (slot-value user 'password)))
(when plaintext-password
(set-smb-password (user-login user) plaintext-password))
Modified: trunk/projects/bos/m2/allocation.lisp
===================================================================
--- trunk/projects/bos/m2/allocation.lisp 2008-07-30 08:42:31 UTC (rev 3688)
+++ trunk/projects/bos/m2/allocation.lisp 2008-07-30 09:36:20 UTC (rev 3689)
@@ -34,7 +34,7 @@
:unbound)
(store-object-id allocation-area))))
-(defmethod initialize-persistent-instance :after ((allocation-area allocation-area) &key)
+(defmethod initialize-instance :after ((allocation-area allocation-area) &key)
(with-slots (total-m2s free-m2s) allocation-area
(setf total-m2s (calculate-total-m2-count allocation-area))
(setf free-m2s (- total-m2s (calculate-allocated-m2-count allocation-area))))
Modified: trunk/projects/bos/m2/m2.lisp
===================================================================
--- trunk/projects/bos/m2/m2.lisp 2008-07-30 08:42:31 UTC (rev 3688)
+++ trunk/projects/bos/m2/m2.lisp 2008-07-30 09:36:20 UTC (rev 3689)
@@ -278,7 +278,7 @@
(defun contract-p (object)
(equal (class-of object) (find-class 'contract)))
-(defmethod initialize-persistent-instance :after ((contract contract) &key)
+(defmethod initialize-instance :after ((contract contract) &key)
(pushnew contract (sponsor-contracts (contract-sponsor contract)))
(dolist (m2 (contract-m2s contract))
(setf (m2-contract m2) contract))
Modified: trunk/projects/bos/m2/poi.lisp
===================================================================
--- trunk/projects/bos/m2/poi.lisp 2008-07-30 08:42:31 UTC (rev 3688)
+++ trunk/projects/bos/m2/poi.lisp 2008-07-30 09:36:20 UTC (rev 3689)
@@ -35,7 +35,7 @@
or description is given")
(apply #'make-object class-name rest))
-(defmethod initialize-persistent-instance :after ((poi-medium poi-medium) &key language title subtitle description poi)
+(defmethod initialize-instance :after ((poi-medium poi-medium) &key language title subtitle description poi)
(when poi
(push poi-medium (poi-media poi)))
(update-textual-attributes poi-medium language
@@ -84,7 +84,7 @@
(setf (slot-string poi 'description language) description)
poi))
-(defmethod initialize-persistent-instance :after ((poi poi) &key language title subtitle description)
+(defmethod initialize-instance :after ((poi poi) &key language title subtitle description)
(update-textual-attributes poi language
:title title
:subtitle subtitle
Modified: trunk/projects/lisp-ecoop/src/participant.lisp
===================================================================
--- trunk/projects/lisp-ecoop/src/participant.lisp 2008-07-30 08:42:31 UTC (rev 3688)
+++ trunk/projects/lisp-ecoop/src/participant.lisp 2008-07-30 09:36:20 UTC (rev 3689)
@@ -7,7 +7,7 @@
(submission :read :documentation "Submission that this document belongs to"))
(:default-initargs :type "application/pdf" :submission (error ":submission argument missing while creating document")))
-(defmethod initialize-persistent-instance :after ((document document) &key)
+(defmethod initialize-instance :after ((document document) &key)
(with-slots (submission) document
(push document (submission-documents submission))))
@@ -92,7 +92,7 @@
#'(lambda (&rest more)
(apply fun (append args more))))
-(defmethod initialize-persistent-instance :after ((participant participant) &key)
+(defmethod initialize-instance :after ((participant participant) &key)
(make-email-list))
(defun make-email-list ()
Modified: trunk/projects/unmaintained/raw-data/mcp/bluetooth.lisp
===================================================================
--- trunk/projects/unmaintained/raw-data/mcp/bluetooth.lisp 2008-07-30 08:42:31 UTC (rev 3688)
+++ trunk/projects/unmaintained/raw-data/mcp/bluetooth.lisp 2008-07-30 09:36:20 UTC (rev 3689)
@@ -88,7 +88,7 @@
((device :initarg :device :reader bluetooth-event-device))
(:metaclass persistent-class))
-(defmethod initialize-persistent-instance :after ((event bluetooth-event) &key)
+(defmethod initialize-instance :after ((event bluetooth-event) &key)
(with-slots (device) event
(push event (bluetooth-device-events device))
(setf (sample-event-value event) (or (bluetooth-device-name device) (bluetooth-device-mac-address device)))))
Modified: trunk/projects/unmaintained/raw-data/mcp/sensors.lisp
===================================================================
--- trunk/projects/unmaintained/raw-data/mcp/sensors.lisp 2008-07-30 08:42:31 UTC (rev 3688)
+++ trunk/projects/unmaintained/raw-data/mcp/sensors.lisp 2008-07-30 09:36:20 UTC (rev 3689)
@@ -60,7 +60,7 @@
(defmethod sample-event-table-name ((sensor sensor))
(format nil "sample_event_~(~A~)" (sensor-type sensor)))
-(defmethod initialize-persistent-instance :after ((sensor sensor) &key)
+(defmethod initialize-instance :after ((sensor sensor) &key)
(let ((id (store-object-id sensor)))
(with-slots (name unit type) sensor
(postgres-execute
More information about the Bknr-cvs
mailing list