[bknr-cvs] hans changed trunk/
BKNR Commits
bknr at bknr.net
Wed Jul 30 11:21:33 UTC 2008
Revision: 3694
Author: hans
URL: http://bknr.net/trac/changeset/3694
back out 3685-3692, that was too much to swallow
U trunk/bknr/datastore/src/data/object-tests.lisp
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/build.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-tests.lisp
===================================================================
--- trunk/bknr/datastore/src/data/object-tests.lisp 2008-07-30 11:17:36 UTC (rev 3693)
+++ trunk/bknr/datastore/src/data/object-tests.lisp 2008-07-30 11:21:33 UTC (rev 3694)
@@ -47,7 +47,7 @@
(defvar *tests* (make-hash-table))
-(defmacro define-datastore-test (name &body body)
+(defmacro define-datastore-test (name &rest body)
`(setf (gethash ,name *tests*)
(make-instance 'datastore-test-class
:unit :datastore
@@ -118,14 +118,6 @@
(map-store-objects #'delete-object)))
(test-equal (all-store-objects) nil))
-(define-datastore-test :make-instance-in-anon-txn
- (with-transaction ()
- (make-instance 'store-object)))
-
-(define-datastore-test :make-object-in-anon-txn
- (with-transaction ()
- (make-object 'store-object)))
-
(define-persistent-class parent ()
((child :update :initform nil)))
Modified: trunk/bknr/datastore/src/data/object.lisp
===================================================================
--- trunk/bknr/datastore/src/data/object.lisp 2008-07-30 11:17:36 UTC (rev 3693)
+++ trunk/bknr/datastore/src/data/object.lisp 2008-07-30 11:21:33 UTC (rev 3694)
@@ -91,7 +91,7 @@
slot-name object))
(when (and (persistent-slot-p slotd)
(not (eq :restore (store-state *store*)))
- (not (member slot-name '(last-change id))))
+ (not (eq 'last-change slot-name)))
(setf (slot-value object 'last-change) (current-transaction-timestamp)))))
(defmethod (setf slot-value-using-class) :after (newval (class persistent-class) object slotd)
@@ -190,32 +190,36 @@
#+allegro
(aclmop::finalize-inheritance (find-class 'store-object))
-(defmethod initialize-instance :around ((object store-object) &rest initargs &key)
+(defmethod initialize-instance :around
+ ((object store-object) &key &allow-other-keys)
(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)) initargs))
+ :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)))))
(anonymous-transaction-log-buffer *current-transaction*)))
(call-next-method)))
-(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 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 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))))
@@ -240,13 +244,19 @@
: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 after a persistent object has been initialized, also
-when the object is loaded from a snapshot, but before reading the
-transaction log."))
+method is called whenever a persistent object is initialized, also
+when the object is loaded from a snapshot."))
+(defmethod initialize-persistent-instance ((object store-object) &key))
(defmethod initialize-transient-instance ((object store-object)))
(defmethod store-object-persistent-slots ((object store-object))
@@ -454,11 +464,7 @@
;; 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
- (setf (next-object-id (store-object-subsystem)) object-id)
- (let ((object (allocate-instance class)))
- (assert (= object-id (slot-value object 'id)))
- (dolist (index (class-slot-indices class 'id))
- (index-add index object)))))))
+ (make-instance class :id object-id)))))
(defun snapshot-read-slots (stream layouts)
(let* ((layout-id (%decode-integer stream))
@@ -635,21 +641,21 @@
(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."
- (if (in-anonymous-transaction-p)
- (apply #'make-instance class-name initargs)
- (with-store-guard ()
- (execute (make-instance 'transaction
- :function-symbol 'tx-make-object
- :args (append (list class-name
- :id (next-object-id (store-object-subsystem)))
- 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
+ :args (append (list class-name
+ :id (next-object-id (store-object-subsystem)))
+ initargs)))))
(defun tx-delete-object (id)
(destroy-object (store-object-with-id id)))
Modified: trunk/bknr/datastore/src/data/package.lisp
===================================================================
--- trunk/bknr/datastore/src/data/package.lisp 2008-07-30 11:17:36 UTC (rev 3693)
+++ trunk/bknr/datastore/src/data/package.lisp 2008-07-30 11:21:33 UTC (rev 3694)
@@ -51,6 +51,7 @@
#: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 11:17:36 UTC (rev 3693)
+++ trunk/bknr/datastore/src/data/tutorial.lisp 2008-07-30 11:21:33 UTC (rev 3694)
@@ -458,13 +458,14 @@
;;; 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-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
+;;; 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
;;; to the snapshot file) of a persistent object.
;;;
;;; We can define the following class with a transient and a
@@ -815,7 +816,9 @@
;;; 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.
+;;; 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.
;;;## Garbage collecting blobs
Modified: trunk/bknr/modules/feed/feed.lisp
===================================================================
--- trunk/bknr/modules/feed/feed.lisp 2008-07-30 11:17:36 UTC (rev 3693)
+++ trunk/bknr/modules/feed/feed.lisp 2008-07-30 11:21:33 UTC (rev 3694)
@@ -24,6 +24,9 @@
(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 11:17:36 UTC (rev 3693)
+++ trunk/bknr/modules/text/article.lisp 2008-07-30 11:21:33 UTC (rev 3694)
@@ -36,7 +36,7 @@
(article-subject article) " "
(article-text article))))
-(defmethod initialize-instance :after ((article article) &key)
+(defmethod initialize-persistent-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 11:17:36 UTC (rev 3693)
+++ trunk/bknr/web/src/rss/rss.lisp 2008-07-30 11:21:33 UTC (rev 3694)
@@ -176,7 +176,7 @@
(:method ((channel (eql nil)) item)
(warn "no RSS channel defined for item ~A" item)))
-(defmethod initialize-instance :after ((rss-item rss-item) &key)
+(defmethod initialize-persistent-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 11:17:36 UTC (rev 3693)
+++ trunk/bknr/web/src/sysclasses/user.lisp 2008-07-30 11:21:33 UTC (rev 3694)
@@ -60,7 +60,7 @@
(user-login object)
"unbound"))))
-(defmethod initialize-instance ((user user) &key)
+(defmethod initialize-persistent-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-instance ((user smb-user) &key)
+(defmethod initialize-persistent-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/build.lisp
===================================================================
--- trunk/build.lisp 2008-07-30 11:17:36 UTC (rev 3693)
+++ trunk/build.lisp 2008-07-30 11:21:33 UTC (rev 3694)
@@ -191,21 +191,21 @@
(zerop (nth-value 8 (5am::partition-results results)))))
(defun test ()
- (cl-gd::load-gd-glue)
+ (cl-gd::load-gd-glue)
(format t "~&;;; --- running tests~%")
(run-tests
- #+(or)
- (cl-ppcre-run-no-failures-p)
- (cl-gd-run-no-failures-p)
- #+(or)
- (flexi-streams-no-failures-p)
- (unit-test:run-all-tests)
- (rt:do-tests)
- (fiveam-run-no-failures-p :bknr.datastore)
- #-darwin (fiveam-run-no-failures-p :bos.test)
- (progn #+(or) (fiveam-run-no-failures-p :it.bese.FiveAM)
- (warn "skipping :it.bese.FiveAM tests")
- t)
- (fiveam-run-no-failures-p 'json-test::json)
- ))
+ #+(or)
+ (cl-ppcre-run-no-failures-p)
+ (cl-gd-run-no-failures-p)
+ #+(or)
+ (flexi-streams-no-failures-p)
+ (unit-test:run-all-tests)
+ (rt:do-tests)
+ (fiveam-run-no-failures-p :bknr.datastore)
+ #-darwin (fiveam-run-no-failures-p :bos.test)
+ (progn #+(or) (fiveam-run-no-failures-p :it.bese.FiveAM)
+ (warn "skipping :it.bese.FiveAM tests")
+ t)
+ (fiveam-run-no-failures-p 'json-test::json)
+ ))
Modified: trunk/projects/bos/m2/allocation.lisp
===================================================================
--- trunk/projects/bos/m2/allocation.lisp 2008-07-30 11:17:36 UTC (rev 3693)
+++ trunk/projects/bos/m2/allocation.lisp 2008-07-30 11:21:33 UTC (rev 3694)
@@ -34,7 +34,7 @@
:unbound)
(store-object-id allocation-area))))
-(defmethod initialize-instance :after ((allocation-area allocation-area) &key)
+(defmethod initialize-persistent-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 11:17:36 UTC (rev 3693)
+++ trunk/projects/bos/m2/m2.lisp 2008-07-30 11:21:33 UTC (rev 3694)
@@ -278,7 +278,7 @@
(defun contract-p (object)
(equal (class-of object) (find-class 'contract)))
-(defmethod initialize-instance :after ((contract contract) &key)
+(defmethod initialize-persistent-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 11:17:36 UTC (rev 3693)
+++ trunk/projects/bos/m2/poi.lisp 2008-07-30 11:21:33 UTC (rev 3694)
@@ -35,7 +35,7 @@
or description is given")
(apply #'make-object class-name rest))
-(defmethod initialize-instance :after ((poi-medium poi-medium) &key language title subtitle description poi)
+(defmethod initialize-persistent-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-instance :after ((poi poi) &key language title subtitle description)
+(defmethod initialize-persistent-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 11:17:36 UTC (rev 3693)
+++ trunk/projects/lisp-ecoop/src/participant.lisp 2008-07-30 11:21:33 UTC (rev 3694)
@@ -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-instance :after ((document document) &key)
+(defmethod initialize-persistent-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-instance :after ((participant participant) &key)
+(defmethod initialize-persistent-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 11:17:36 UTC (rev 3693)
+++ trunk/projects/unmaintained/raw-data/mcp/bluetooth.lisp 2008-07-30 11:21:33 UTC (rev 3694)
@@ -88,7 +88,7 @@
((device :initarg :device :reader bluetooth-event-device))
(:metaclass persistent-class))
-(defmethod initialize-instance :after ((event bluetooth-event) &key)
+(defmethod initialize-persistent-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 11:17:36 UTC (rev 3693)
+++ trunk/projects/unmaintained/raw-data/mcp/sensors.lisp 2008-07-30 11:21:33 UTC (rev 3694)
@@ -60,7 +60,7 @@
(defmethod sample-event-table-name ((sensor sensor))
(format nil "sample_event_~(~A~)" (sensor-type sensor)))
-(defmethod initialize-instance :after ((sensor sensor) &key)
+(defmethod initialize-persistent-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