[bknr-cvs] r1982 - in branches/xml-class-rework/bknr/src: data indices rss

[bknr at bknr.net]

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