[bknr-cvs] hans changed trunk/bknr/datastore/src/data/

[BKNR Commits]

Revision: 3450
Author: hans
URL: http://bknr.net/trac/changeset/3450

Automatic recursive determination of last-change timestamp.  Also
store-object-touch.

U   trunk/bknr/datastore/src/data/object.lisp
U   trunk/bknr/datastore/src/data/package.lisp
U   trunk/bknr/datastore/src/data/txn.lisp

Modified: trunk/bknr/datastore/src/data/object.lisp
===================================================================
--- trunk/bknr/datastore/src/data/object.lisp	2008-07-15 13:14:17 UTC (rev 3449)
+++ trunk/bknr/datastore/src/data/object.lisp	2008-07-15 14:13:49 UTC (rev 3450)
@@ -90,7 +90,7 @@
       (error "Attempt to set persistent slot ~A of ~A outside of a transaction"
              slot-name object))
     (unless (eq 'last-change slot-name)
-      (setf (slot-value object 'last-change) (transaction-timestamp *current-transaction*)))))
+      (setf (slot-value object 'last-change) (current-transaction-timestamp)))))
 
 (defmethod (setf slot-value-using-class) :after (newval (class persistent-class) object slotd)
   (when (in-anonymous-transaction-p)
@@ -151,6 +151,40 @@
     (error "class-instances called for nonexistent class ~A" class))
   (store-objects-with-class class))
 
+(deftransaction store-object-touch (object)
+  "Update the LAST-CHANGE slot to reflect the current transaction timestamp."
+  (setf (slot-value object 'last-change) (current-transaction-timestamp)))
+
+(defgeneric store-object-last-change (object depth)
+  (:documentation "Return the last change time of the OBJECT.  DEPTH
+  determines how deep the object graph will be traversed.")
+
+  (:method (object depth)
+    0)
+
+  (:method ((object store-object) (depth (eql 0)))
+            (slot-value object 'last-change))
+
+  (:method ((object store-object) depth)
+    (let ((last-change (slot-value object 'last-change)))
+      (dolist (slotd (class-slots (class-of object)))
+        (let* ((slot-name (slot-definition-name slotd))
+               (child (and (slot-boundp object slot-name)
+                           (slot-value object slot-name))))
+          (setf last-change
+                (cond
+                  ((null child)
+                   last-change)
+                  ((typep child 'store-object)
+                   (max last-change (store-object-last-change child (1- depth))))
+                  ((listp child)
+                   (reduce #'max child
+                           :key (alexandria:rcurry 'store-object-last-change (1- depth))
+                           :initial-value last-change))
+                  (t
+                   last-change)))))
+      last-change)))
+
 #+allegro
 (aclmop::finalize-inheritance (find-class 'store-object))
 

Modified: trunk/bknr/datastore/src/data/package.lisp
===================================================================
--- trunk/bknr/datastore/src/data/package.lisp	2008-07-15 13:14:17 UTC (rev 3449)
+++ trunk/bknr/datastore/src/data/package.lisp	2008-07-15 14:13:49 UTC (rev 3450)
@@ -28,6 +28,7 @@
 	   #:transaction-function-symbol
 	   #:transaction-args
 	   #:transaction-timestamp
+           #:current-transaction-timestamp
 	   #:in-transaction-p
 	   #:deftransaction
 
@@ -42,6 +43,8 @@
 	   #:store-object
 	   #:store-object-store
 	   #:store-object-id
+           #:store-object-last-change
+           #:store-object-touch
 
 	   #:delete-object
 	   #:delete-objects

Modified: trunk/bknr/datastore/src/data/txn.lisp
===================================================================
--- trunk/bknr/datastore/src/data/txn.lisp	2008-07-15 13:14:17 UTC (rev 3449)
+++ trunk/bknr/datastore/src/data/txn.lisp	2008-07-15 14:13:49 UTC (rev 3450)
@@ -236,6 +236,9 @@
   (or *current-transaction*
       (eq :restore (store-state *store*))))
 
+(defun current-transaction-timestamp ()
+  (transaction-timestamp *current-transaction*))
+
 (defun store-open-p ()
   (not (eq :closed (store-state *store*))))