Author: hhubner Date: 2006-08-18 12:38:52 -0400 (Fri, 18 Aug 2006) New Revision: 1982 Modified: branches/xml-class-rework/bknr/src/data/object.lisp branches/xml-class-rework/bknr/src/data/package.lisp branches/xml-class-rework/bknr/src/indices/indexed-class.lisp branches/xml-class-rework/bknr/src/rss/rss.lisp Log: Add prepare-for-snapshot method for persistent objects. This method is called before a snapshot is written and allows the object to perform cleanup operations before it is written to the snapshot file. This can be used, for example, to remove references to destroyed objects which would not be a problem when restoring from a transaction log, but can't be restored from a snapshot. The rss module uses this to clean up the list of items in a channel. The item list may contain dangling references that are filtered out upon access to the item list. These dangling references are removed before a rss channel object is written to the snapshot file. Modified: branches/xml-class-rework/bknr/src/data/object.lisp =================================================================== --- branches/xml-class-rework/bknr/src/data/object.lisp 2006-08-14 12:57:02 UTC (rev 1981) +++ branches/xml-class-rework/bknr/src/data/object.lisp 2006-08-18 16:38:52 UTC (rev 1982) @@ -473,6 +473,8 @@ :if-does-not-exist :create :if-exists :supersede) (let ((class-layouts (make-hash-table))) + (with-transaction (:prepare-for-snapshot) + (map-store-objects #'prepare-for-snapshot)) (map-store-objects (lambda (object) (when (subtypep (type-of object) 'store-object) (encode-create-object class-layouts object s)))) (map-store-objects (lambda (object) (when (subtypep (type-of object) 'store-object) @@ -581,6 +583,10 @@ (loop for (slot value) on slots-and-values by #'cddr do (setf (slot-value object slot) value)))) +(defmethod prepare-for-snapshot (object) + nil) + + (defun find-store-object (id-or-name &key (class 'store-object) query-function key-slot-name) "mock up implementation of find-store-object api as in the old datastore" (unless id-or-name Modified: branches/xml-class-rework/bknr/src/data/package.lisp =================================================================== --- branches/xml-class-rework/bknr/src/data/package.lisp 2006-08-14 12:57:02 UTC (rev 1981) +++ branches/xml-class-rework/bknr/src/data/package.lisp 2006-08-18 16:38:52 UTC (rev 1982) @@ -62,6 +62,7 @@ #:store-objects-of-class #:all-store-objects #:map-store-objects + #:prepare-for-snapshot #:find-store-object #:create-object-transaction #:tx-make-object Modified: branches/xml-class-rework/bknr/src/indices/indexed-class.lisp =================================================================== --- branches/xml-class-rework/bknr/src/indices/indexed-class.lisp 2006-08-14 12:57:02 UTC (rev 1981) +++ branches/xml-class-rework/bknr/src/indices/indexed-class.lisp 2006-08-18 16:38:52 UTC (rev 1982) @@ -451,3 +451,4 @@ (slot-value object 'destroyed-p) (unbound-slot () nil) (simple-error () nil))) + Modified: branches/xml-class-rework/bknr/src/rss/rss.lisp =================================================================== --- branches/xml-class-rework/bknr/src/rss/rss.lisp 2006-08-14 12:57:02 UTC (rev 1981) +++ branches/xml-class-rework/bknr/src/rss/rss.lisp 2006-08-18 16:38:52 UTC (rev 1982) @@ -50,6 +50,9 @@ (max-item-age :update :initform (* 4 7 3600)) (items :update :initform nil))) +(defmethod prepare-for-snapshot ((channel rss-channel)) + (setf (rss-channel-items channel) (remove-if #'object-destroyed-p (rss-channel-items channel)))) + ;; Mixin for items (define-persistent-class rss-item () @@ -75,13 +78,18 @@ (dolist (slot '(title link description)) (render-mandatory-element channel slot)) - (dolist (item (remove-if-not #'rss-item-published (rss-channel-items channel))) + (dolist (item (remove-if-not #'(lambda (item) + (and (not (object-destroyed-p item)) + (rss-item-published item))) + (rss-channel-items channel))) (rss-item-xml item)))))) (defmethod rss-channel-items ((channel rss-channel)) "Return all non-expired items in channel." (let ((expiry-time (- (get-universal-time) (rss-channel-max-item-age channel)))) - (remove-if (lambda (item) (< (rss-item-pub-date item) expiry-time)) (slot-value channel 'items)))) + (remove-if (lambda (item) (or (object-destroyed-p item) + (< (rss-item-pub-date item) expiry-time))) + (slot-value channel 'items)))) (deftransaction rss-channel-cleanup (channel) "Remove expired items from the items list. Can be used to reduce