[cl-prevalence-cvs] CVS update: cl-prevalence/src/prevalence.lisp

[Sven Van Caekenberghe]

Update of /project/cl-prevalence/cvsroot/cl-prevalence/src
In directory common-lisp.net:/tmp/cvs-serv17101/src

Modified Files:
	prevalence.lisp 
Log Message:
introduced transaction-hook
turned *serialization-state* into an instance variable in prevalence-system
bugfixes to filenaming methods

Date: Mon Jun 28 04:56:35 2004
Author: scaekenberghe

Index: cl-prevalence/src/prevalence.lisp
diff -u cl-prevalence/src/prevalence.lisp:1.4 cl-prevalence/src/prevalence.lisp:1.5
--- cl-prevalence/src/prevalence.lisp:1.4	Sun Jun 27 09:37:10 2004
+++ cl-prevalence/src/prevalence.lisp	Mon Jun 28 04:56:35 2004
@@ -1,6 +1,6 @@
 ;;;; -*- mode: Lisp -*-
 ;;;;
-;;;; $Id: prevalence.lisp,v 1.4 2004/06/27 16:37:10 scaekenberghe Exp $
+;;;; $Id: prevalence.lisp,v 1.5 2004/06/28 11:56:35 scaekenberghe Exp $
 ;;;;
 ;;;; Object Prevalence in Common Lisp
 ;;;;
@@ -96,7 +96,14 @@
    (file-extension ;; type string
                    :accessor get-file-extension
                    :initarg :file-extension 
-                   :initform "xml"))
+                   :initform "xml")
+   (serialization-state ;; type serialization-state
+                        :reader get-serialization-state
+                        :initform (make-serialization-state))
+   (transaction-hook ;; type function
+                     :accessor get-transaction-hook
+                     :initarg :transaction-hook
+                     :initform #'identity))
   (:documentation "Base Prevalence system implementation object"))
 
 (defclass guarded-prevalence-system (prevalence-system)
@@ -190,8 +197,6 @@
 (defmethod remove-root-object ((system prevalence-system) name)
   (remhash name (get-root-objects system)))
 
-(defparameter *serialization-state* (make-serialization-state))
-
 (defmethod execute ((system prevalence-system) (transaction transaction))
   "Execute a transaction on a system and log it to the transaction log"
   (let ((result
@@ -202,13 +207,21 @@
                                              ";; Notice: system rollback/restore due to error (~a)~%" 
                                              condition)
 				     (restore system)))))
-	   (execute-on transaction system)))
-	 (out (get-transaction-log-stream system)))
-    (funcall (get-serializer system) transaction out *serialization-state*)
-    (terpri out)
-    (finish-output out)
+	   (execute-on transaction system))))
+    (log-transaction system transaction)
     result))
 
+(defmethod log-transaction ((system prevalence-system) (transaction transaction))
+  "Log transaction for system"
+  (let ((out (get-transaction-log-stream system)))
+    (funcall (get-serializer system) transaction out (get-serialization-state system))
+    (terpri out)
+    (finish-output out)))
+
+(defmethod log-transaction :after ((system prevalence-system) (transaction transaction))
+  "Execute the transaction-hook"
+  (funcall (get-transaction-hook system) transaction))
+
 (defmethod query ((system prevalence-system) function &rest args)
   "Execute an exclusive query function on a sytem"
   (apply function (cons system args)))
@@ -230,7 +243,7 @@
                                            snapshot)))
     (with-open-file (out snapshot
 			 :direction :output :if-does-not-exist :create :if-exists :supersede)
-      (funcall (get-serializer system) (get-root-objects system) out *serialization-state*))
+      (funcall (get-serializer system) (get-root-objects system) out (get-serialization-state system)))
     (when (probe-file transaction-log)
       (copy-file transaction-log (merge-pathnames (make-pathname :name (get-transaction-log-filename timetag)
                                                                  :type (get-file-extension system))
@@ -261,7 +274,7 @@
   (close-open-streams system)
   (when (probe-file (get-snapshot system))
     (with-open-file (in (get-snapshot system) :direction :input)
-      (setf (get-root-objects system) (funcall (get-deserializer system) in *serialization-state*))))
+      (setf (get-root-objects system) (funcall (get-deserializer system) in (get-serialization-state system)))))
   (when (probe-file (get-transaction-log system))
     (let ((position 0))
       (handler-bind ((s-xml:xml-parser-error 
@@ -273,7 +286,7 @@
                           (return-from restore))))
 	(with-open-file (in (get-transaction-log system) :direction :input)
 	  (loop
-	   (let ((transaction (funcall (get-deserializer system) in *serialization-state*)))
+	   (let ((transaction (funcall (get-deserializer system) in (get-serialization-state system))))
 	     (setf position (file-position in))
 	     (if transaction
 		 (execute-on transaction system)
@@ -316,11 +329,11 @@
 
 (defmethod get-transaction-log-filename ((system prevalence-system) &optional suffix)
   "Return the name of the transaction-log filename, optionally using a suffix"
-  (format nil "transaction-log@[-~a]" suffix))
+  (format nil "transaction-log~@[-~a~]" suffix))
 
 (defmethod get-snapshot-filename ((system prevalence-system) &optional suffix)
   "Return the name of the snapshot filename, optionally using a suffix"
-  (format nil "snapshot@[-~a]" suffix))
+  (format nil "snapshot~@[-~a~]" suffix))
 
 ;;; Some file manipulation utilities