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