Commits

Anonymous committed bd97abc

Initial revision

  • Participants
  • Parent commits 5024ddb

Comments (0)

Files changed (12)

+# $Id$
+
+default:
+	@echo Possible targets:
+	@echo clean-openmcl --- remove all '*.dfsl' recursively
+	@echo clean-lw --- remove all '*.nfasl' recursively
+	@echo clean-emacs --- remove all '*~' recursively
+	@echo clean --- all of the above
+
+clean-openmcl:
+	find . -name "*.dfsl" | xargs rm
+
+clean-lw:
+	find . -name "*.nfasl" | xargs rm
+
+clean-emacs:
+	find . -name "*~" | xargs rm
+
+clean: clean-openmcl clean-lw clean-emacs
+
+#
+# This can obviously only be done by a specific person in a very specific context ;-)
+#
+
+PRJ=cl-prevalence
+ACCOUNT=scaekenberghe
+CVSRT=:ext:$ACCOUNT@common-lisp.net:/project/$PRJ/cvsroot
+
+release:
+	rm -rf /tmp/$PRJ /tmp/public_html /tmp/$PRJ.tgz /tmp/$PRJ.tgz.asc
+	cd /tmp; cvs -d$CVSRT export -r HEAD $PRJ; cvs -d$CVSRT export -r HEAD public_html
+	mv /tmp/public_html /tmp/$PRJ/doc
+	cd /tmp; gnutar cvfz $PRJ.tgz $PRJ; gpg -a -b $PRJ.tgz
+	scp /tmp/$PRJ.tgz $ACCOUNT@common-lisp.net:/project/$PRJ/public_html
+	scp /tmp/$PRJ.tgz.asc $ACCOUNT@common-lisp.net:/project/$PRJ/public_html

File cl-prevalence.asd

+;;;; -*- Mode: LISP -*-
+;;;;
+;;;; $Id$
+;;;;
+;;;; The CL-PREVALENCE ASDF system definition
+;;;;
+;;;; Copyright (C) 2003, 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :asdf)
+
+(defsystem :cl-prevalence
+  :name "CL-PREVALENCE"
+  :author "Sven Van Caekenberghe <svc@mac.com>"
+  :version "3"
+  :maintainer "Sven Van Caekenberghe <svc@mac.com>"
+  :licence "Lesser Lisp General Public License"
+  :description "Common Lisp Prevalence Package"
+  :long-description "Common Lisp Prevalence is an implementation of Object Prevalence for Common Lisp"
+
+  :components 
+  ((:module 
+    :src
+    :components
+    ((:file "package")
+     (:file "serialization" :depends-on ("package"))
+     (:file "prevalence" :depends-on ("serialization"))
+     (:file "debug-prevalence" :depends-on ("prevalence"))
+     (:file "managed-prevalence" :depends-on ("prevalence"))
+     (:file "blob" :depends-on ("managed-prevalence")))))
+  :depends-on (:s-xml))
+
+;;;; eof

File src/blob.lisp

+;;;; -*- Mode: LISP -*-
+;;;;
+;;;; $Id$
+;;;;
+;;;; Blobs represent collections of bytes of a certain mime type,
+;;;; where the bytes themselves are stored automatically in an ordinary file.
+;;;; This helps to save memory for large collections of binary data.
+;;;;
+;;;; Copyright (C) 2003, 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :cl-prevalence)
+
+(defclass blob (object-with-id)
+  ((name :accessor get-name :initarg :name :initform "untitled")
+   (size :reader get-size :initarg :size :initform -1)
+   (mime-type :accessor get-mime-type :initarg :mime-type :initform "application/octet-stream")
+   (keywords :accessor get-keywords :initarg :keywords :initform '()))
+  (:documentation "A blob is a file-like collection of bytes with related metadata"))
+
+(defgeneric get-name (blob)
+  (:documentation "Return the descriptive name of blob"))
+
+(defgeneric (setf get-name) (name blob)
+  (:documentation "Set the descriptive name of blob"))
+
+(defgeneric get-size (blob)
+  (:documentation "Return the size of blob in bytes"))
+
+(defgeneric get-mime-type (blob)
+  (:documentation "Return the mime-type of blob as a string"))
+
+(defgeneric (setf get-mime-type) (mime-type blob)
+  (:documentation "Set the mime-type string of blob"))
+
+(defgeneric get-keywords (blob)
+  (:documentation "Return the list of keywords associated with blob"))
+
+(defgeneric (setf get-keywords) (keywords blob)
+  (:documentation "Set the keywords list of blob"))
+
+(defmethod print-object ((blob blob) stream)
+  (print-unreadable-object
+   (blob stream :type t :identity t)
+   (with-slots (id name mime-type) blob
+   (format stream "#~d \"~a\" ~a" id name mime-type))))
+
+(defvar *blob-root* nil
+  "The directory in which to store the blob files")
+
+(defgeneric get-file (blob)
+  (:documentation "Return the pathname to the bytes of blob"))
+
+(defmethod get-file ((blob blob))
+  (merge-pathnames (princ-to-string (get-id blob)) *blob-root*))
+
+(defun copy-stream (in out &optional (element-type '(unsigned-byte 8)))
+  "Copy everything from in to out"
+  (let* ((buffer-size 4096)
+	 (buffer (make-array buffer-size :element-type element-type)))
+    (labels ((read-chunks ()
+			  (let ((size (read-sequence buffer in)))
+			    (if (< size buffer-size)
+				(write-sequence buffer out :start 0 :end size)
+			      (progn
+				(write-sequence buffer out)
+				(read-chunks))))))
+      (read-chunks))))
+
+(defgeneric fill-from-stream (blob binary-input-stream)
+  (:documentation "Fill the blob's contents with the bytes from binary-input-stream"))
+
+(defmethod fill-from-stream ((blob blob) binary-input-stream)
+  "Fill the blob's contents with the bytes from binary-input-stream"
+  (with-open-file (out (get-file blob)
+		       :direction :output
+		       :element-type '(unsigned-byte 8)
+		       :if-exists :overwrite
+		       :if-does-not-exist :create)
+    (copy-stream binary-input-stream out)))
+
+(defgeneric copy-to-stream (blob binary-output-stream)
+  (:documentation "Copy the bytes from blob to binary-output-stream"))
+
+(defmethod copy-to-stream ((blob blob) binary-output-stream)
+  "Copy the bytes from blob to binary-output-stream"
+  (with-open-file (in (get-file blob)
+		       :direction :input
+		       :element-type '(unsigned-byte 8))
+    (copy-stream in binary-output-stream)))
+
+(defgeneric fill-from-file (blob pathname)
+  (:documentation "Fill the blob's contents with the bytes read from the binary file at pathname"))
+
+(defmethod fill-from-file ((blob blob) pathname)
+  "Fill the blob's contents with the bytes read from the binary file at pathname"
+  (with-open-file (in pathname :direction :input :element-type '(unsigned-byte 8))
+    (fill-from-stream blob in))
+  (push (format nil "~a.~a"
+                (or (pathname-name pathname) "")
+                (or (pathname-type pathname) "")) 
+        (get-keywords blob)))
+
+(defgeneric destroy (blob)
+  (:documentation "Completely destroy blob (removing its byte data file as well)"))
+
+(defmethod destroy ((blob blob))
+  (when (probe-file (get-file blob))
+    (delete-file (get-file blob)))
+  (push :destroyed (get-keywords blob)))
+
+(defmethod size-from-file ((blob blob))
+  (let ((path (get-file blob)))
+    (if (probe-file path)
+	(with-open-file (in path :direction :input :element-type '(unsigned-byte 8))
+	  (file-length in))
+      -1)))
+
+(defmethod set-size-from-file ((blob blob))
+  (with-slots (size) blob
+    (setf size (size-from-file blob))))
+
+(defmethod get-size :before ((blob blob))
+  (with-slots (size) blob
+    (when (eql size -1)
+      (setf size (size-from-file blob)))))
+      
+;;;; eof

File src/debug-prevalence.lisp

+;;;; -*- Mode: LISP -*-
+;;;;
+;;;; $Id$
+;;;;
+;;;; Some debugging routines for CL-PREVALENCE
+;;;;
+;;;; Copyright (C) 2003, 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :cl-prevalence)
+
+(defun print-transaction-log (system)
+  "Echo the XML making up the transaction log of system to t"
+  (with-open-file (in (get-transaction-log system) :direction :input)
+    (loop
+     (let ((transaction (s-xml:echo-xml in *standard-output*)))
+       (when (null transaction) (return)))))
+  t)
+
+(defun show-transaction-log (system)
+  "Print the transaction objects making up the transaction log of system to t"
+  (with-open-file (in (get-transaction-log system) :direction :input)
+    (loop
+     (let ((transaction (deserialize-xml in *serialization-state*)))
+       (if (null transaction)
+	   (return)
+	 (format t "~a~%" transaction)))))
+  t)
+
+(defun print-snapshot (system)
+  "Echo the XML making up the snapshot of system to t"
+  (with-open-file (in (get-snapshot system) :direction :input)
+    (s-xml:echo-xml in *standard-output*))
+  t)
+
+(defun transaction-log-tail (system &optional (count 8))
+  "Return a list of the count last transaction objects of system"
+  (let (transactions)
+    (with-open-file (in (get-transaction-log system) :direction :input)
+      (loop
+       (let ((transaction (deserialize-xml in *serialization-state*)))
+	 (if (null transaction)
+	     (return)
+	   (push transaction transactions)))))
+    (setf transactions (nreverse transactions))
+    (nthcdr (max 0 (- (length transactions) count)) transactions)))
+
+;;;; eof

File src/managed-prevalence.lisp

+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id$
+;;;;
+;;;; The code in this file adds another layer above plain object prevalence.
+;;;; We manage objects with ids in an organized fashion, adding an id counter and preferences.
+;;;;
+;;;; Copyright (C) 2003, 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :cl-prevalence)
+
+;; A convience macro
+
+(defmacro execute-transaction (transaction-call)
+  "Create a transaction object from transaction-call and execute it"
+  `(execute ,(second transaction-call)
+	    (make-transaction ',(first transaction-call) ,@(rest (rest transaction-call)))))
+
+;; A generic object prevalence protocol handling objects with id
+
+(defclass object-with-id ()
+  ((id :reader get-id :initarg :id :initform -1))
+  (:documentation "Superclass for objects with an id"))
+
+(defgeneric get-id (object)
+  (:documentation "Return an external, unique, immutable identifier for object (typically an integer)"))
+
+(defun get-objects-root-name (class)
+  "Return the keyword symbol naming the root of instances of class"
+  (let ((classname (if (symbolp class) (string class) (class-name class))))
+    (intern (concatenate 'string classname "-ROOT") :keyword)))
+
+(defun get-objects-index-root-name (class)
+  "Return the keyword symbol naming the id index of instances of class"
+  (let ((classname (if (symbolp class) (string class) (class-name class))))
+    (intern (concatenate 'string classname "-ID-INDEX") :keyword)))
+
+(defgeneric find-all-objects (system class)
+  (:documentation "Return an unordered collection of all objects in system that are instances of class"))
+
+(defmethod find-all-objects ((system prevalence-system) class)
+  "Return an unordered collection of all objects in system that are instances of class"
+  (let ((root-name (get-objects-root-name class)))
+    (get-root-object system root-name)))
+
+(defgeneric find-object-with-id (system class id)
+  (:documentation "Find and return the object in system of class with id, null if not found"))
+
+(defmethod find-object-with-id ((system prevalence-system) class id)
+  "Find and return the object in system of class with id, null if not found"
+  (let* ((index-name (get-objects-index-root-name class))
+	 (index (get-root-object system index-name)))
+    (when index
+      (gethash id index))))
+
+(defun set-slot-values (instance slots-and-values)
+  "Set slots and values of instance"
+  (dolist (slot-and-value slots-and-values instance)
+    (setf (slot-value instance (first slot-and-value)) (second slot-and-value))))
+
+(defun tx-create-object (system &optional class slots-and-values)
+  "Create a new object of class in system, assigning it a unique id, optionally setting some slots and values"
+  (let* ((id (next-id system))
+	 (object (make-instance class :id id))
+	 (index-name (get-objects-index-root-name class))
+	 (index (or (get-root-object system index-name)
+		    (setf (get-root-object system index-name) (make-hash-table)))))
+    (set-slot-values object slots-and-values)
+    (push object (get-root-object system (get-objects-root-name class)))
+    (setf (gethash id index) object)))
+
+(defun tx-delete-object (system class id)
+  "Delete the object of class with if from the system"
+  (let ((object (find-object-with-id system class id)))
+    (if object
+	(let ((root-name (get-objects-root-name class))
+	      (index-name (get-objects-index-root-name class)))
+	  (setf (get-root-object system root-name) (delete object (get-root-object system root-name)))
+	  (remhash id (get-root-object system index-name)))
+      (error "no object of class ~a with id ~d found in ~s" system class id))))
+
+(defun tx-change-object-slots (system class id slots-and-values)
+  "Change some slots of the object of class with id in system using slots and values"
+  (let ((object (find-object-with-id system class id)))
+    (if object
+	(set-slot-values object slots-and-values)
+      (error "no object of class ~a with id ~d found in ~s" system class id))))
+
+;; We use a simple id counter to generate unique object identifiers
+
+(defun tx-create-id-counter (system)
+  "Initialize the id counter to 0"
+  (setf (get-root-object system :id-counter) 0))
+
+(defmethod next-id ((system prevalence-system))
+  "Increment and return the next id"
+  (incf (get-root-object system :id-counter)))
+
+;;; A generic persistent preferences mechanism
+
+(defgeneric get-preference (system key)
+  (:documentation "Retrieve the value of the persistent preference stored under key in system"))
+
+(defmethod get-preference ((system prevalence-system) key)
+  "Retrieve the value of the persistent preference stored under key in system"
+  (let ((preferences (get-root-object system :preferences)))
+    (when preferences
+      (gethash key preferences)))) 
+
+(defun tx-set-preference (system key value)
+  "Set the value of the persistent preference key in system"
+  (let ((preferences (get-root-object system :preferences)))
+    (when (not preferences)
+      (setf preferences (make-hash-table)
+	    (get-root-object system :preferences) preferences))
+    (setf (gethash key preferences) value)))
+
+(defgeneric all-preferences-keys (system)
+  (:documentation "Return a list of all persistent preference keys of system"))
+
+(defmethod all-preferences-keys ((system prevalence-system))
+  "Return a list of all persistent preference keys of system"
+  (let ((preferences (get-root-object system :preferences)))
+    (when preferences
+      (let (keys)
+        (maphash #'(lambda (key value)
+                     (declare (ignore value))
+                     (push key keys))
+                 preferences)
+        keys))))
+
+;;;; eof

File src/package.lisp

+;;;; -*- Mode: LISP -*-
+;;;;
+;;;; $Id$
+;;;;
+;;;; Package definitions for the CL-PREVALENCE project
+;;;;
+;;;; Copyright (C) 2003, 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(defpackage :s-serialization
+  (:use :cl)
+  (:export
+   #:serializable-slots
+   #:serialize-xml
+   #:deserialize-xml
+   #:make-serialization-state)
+  (:documentation "XML and s-expression based serialization for Common Lisp and CLOS"))
+
+(defpackage :cl-prevalence
+  (:use :cl :s-serialization)
+  #+NIL(:nicknames :clp)
+  (:export
+   #:make-prevalence-system
+   #:make-transaction
+   #:execute
+   #:query
+   #:snapshot
+   #:restore
+   #:backup
+   #:get-root-object
+   #:get-option
+   #:remove-root-object
+   #:prevalence-system
+   #:guarded-prevalence-system
+   #:get-guard
+   #:transaction
+   #:no-rollback-error
+   #:initiates-rollback
+
+   #:print-transaction-log #:show-transaction-log #:print-snapshot #:transaction-log-tail
+
+   #:blob
+   #:get-file
+   #:get-name
+   #:name
+   #:get-mime-type
+   #:mime-type
+   #:get-size
+   #:size
+   #:get-keywords
+   #:keywords
+   #:*blob-root*
+   #:copy-to-stream
+   #:fill-from-stream
+   #:fill-from-file
+   #:destroy
+
+   #:execute-transaction 
+   #:object-with-id
+   #:get-id
+   #:id
+   #:find-all-objects
+   #:find-object-with-id
+   #:set-slot-values
+   #:tx-create-id-counter
+   #:tx-create-object
+   #:tx-delete-object
+   #:tx-change-object-slots
+   #:get-preference
+   #:all-preferences-keys
+   #:tx-set-preference)
+  (:documentation "A proof of concept Common Lisp Prevalence system"))
+
+;;;; eof

File src/prevalence.lisp

+;;;; -*- mode: Lisp -*-
+;;;;
+;;;; $Id$
+;;;;
+;;;; Object Prevalence in Common Lisp
+;;;;
+;;;; Copyright (C) 2003, 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :cl-prevalence)
+
+;;; Public API: Functions and Generic Functions
+
+(defun make-prevalence-system (directory &key (prevalence-system-class 'prevalence-system))
+  "Create and return a new prevalence system on directory. When the
+  directory contains a valid snapshot and/or transaction log file, the
+  system will be restored. Optionally specify the prevalence system's
+  class."
+  (make-instance prevalence-system-class :directory directory))
+
+(defun make-transaction (function &rest args)
+  "Create and return a new transaction specifying a function name and
+  an argument list. The function should accept the system instance
+  prepended to the argument list as arguments and implement the actual
+  transaction in a re-entrant way."
+  (make-instance 'transaction :function function :args args))
+
+(defgeneric execute (system object)
+  (:documentation "Ask for a transaction object to be executed on system with ACID properties"))
+
+(defgeneric execute-on (object system)
+  (:documentation "Ask for a transaction object to execute its changes in the context of system"))
+
+(defgeneric query (system function &rest args)
+  (:documentation "Ask for a query function to be executed on system with args"))
+
+(defgeneric snapshot (system)
+  (:documentation "Take a snapshot of a system"))
+
+(defgeneric restore (system)
+  (:documentation "Restore a system from permanent storage"))
+
+(defgeneric get-root-object (system name)
+  (:documentation "Retrieve a root object by symbol name from system"))
+
+(defgeneric (setf get-root-object) (value system name)
+  (:documentation "Set a symbol named root object of system to value")) 
+
+(defgeneric get-option (system name)
+  (:documentation "Retrieve a named option from system"))
+
+(defgeneric (setf get-option) (value system name)
+  (:documentation "Set a named option of system to value")) 
+
+(defgeneric remove-root-object (system name)
+  (:documentation "Remove the root object by symbol name from system"))
+
+(defgeneric initiates-rollback (condition)
+  (:documentation "Return true when a condition initiates a rollback when thrown from a transaction"))
+  
+(defgeneric backup (system &key directory)
+  (:documentation "Make backup copies of the current snapshot and transaction-log files"))
+
+;;; Classes
+
+(defclass prevalence-system ()
+  ((directory ;; :type pathname
+	      :initarg :directory
+	      :accessor get-directory)
+   (root-objects ;; :type hash-table
+		 :accessor get-root-objects
+		 :initform (make-hash-table :test 'eq))
+   (options ;; :type hash-table
+	    :initform (make-hash-table :test 'eq))
+   (snapshot ;; :type pathname
+	     :accessor get-snapshot)
+   (transaction-log ;; :type pathname
+		    :accessor get-transaction-log)
+   (transaction-log-stream ;; :type stream
+			   :accessor get-transaction-log-stream
+			   :initform nil))
+  (:documentation "Base Prevalence system implementation object"))
+
+(defclass guarded-prevalence-system (prevalence-system)
+  ((guard ;; :type function
+	  :accessor get-guard
+	  :initform #'(lambda (thunk) (funcall thunk))))
+  (:documentation "A Prevalence system with a guard thunk"))
+
+(defclass transaction ()
+  ((args ;; :type cons
+	 :initarg :args
+	 :accessor get-args
+	 :initform nil)
+   (function ;; :type symbol
+	     :initarg :function
+	     :accessor get-function
+	     :initform 'identity))
+  (:documentation "A simple Transaction object joining a function and its arguments"))
+
+;;; Conditions
+
+(define-condition no-rollback-error (error)
+  ()
+  (:documentation "Thrown by code inside a transaction to indicate that no rollback is needed"))
+
+;;; Implementation
+
+(defmethod initialize-instance :after ((system prevalence-system) &rest initargs &key &allow-other-keys)
+  "After a system is initialized, derive its file paths and try to restore it"
+  (declare (ignore initargs))
+  (with-slots (directory) system
+    (ensure-directories-exist directory)
+    (setf (get-snapshot system) (merge-pathnames "snapshot.xml" directory)
+	  (get-transaction-log system) (merge-pathnames "transaction-log.xml" directory)))
+  (restore system))
+
+(defmethod get-transaction-log-stream :before ((system prevalence-system))
+  (with-slots (transaction-log-stream) system
+    (unless transaction-log-stream
+      (setf transaction-log-stream (open (get-transaction-log system)
+					 :direction :output
+					 :if-does-not-exist :create
+					 :if-exists :append)))))
+
+(defmethod close-open-streams ((system prevalence-system) &key abort)
+  "Close all open stream associated with system"
+  (with-slots (transaction-log-stream) system
+    (when transaction-log-stream
+      (close transaction-log-stream :abort abort)
+      (setf transaction-log-stream nil))))
+
+(defmethod totally-destroy ((system prevalence-system) &key abort)
+  "Totally destroy system from permanent storage by deleting any xml files that we find"
+  (close-open-streams system :abort abort)
+  (when (probe-file (get-directory system))
+    (dolist (pathname (directory (merge-pathnames "*.xml" (get-directory system))))
+      (delete-file pathname))))
+
+(defmethod print-object ((transaction transaction) stream)
+  (format stream "#<TRANSACTION ~a ~a>"
+	  (get-function transaction)
+	  (or (get-args transaction) "()")))
+
+(defmethod get-root-object ((system prevalence-system) name)
+  (gethash name (get-root-objects system)))
+
+(defmethod (setf get-root-object) (value (system prevalence-system) name)
+  (setf (gethash name (get-root-objects system)) value))
+
+(defmethod get-option ((system prevalence-system) name)
+  (with-slots (options) system
+    (gethash name options)))
+
+(defmethod (setf get-option) (value (system prevalence-system) name)
+  (with-slots (options) system
+    (setf (gethash name options) value)))
+
+(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
+	 (handler-bind ((error #'(lambda (condition)
+				   (when (and (get-option system :rollback-on-error)
+					      (initiates-rollback condition))
+				     (format t ";; Notice: system rollback/restore due to error (~a)~%" condition)
+				     (restore system)))))
+	   (execute-on transaction system)))
+	 (out (get-transaction-log-stream system)))
+    (serialize-xml transaction out *serialization-state*)
+    (terpri out)
+    (finish-output out)
+    result))
+
+(defmethod query ((system prevalence-system) function &rest args)
+  "Execute an exclusive query function on a sytem"
+  (apply function (cons system args)))
+
+(defmethod execute ((system guarded-prevalence-system) (transaction transaction))
+  "Execute a transaction on a sytem controlled by a guard"
+  (funcall (get-guard system)
+	   #'(lambda () (call-next-method system transaction))))
+
+(defmethod query ((system guarded-prevalence-system) function &rest args)
+  "Execute an exclusive query function on a sytem controlled by a guard"
+  (funcall (get-guard system)
+	   #'(lambda () (apply function (cons system args)))))
+
+(defmethod execute-on ((transaction transaction) (system prevalence-system))
+  "Execute a transaction itself in the context of a system"
+  (apply (get-function transaction)
+	 (cons system (get-args transaction))))
+
+(defun timetag ()
+  (multiple-value-bind (second minute hour date month year)
+      (decode-universal-time (get-universal-time) 0)
+    (format nil
+	    "~d~2,'0d~2,'0dT~2,'0d~2,'0d~2,'0d"
+	    year month date hour minute second)))
+
+(defmethod snapshot ((system prevalence-system))
+  "Write to whole system to persistent storage resetting the transaction log"
+  (let ((timetag (timetag))
+	(transaction-log (get-transaction-log system))
+	(snapshot (get-snapshot system)))
+    (close-open-streams system)
+    (when (probe-file snapshot)
+      (copy-file snapshot (merge-pathnames (format nil "snapshot-~a.xml" timetag) snapshot)))
+    (with-open-file (out snapshot
+			 :direction :output :if-does-not-exist :create :if-exists :supersede)
+      (serialize-xml (get-root-objects system) out *serialization-state*))
+    (when (probe-file transaction-log)
+      (copy-file transaction-log (merge-pathnames (format nil "transaction-log-~a.xml" timetag) transaction-log))
+      (delete-file transaction-log))))
+
+(defmethod backup ((system prevalence-system) &key directory)
+  "Make backup copies of the current snapshot and transaction-log files"
+  (let* ((timetag (timetag))
+	 (transaction-log (get-transaction-log system))
+	 (snapshot (get-snapshot system))
+	 (transaction-log-backup (merge-pathnames (format nil "transaction-log-~a.xml" timetag)
+						  (or directory transaction-log)))
+	 (snapshot-backup (merge-pathnames (format nil "snapshot-~a.xml" timetag)
+					   (or directory snapshot))))
+    (close-open-streams system)
+    (when (probe-file transaction-log)
+      (copy-file transaction-log transaction-log-backup))
+    (when (probe-file snapshot)
+      (copy-file snapshot snapshot-backup))
+    timetag))
+
+(defmethod restore ((system prevalence-system))
+  "Load a system from persistent storage starting from the last snapshot and replaying the transaction log"
+  (clrhash (get-root-objects system))
+  (close-open-streams system)
+  (when (probe-file (get-snapshot system))
+    (with-open-file (in (get-snapshot system) :direction :input)
+      (setf (get-root-objects system) (deserialize-xml in *serialization-state*))))
+  (when (probe-file (get-transaction-log system))
+    (let ((position 0))
+      (handler-bind ((s-xml:xml-parser-error 
+                      #'(lambda (condition)
+                          (format t ";; Warning: error during transaction log restore: ~s~%" condition)
+                          (truncate-file (get-transaction-log system) position)
+                          (return-from restore))))
+	(with-open-file (in (get-transaction-log system) :direction :input)
+	  (loop
+	   (let ((transaction (deserialize-xml in *serialization-state*)))
+	     (setf position (file-position in))
+	     (if transaction
+		 (execute-on transaction system)
+	       (return)))))))))
+
+(defun truncate-file (file position)
+  "Truncate the physical file at position by copying and replacing it"
+  (let ((tmp-file (merge-pathnames (concatenate 'string "tmp-" (pathname-name file)) file))
+	(buffer (make-string 4096))
+	(index 0)
+	(read-count 0))
+    (with-open-file (in file :direction :input)
+      (with-open-file (out tmp-file :direction :output :if-exists :overwrite :if-does-not-exist :create)
+	(when (> position (file-length in)) (return-from truncate-file))
+	(loop
+	 (when (= index position) (return))
+	 (setf read-count (read-sequence buffer in))
+	 (when (>= (+ index read-count) position)
+	   (setf read-count (- position index)))
+	 (incf index read-count)
+	 (write-sequence buffer out :end read-count))))
+    (delete-file file)
+    (rename-file tmp-file file))
+  (format t ";; Notice: truncated transaction log at position ~d~%" position))
+
+(defun copy-file (source target)
+  (let ((buffer (make-string 4096))
+	(read-count 0))
+    (with-open-file (in source :direction :input)
+      (with-open-file (out target :direction :output :if-exists :overwrite :if-does-not-exist :create)
+	(loop
+	 (setf read-count (read-sequence buffer in))
+	 (write-sequence buffer out :end read-count)
+	 (when (< read-count 4096) (return)))))))
+  
+(defmethod initiates-rollback ((condition condition))
+  t)
+
+(defmethod initiates-rollback ((no-rollback-error no-rollback-error))
+  nil)
+
+(setf (documentation 'get-guard 'function) "Access the guard function of a sytem")
+
+#-allegro
+(setf (documentation '(setf get-guard) 'function) "Set the guard function of a system")
+
+;;;; eof

File src/serialization.lisp

+;;;; -*- mode: Lisp -*-
+;;;;
+;;;; $Id$
+;;;;
+;;;; XML and S-Expression based Serialization for Common Lisp and CLOS
+;;;;
+;;;; Copyright (C) 2003, 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :s-serialization)
+
+;;; Public API
+
+(defgeneric serializable-slots (object)
+  (:documentation "Return a list of slot names that need serialization"))
+
+(defun serialize-xml (object stream &optional (serialization-state (make-serialization-state)))
+  "Write a serialized version of object to stream using XML, optionally reusing a serialization-state"
+  (reset serialization-state)
+  (serialize-xml-internal object stream serialization-state))
+
+(defun serialize-sexp (object stream &optional (serialization-state (make-serialization-state)))
+  "Write a serialized version of object to stream using s-expressions, optionally reusing a serialization-state"
+  (reset serialization-state)
+  (serialize-sexp-internal object stream serialization-state))
+
+(defgeneric serialize-xml-internal (object stream serialization-state)
+  (:documentation "Write a serialized version of object to stream using XML"))
+
+(defgeneric serialize-sexp-internal (object stream serialization-state)
+  (:documentation "Write a serialized version of object to stream using s-expressions"))
+
+(defun deserialize-xml (stream &optional (serialization-state (make-serialization-state)))
+  "Read and return an XML serialized version of a lisp object from stream, optionally reusing a serialization state"
+  (reset serialization-state)
+  (let ((*deserialized-objects* (get-hashtable serialization-state)))
+    (declare (special *deserialized-objects*))
+    (car (s-xml:start-parse-xml stream (get-xml-parser-state serialization-state)))))
+
+(defun deserialize-sexp (stream &optional (serialization-state (make-serialization-state)))
+  "Read and return an s-expression serialized version of a lisp object from stream, optionally reusing a serialization state"
+  (reset serialization-state)
+  (let ((sexp (read stream nil :eof)))
+    (if (eq sexp :eof) 
+        (error "Unexpected end of file while deserializing from s-expression"))
+    (deserialize-sexp-internal sexp (get-hashtable serialization-state))))
+
+(defun make-serialization-state ()
+  "Create a reusable serialization state to pass as optional argument to [de]serialize-xml"
+  (make-instance 'serialization-state))
+
+;;; Implementation
+
+;; State and Support
+
+(defclass serialization-state ()
+  ((xml-parser-state :initform nil)
+   (counter :accessor get-counter :initform 0)
+   (hashtable :reader get-hashtable :initform (make-hash-table :test 'eq :size 1024 :rehash-size 2.0))
+   (known-slots :initform (make-hash-table))))
+
+(defmethod get-xml-parser-state ((serialization-state serialization-state))
+  (with-slots (xml-parser-state) serialization-state
+    (or xml-parser-state
+        (setf xml-parser-state (make-instance 's-xml:xml-parser-state
+					      :new-element-hook #'deserialize-xml-new-element
+					      :finish-element-hook #'deserialize-xml-finish-element
+					      :text-hook #'deserialize-xml-text)))))
+
+(defmethod reset ((serialization-state serialization-state))
+  (with-slots (hashtable counter) serialization-state
+    (clrhash hashtable)
+    (setf counter 0)))
+
+(defmethod known-object-id ((serialization-state serialization-state) object)
+  (gethash object (get-hashtable serialization-state)))
+
+(defmethod set-known-object ((serialization-state serialization-state) object)
+  (setf (gethash object (get-hashtable serialization-state))
+        (incf (get-counter serialization-state))))
+
+(defconstant +cl-package+ (find-package :cl))
+
+(defconstant +keyword-package+ (find-package :keyword))
+
+(defun print-symbol-xml (symbol stream)
+  (let ((package (symbol-package symbol))
+	(name (symbol-name symbol)))
+    (cond ((eq package +cl-package+) (write-string "CL:" stream))
+	  ((eq package +keyword-package+) (write-char #\: stream))
+	  (t (s-xml:print-string-xml (package-name package) stream)
+	     (write-string "::" stream)))
+    (s-xml:print-string-xml name stream)))
+
+(defun print-symbol (symbol stream)
+  (let ((package (symbol-package symbol))
+	(name (symbol-name symbol)))
+    (cond ((eq package +cl-package+) (write-string "CL:" stream))
+	  ((eq package +keyword-package+) (write-char #\: stream))
+	  (t (write-string (package-name package) stream)
+	     (write-string "::" stream)))
+    (write-string name stream)))
+
+(defmethod serializable-slots ((object structure-object))
+  #+openmcl
+  (let* ((sd (gethash (class-name (class-of object)) ccl::%defstructs%))
+	 (slots (if sd (ccl::sd-slots sd))))
+    (mapcar #'car (if (symbolp (caar slots)) slots (cdr slots))))
+  #+cmu
+  (mapcar #'pcl:slot-definition-name (pcl:class-slots (class-of object)))
+  #+lispworks
+  (structure:structure-class-slot-names (class-of object))
+  #+allegro
+  (mapcar #'mop:slot-definition-name (mop:class-slots (class-of object))))
+
+(defmethod serializable-slots ((object standard-object))
+  #+openmcl
+  (mapcar #'ccl:slot-definition-name
+	  (#-openmcl-native-threads ccl:class-instance-slots
+	   #+openmcl-native-threads ccl:class-slots
+	   (class-of object)))
+  #+cmu
+  (mapcar #'pcl:slot-definition-name (pcl:class-slots (class-of object)))
+  #+lispworks
+  (mapcar #'hcl:slot-definition-name (hcl:class-slots (class-of object)))
+  #+allegro
+  (mapcar #'mop:slot-definition-name (mop:class-slots (class-of object))))
+
+(defmethod get-serializable-slots ((serialization-state serialization-state) object)
+  (with-slots (known-slots) serialization-state
+    (let* ((class (class-name (class-of object)))
+	   (slots (gethash class known-slots)))
+      (when (not slots)
+	(setf slots (serializable-slots object))
+	(setf (gethash class known-slots) slots))
+      slots)))
+
+;; Serializers
+
+(defmethod serialize-xml-internal ((object integer) stream serialization-state)
+  (declare (ignore serialization-state))
+  (write-string "<INT>" stream)
+  (prin1 object stream)
+  (write-string "</INT>" stream))
+
+(defmethod serialize-xml-internal ((object ratio) stream serialization-state)
+  (declare (ignore serialization-state))
+  (write-string "<RATIO>" stream)
+  (prin1 object stream)
+  (write-string "</RATIO>" stream))
+
+(defmethod serialize-xml-internal ((object float) stream serialization-state)
+  (declare (ignore serialization-state))
+  (write-string "<FLOAT>" stream)
+  (prin1 object stream)
+  (write-string "</FLOAT>" stream))
+
+(defmethod serialize-xml-internal ((object complex) stream serialization-state)
+  (declare (ignore serialization-state))
+  (write-string "<COMPLEX>" stream)
+  (prin1 object stream)
+  (write-string "</COMPLEX>" stream))
+
+(defmethod serialize-sexp-internal ((object number) stream serialize-sexp-internal)
+  (declare (ignore serialize-sexp-internal))
+  (prin1 object stream))
+
+(defmethod serialize-xml-internal ((object null) stream serialization-state)
+  (declare (ignore serialization-state))
+  (write-string "<NULL/>" stream))
+
+(defmethod serialize-xml-internal ((object (eql 't)) stream serialization-state)
+  (declare (ignore serialization-state))
+  (write-string "<TRUE/>" stream))
+
+(defmethod serialize-xml-internal ((object string) stream serialization-state)
+  (declare (ignore serialization-state))
+  (write-string "<STRING>" stream)
+  (s-xml:print-string-xml object stream)
+  (write-string "</STRING>" stream))
+
+(defmethod serialize-xml-internal ((object symbol) stream serialization-state)
+  (declare (ignore serialization-state))
+  (write-string "<SYMBOL>" stream)
+  (print-symbol-xml object stream)
+  (write-string "</SYMBOL>" stream))
+
+(defmethod serialize-sexp-internal ((object null) stream serialization-state)
+  (declare (ignore serialization-state))
+  (write-string "NIL" stream))
+
+(defmethod serialize-sexp-internal ((object (eql 't)) stream serialization-state)
+  (declare (ignore serialization-state))
+  (write-string "T" stream))
+
+(defmethod serialize-sexp-internal ((object string) stream serialization-state)
+  (declare (ignore serialization-state))
+  (prin1 object stream))
+
+(defmethod serialize-sexp-internal ((object symbol) stream serialization-state)
+  (declare (ignore serialization-state))
+  (print-symbol object stream))
+
+(defmethod serialize-xml-internal ((object sequence) stream serialization-state)
+  (let ((id (known-object-id serialization-state object)))
+    (if id
+	(progn
+	  (write-string "<REF ID=\"" stream)
+	  (prin1 id stream)
+	  (write-string "\"/>" stream))
+      (progn
+	(setf id (set-known-object serialization-state object))
+	(write-string "<SEQUENCE ID=\"" stream)
+	(prin1 id stream)
+	(write-string "\" CLASS=\"" stream)
+	(print-symbol-xml (etypecase object (list 'list) (vector 'vector)) stream)
+	(write-string "\" SIZE=\"" stream)
+	(prin1 (length object) stream)
+	(write-string "\">" stream)
+	(map nil
+	     #'(lambda (element)
+		 (serialize-xml-internal element stream serialization-state))
+	     object)
+	(write-string "</SEQUENCE>" stream)))))
+
+(defmethod serialize-sexp-internal ((object sequence) stream serialization-state)
+  (let ((id (known-object-id serialization-state object)))
+    (if id
+	(progn
+	  (write-string "(:REF . " stream)
+	  (prin1 id stream)
+	  (write-string ")" stream))
+      (let ((length (length object))) 
+	(setf id (set-known-object serialization-state object))
+	(write-string "(:SEQUENCE " stream)
+	(prin1 id stream)
+	(write-string " :CLASS " stream)
+	(print-symbol (etypecase object (list 'list) (vector 'vector)) stream)
+	(write-string " :SIZE " stream)
+        (prin1 length stream)
+        (unless (zerop length)
+          (write-string " :ELEMENTS (" stream)
+          (map nil
+               #'(lambda (element) 
+                   (write-string " " stream)
+                   (serialize-sexp-internal element stream serialization-state))
+               object))
+        (write-string " ) )" stream)))))
+
+(defmethod serialize-xml-internal ((object hash-table) stream serialization-state)
+  (let ((id (known-object-id serialization-state object)))
+    (if id
+	(progn
+	  (write-string "<REF ID=\"" stream)
+	  (prin1 id stream)
+	  (write-string "\"/>" stream))
+      (progn
+	(setf id (set-known-object serialization-state object))
+	(write-string "<HASH-TABLE ID=\"" stream)
+	(prin1 id stream)
+	(write-string "\" TEST=\"" stream)
+	(print-symbol-xml (hash-table-test object) stream)
+	(write-string "\" SIZE=\"" stream)
+	(prin1 (hash-table-size object) stream)
+	(write-string "\">" stream)
+	(maphash #'(lambda (key value)
+		     (write-string "<ENTRY><KEY>" stream)
+		     (serialize-xml-internal key stream serialization-state)
+		     (write-string "</KEY><VALUE>" stream)
+		     (serialize-xml-internal value stream serialization-state)
+		     (princ "</VALUE></ENTRY>" stream))
+		 object)
+	(write-string "</HASH-TABLE>" stream)))))
+
+(defmethod serialize-sexp-internal ((object hash-table) stream serialization-state)
+  (let ((id (known-object-id serialization-state object)))
+    (if id
+	(progn
+	  (write-string "(:REF . " stream)
+	  (prin1 id stream)
+	  (write-string ")" stream))
+      (let ((count (hash-table-count object)))
+	(setf id (set-known-object serialization-state object))
+	(write-string "(:HASH-TABLE " stream)
+	(prin1 id stream)
+	(write-string " :TEST " stream)
+	(print-symbol (hash-table-test object) stream)
+	(write-string " :SIZE " stream)
+	(prin1 (hash-table-size object) stream)
+        (write-string " :REHASH-SIZE " stream)
+        (prin1 (hash-table-rehash-size object) stream)
+        (write-string " :REHASH-THRESHOLD " stream)
+        (prin1 (hash-table-rehash-threshold object) stream)
+        (unless (zerop count)
+          (write-string " :ENTRIES (" stream)
+          (maphash #'(lambda (key value)
+                       (write-string " (" stream)
+                       (serialize-sexp-internal key stream serialization-state)
+                       (write-string " . " stream)
+                       (serialize-sexp-internal value stream serialization-state)
+                       (princ ")" stream))
+                   object))
+	(write-string " ) )" stream)))))
+
+(defmethod serialize-xml-internal ((object structure-object) stream serialization-state)
+  (let ((id (known-object-id serialization-state object)))
+    (if id
+	(progn
+	  (write-string "<REF ID=\"" stream)
+	  (prin1 id stream)
+	  (write-string "\"/>" stream))
+      (progn
+	(setf id (set-known-object serialization-state object))
+	(write-string "<STRUCT ID=\"" stream)
+	(prin1 id stream)
+	(write-string "\" CLASS=\"" stream)
+	(print-symbol-xml (class-name (class-of object)) stream)
+	(write-string "\">" stream)
+	(mapc #'(lambda (slot)
+		  (write-string "<SLOT NAME=\"" stream)
+		  (print-symbol-xml slot stream)
+		  (write-string "\">" stream)
+		  (serialize-xml-internal (slot-value object slot) stream serialization-state)
+		  (write-string "</SLOT>" stream))
+	      (get-serializable-slots serialization-state object))
+	(write-string "</STRUCT>" stream)))))
+
+(defmethod serialize-sexp-internal ((object structure-object) stream serialization-state)
+  (let ((id (known-object-id serialization-state object)))
+    (if id
+	(progn
+	  (write-string "(:REF . " stream)
+	  (prin1 id stream)
+	  (write-string ")" stream))
+      (let ((serializable-slots (get-serializable-slots serialization-state object)))
+	(setf id (set-known-object serialization-state object))
+	(write-string "(:STRUCT " stream)
+	(prin1 id stream)
+	(write-string " :CLASS " stream)
+	(print-symbol (class-name (class-of object)) stream)
+        (when serializable-slots
+          (write-string " :SLOTS (" stream)
+          (mapc #'(lambda (slot)
+                    (write-string " (" stream)
+                    (print-symbol slot stream)
+                    (write-string " . " stream)
+                    (serialize-sexp-internal (slot-value object slot) stream serialization-state)
+                    (write-string ")" stream))
+                serializable-slots))
+	(write-string " ) )" stream)))))
+
+(defmethod serialize-xml-internal ((object standard-object) stream serialization-state)
+  (let ((id (known-object-id serialization-state object)))
+    (if id
+	(progn
+	  (write-string "<REF ID=\"" stream)
+	  (prin1 id stream)
+	  (write-string "\"/>" stream))
+      (progn
+	(setf id (set-known-object serialization-state object))
+	(write-string "<OBJECT ID=\"" stream)
+	(prin1 id stream)
+	(write-string "\" CLASS=\"" stream)
+	(print-symbol-xml (class-name (class-of object)) stream)
+	(princ "\">" stream)
+	(mapc #'(lambda (slot)
+		  (write-string "<SLOT NAME=\"" stream)
+		  (print-symbol-xml slot stream)
+		  (write-string "\">" stream)
+		  (serialize-xml-internal (slot-value object slot) stream serialization-state)
+		  (write-string "</SLOT>" stream))
+	      (get-serializable-slots serialization-state object))
+	(write-string "</OBJECT>" stream)))))
+
+(defmethod serialize-sexp-internal ((object standard-object) stream serialization-state)
+  (let ((id (known-object-id serialization-state object)))
+    (if id
+	(progn
+	  (write-string "(:REF . " stream)
+	  (prin1 id stream)
+	  (write-string ")" stream))
+      (let ((serializable-slots (get-serializable-slots serialization-state object)))
+	(setf id (set-known-object serialization-state object))
+	(write-string "(:OBJECT " stream)
+	(prin1 id stream)
+	(write-string " :CLASS " stream)
+	(print-symbol (class-name (class-of object)) stream)
+        (when serializable-slots
+          (princ " :SLOTS (" stream)
+          (mapc #'(lambda (slot)
+                    (write-string " (" stream)
+                    (print-symbol slot stream)
+                    (write-string " . " stream)
+                    (serialize-sexp-internal (slot-value object slot) stream serialization-state)
+                    (write-string ")" stream))
+                serializable-slots))
+	(write-string " ) )" stream)))))
+
+;;; Deserialize CLOS instances and Lisp primitives from the XML representation
+
+(defun get-attribute-value (name attributes)
+  (cdr (assoc name attributes :test #'eq)))
+
+(defun deserialize-xml-new-element (name attributes seed)
+  (declare (ignore seed) (special *deserialized-objects*))
+  (case name
+    (:sequence (let ((id (parse-integer (get-attribute-value :id attributes)))
+		     (class (read-from-string (get-attribute-value :class attributes)))
+		     (size (parse-integer (get-attribute-value :size attributes))))
+		 (setf (gethash id *deserialized-objects*)
+		       (make-sequence class size))))
+    (:object (let ((id (parse-integer (get-attribute-value :id attributes)))
+		   (class (read-from-string (get-attribute-value :class attributes))))
+	       (setf (gethash id *deserialized-objects*)
+		     (make-instance class))))
+    (:struct (let ((id (parse-integer (get-attribute-value :id attributes)))
+		   (class (read-from-string (get-attribute-value :class attributes))))
+	       (setf (gethash id *deserialized-objects*)
+		     (funcall (intern (concatenate 'string "MAKE-" (symbol-name class)) (symbol-package class))))))
+    (:hash-table (let ((id (parse-integer (get-attribute-value :id attributes)))
+		       (test (read-from-string (get-attribute-value :test attributes)))
+		       (size (parse-integer (get-attribute-value :size attributes))))
+		   (setf (gethash id *deserialized-objects*)
+			 (make-hash-table :test test :size size)))))
+  '())
+
+(defun deserialize-xml-finish-element (name attributes parent-seed seed)
+  (declare (special *deserialized-objects*))
+  (cons (case name
+	  (:int (parse-integer seed))
+	  ((:float :ratio :complex :symbol) (read-from-string seed))
+	  (:null nil)
+	  (:true t)
+	  (:string seed)
+	  (:key (car seed))
+	  (:value (car seed))
+	  (:entry (nreverse seed))
+	  (:slot (let ((name (read-from-string (get-attribute-value :name attributes))))
+		   (cons name (car seed))))
+	  (:sequence (let* ((id (parse-integer (get-attribute-value :id attributes)))
+			    (sequence (gethash id *deserialized-objects*)))
+		       (map-into sequence #'identity (nreverse seed)))) 
+	  (:object (let* ((id (parse-integer (get-attribute-value :id attributes)))
+			  (object (gethash id *deserialized-objects*)))
+		     (dolist (pair seed object)
+		       (setf (slot-value object (car pair)) (cdr pair)))))
+	  (:struct (let* ((id (parse-integer (get-attribute-value :id attributes)))
+			  (object (gethash id *deserialized-objects*)))
+		     (dolist (pair seed object)
+		       (setf (slot-value object (car pair)) (cdr pair)))))
+	  (:hash-table (let* ((id (parse-integer (get-attribute-value :id attributes)))
+			      (hash-table (gethash id *deserialized-objects*)))
+			 (dolist (pair seed hash-table)
+			   (setf (gethash (car pair) hash-table) (cadr pair)))))
+	  (:ref (let ((id (parse-integer (get-attribute-value :id attributes))))
+		  (gethash id *deserialized-objects*))))
+	parent-seed))
+
+(defun deserialize-xml-text (string seed)
+  (declare (ignore seed))
+  string)
+
+(defun deserialize-sexp-internal (sexp deserialized-objects)
+  (if (atom sexp) 
+      sexp
+    (ecase (first sexp)
+      (:sequence (destructuring-bind (id &key class size elements) (rest sexp)
+                   (let ((sequence (make-sequence class size)))
+                     (setf (gethash id deserialized-objects) sequence)
+                     (map-into sequence 
+                               #'(lambda (x) (deserialize-sexp-internal x deserialized-objects)) 
+                               elements))))
+      (:hash-table (destructuring-bind (id &key test size rehash-size rehash-threshold entries) (rest sexp)
+                     (let ((hash-table (make-hash-table :size size 
+                                                        :test test 
+                                                        :rehash-size rehash-size 
+                                                        :rehash-threshold rehash-threshold)))
+                       (setf (gethash id deserialized-objects) hash-table)
+                       (dolist (entry entries)
+                         (setf (gethash (deserialize-sexp-internal (first entry) deserialized-objects) hash-table)
+                               (deserialize-sexp-internal (rest entry) deserialized-objects)))
+                       hash-table)))
+      (:object (destructuring-bind (id &key class slots) (rest sexp)
+                 (let ((object (make-instance class)))
+                   (setf (gethash id deserialized-objects) object)
+                   (dolist (slot slots)
+                     (setf (slot-value object (first slot)) 
+                           (deserialize-sexp-internal (rest slot) deserialized-objects)))
+                   object)))
+      (:struct (destructuring-bind (id &key class slots) (rest sexp)
+                 (let ((object (funcall (intern (concatenate 'string "MAKE-" (symbol-name class)) 
+                                                (symbol-package class)))))
+                   (setf (gethash id deserialized-objects) object)
+                   (dolist (slot slots)
+                     (setf (slot-value object (first slot)) 
+                           (deserialize-sexp-internal (rest slot) deserialized-objects)))
+                   object)))
+      (:ref (gethash (rest sexp) deserialized-objects)))))
+
+;;;; eof

File test/demo1.lisp

+;;;; -*- mode: Lisp -*-
+;;;;
+;;;; $Id$
+;;;;
+;;;; A Common Lisp version of the the Java Prevalyer demo1 example
+;;;;
+;;;; Copyright (C) 2003, 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :cl-prevalence)
+
+(defun prime-p (n)
+  "Prime predicate copied from Java code"
+  (cond ((< n 2) nil)
+	((= n 2) t)
+	((evenp n) nil)
+	(t (let ((factor 3)
+		 (square (ceiling (sqrt n))))
+	     (loop
+	      (unless (<= factor square)
+		(return-from prime-p t))
+	      (if (zerop (mod n factor))
+		  (return-from prime-p nil)
+		(incf factor 2)))))))
+
+(defclass numbers ()
+  ((numbers-list :accessor get-numbers-list :initform nil))
+  (:documentation "Object to hold our list of numbers"))
+
+(defun tx-create-numbers-root (system)
+  "Transaction function to create a numbers instance as a root object"
+  (setf (get-root-object system :numbers) (make-instance 'numbers)))
+
+(defun tx-add-number (system number)
+  "Transaction function to add a number to the numbers list"
+  (let ((numbers (get-root-object system :numbers)))
+    (push number (get-numbers-list numbers))))
+
+(defparameter *system-location* (pathname "/tmp/demo1-prevalence-system/")
+  "Filesystem location of the prevalence system")
+
+(defun demo1 ()
+  "Run the demo1 loop, computing primes and making the list of primes found persistent"
+  (let ((system (make-prevalence-system *system-location*)))
+    (unwind-protect
+	(let* ((numbers (or (get-root-object system :numbers)
+			    (execute system (make-transaction 'tx-create-numbers-root))))
+	       (numbers-list (get-numbers-list numbers))
+	       (candidate (if numbers-list (1+ (first numbers-list)) 0))
+	       (largest 0))
+	  (loop
+	   (when (> candidate most-positive-fixnum)
+	     (return))
+	   (when (prime-p candidate)
+	     (execute system (make-transaction 'tx-add-number candidate))
+	     (setf largest candidate)
+	     (format t "Primes found: ~d. Largest: ~d~%" (length (get-numbers-list numbers)) largest))
+	   (incf candidate)))
+      (close-open-streams system))))
+
+(defun reset-demo1 ()
+  "Throw away any xml files that we find: we want to start from scratch"
+  (when (probe-file *system-location*)
+    (dolist (pathname (directory (merge-pathnames "*.xml" *system-location*)))
+      (delete-file pathname))))
+
+(defun benchmark1 ()
+  (reset-demo1)
+  (let (system)
+    (setf system (make-prevalence-system *system-location*))
+    (execute system (make-transaction 'tx-create-numbers-root))
+    (time (dotimes (i 1000) (execute system (make-transaction 'tx-add-number i))))
+    (close-open-streams system)
+    (setf system (time (make-prevalence-system *system-location*)))
+    (close-open-streams system)))
+
+;;;; eof

File test/demo2.lisp

+;;;; -*- mode: Lisp -*-
+;;;;
+;;;; $Id$
+;;;;
+;;;; A Common Lisp version of the the Java Prevalyer demo2 example
+;;;;
+;;;; Copyright (C) 2003, 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :cl-prevalence)
+
+;;; Domain Model
+
+(defclass bank ()
+  ((accounts-by-number :accessor get-accounts-by-number :initform (make-hash-table :test 'eql))
+   (next-account-number :accessor get-next-account-number :initform 1)))
+
+(defclass account ()
+  ((number :accessor get-number :initarg :number :initform -1)
+   (holder :accessor get-holder :initarg :holder :initform "Unspecified")
+   (balance :accessor get-balance :initform 0)
+   (transaction-history :accessor get-transaction-history :initform nil)))
+
+(defmethod print-object ((account account) stream)
+  (with-slots (number holder balance) account
+    (format stream "#<ACCOUNT ~d '~a' $~d>" number holder balance)))
+
+(defclass account-entry ()
+  ((amount :accessor get-amount :initarg :amount)
+   (timestamp :accessor get-timestamp :initarg :timestamp)))
+
+(defun date-time->string (universal-time)
+  (multiple-value-bind (second minute hour date month year)
+      (decode-universal-time universal-time)
+    (format nil
+	    "~d/~2,'0d/~2,'0d ~2,'0d:~2,'0d:~2,'0d"
+	    year month date hour minute second)))
+
+(defmethod print-object ((account-entry account-entry) stream)
+  (with-slots (timestamp amount) account-entry
+    (format stream "#<ACCOUNT-ENTRY ~a ~@d>" (date-time->string timestamp) amount)))
+
+;;; Prevalence System
+
+(defparameter *bank-system-location* (pathname "/tmp/demo2-prevalence-system/"))
+
+(defun tx-create-bank (system)
+  (setf (get-root-object system :bank) (make-instance 'bank)))
+
+(defun init-bank-system (system)
+  (unless (get-root-object system :bank)
+    (execute system (make-transaction 'tx-create-bank)))
+  system)
+
+(defvar *bank-system*
+  (let ((system (make-prevalence-system *bank-system-location*)))
+    (init-bank-system system)))
+
+(defun tx-create-account (system holder)
+  (let* ((bank (get-root-object system :bank))
+	 (account-number (get-next-account-number bank))
+	 (new-account (make-instance 'account
+				     :holder holder
+				     :number account-number)))
+    (setf (gethash account-number (get-accounts-by-number bank)) new-account) 
+    (incf (get-next-account-number bank))
+    new-account))
+
+(define-condition bank-error (error) ())
+
+(define-condition unknown-account (bank-error)
+  ((account-number :reader unknown-account-number :initarg :account-number))
+  (:report (lambda (condition stream)
+	     (format stream "Unknown account ~a"
+		     (unknown-account-number condition)))))
+
+(define-condition overdrawn-account (bank-error)
+  ((account :reader overdrawn-account-account :initarg :account)
+   (amount :reader overdrawn-account-amount :initarg :amount))
+  (:report (lambda (condition stream)
+	     (format stream "You cannot withdraw ~d from account ~a"
+		     (overdrawn-account-amount condition)
+		     (overdrawn-account-account condition)))))
+
+(defun get-account (system account-number)
+  (let* ((bank (get-root-object system :bank))
+	 (account (gethash account-number (get-accounts-by-number bank))))
+    (if account
+	account
+      (error 'unknown-account :account-number account-number))))
+
+(defun tx-delete-account (system account-number)
+  (when (get-account system account-number)
+    (remhash account-number (get-accounts-by-number (get-root-object system :bank)))))
+
+(defun tx-change-account-holder (system account-number new-holder)
+  (let ((account (get-account system account-number)))
+    (setf (get-holder account) new-holder)
+    account))
+
+(defun tx-deposit (system account-number amount timestamp)
+  (let ((account (get-account system account-number)))
+    (incf (get-balance account) amount)
+    (push (make-instance 'account-entry :amount amount :timestamp timestamp)
+	  (get-transaction-history account))
+    account))
+
+(defun tx-withdraw (system account-number amount timestamp)
+  (let ((account (get-account system account-number)))
+    (if (< (get-balance account) amount)
+	(error 'overdrawn-account :account account :amount amount)
+      (decf (get-balance account) amount))
+    (push (make-instance 'account-entry :amount (- amount) :timestamp timestamp)
+	  (get-transaction-history account))
+    account))
+
+(defun tx-transfer (system from-account-number to-account-number amount timestamp)
+  (let* ((from-account (get-account system from-account-number))
+	 (to-account (get-account system to-account-number)))
+    (cond ((< (get-balance from-account) amount)
+	   (error 'overdrawn-account :amount amount :account from-account))
+	  (t (decf (get-balance from-account) amount)
+	     (incf (get-balance to-account) amount)
+	     (push (make-instance 'account-entry :amount (- amount) :timestamp timestamp)
+		   (get-transaction-history from-account))
+	     (push (make-instance 'account-entry :amount amount :timestamp timestamp)
+		   (get-transaction-history to-account))))
+    amount))
+
+(defun get-bank-balance (system)
+  (let ((bank (get-root-object system :bank))
+	(total 0))
+    (maphash #'(lambda (key value)
+		 (declare (ignore key))
+		 (incf total (get-balance value)))
+	     (get-accounts-by-number bank))
+    total))
+
+;;; Client Interface
+
+(defun create-account (holder)
+  (execute *bank-system* (make-transaction 'tx-create-account holder)))
+
+(defun delete-account (account-number)
+  (execute *bank-system* (make-transaction 'tx-delete-account account-number)))
+
+(defun change-account-holder (account-number new-holder)
+  (execute *bank-system* (make-transaction 'tx-change-account-holder account-number new-holder)))
+
+(defun deposit (account-number amount)
+  (execute *bank-system* (make-transaction 'tx-deposit
+					   account-number amount (get-universal-time))))
+
+(defun withdraw (account-number amount)
+  (execute *bank-system* (make-transaction 'tx-withdraw
+					   account-number amount (get-universal-time))))
+
+(defun transfer (from-account-number to-account-number amount)
+  (execute *bank-system* (make-transaction 'tx-transfer
+					   from-account-number to-account-number amount (get-universal-time))))
+
+(defun find-account (account-number)
+  (let ((bank (get-root-object *bank-system* :bank)))
+    (gethash account-number (get-accounts-by-number bank))))
+
+(defun list-all-accounts ()
+  (let ((bank (get-root-object *bank-system* :bank))
+	accounts)
+    (maphash #'(lambda (key value)
+		 (declare (ignore key))
+		 (push value accounts))
+	     (get-accounts-by-number bank))
+    accounts))
+
+;;; Now some test code
+
+(defun bank-test-1 ()
+  (let ((test-1 (get-number (create-account "Test Account 1")))
+	(test-2 (get-number (create-account "Test Account 2"))))
+    (assert (zerop (get-balance (find-account test-1))))
+    (assert (zerop (get-balance (find-account test-2))))
+    (deposit test-1 1000)
+    (deposit test-2 2000)
+    (withdraw test-2 500)
+    (transfer test-2 test-1 500)
+    (withdraw test-1 500)
+    (assert (= 1000 (get-balance (find-account test-1))))
+    (assert (= 1000 (get-balance (find-account test-2))))
+    (delete-account test-1)
+    (delete-account test-2)
+    (print-transaction-log *bank-system*)
+    (snapshot *bank-system*)
+    (print-snapshot *bank-system*)))
+
+(defun bank-test-2 ()
+  (let ((test-1 (get-number (create-account "Test Account 1")))
+	(test-2 (get-number (create-account "Test Account 2")))
+	now)
+    (assert (zerop (get-balance (find-account test-1))))
+    (assert (zerop (get-balance (find-account test-2))))
+    (deposit test-1 1000)
+    (deposit test-2 2000)
+    (withdraw test-2 500)
+    (transfer test-2 test-1 500)
+    (withdraw test-1 500)
+    (assert (= 1000 (get-balance (find-account test-1))))
+    (assert (= 1000 (get-balance (find-account test-2))))
+    (sleep 1)
+    (setf now (get-universal-time))
+    (restore *bank-system*)
+    (let ((account-1 (find-account test-1))
+	  (account-2 (find-account test-2)))
+      (dolist (account-entry (get-transaction-history account-1))
+	(assert (< (get-timestamp account-entry) now)))
+      (dolist (account-entry (get-transaction-history account-2))
+	(assert (< (get-timestamp account-entry) now))))
+    (delete-account test-1)
+    (delete-account test-2))
+  t)
+
+(defun bank-test-3 ()
+  (let ((system (make-prevalence-system *bank-system-location*
+					:prevalence-system-class 'guarded-prevalence-system)))
+    (query system #'get-bank-balance)
+    (close-open-streams system)))
+
+(defmethod initiates-rollback ((bank-error bank-error))
+  nil)
+
+(defun tx-bogus-withdraw (system account-number amount)
+  (let* ((bank (get-root-object system :bank))
+	 (account (gethash account-number (get-accounts-by-number bank))))
+    (if (null account)
+	(error 'unknown-account :account-number account-number)
+      (progn
+	;; this is intentionally wrong: we modify before we test
+	(decf (get-balance account) amount)
+	;; if negative throw a hard error (could initiate rollback)
+	(when (< (get-balance account) 0)
+	  (error "Account ~a went below zero!" account))))))
+
+(defun bank-test-4 ()
+  (let ((account-number (get-number (create-account "bank-test4"))))
+    ;; --------------------------------------------------------------
+    (format t "Part 1~%")
+    ;; disable the rollback option (off by default)
+    (setf (get-option *bank-system* :rollback-on-error) nil)
+    ;; put 10 bucks on the account
+    (deposit account-number 10)
+    ;; check that we have 10 bucks
+    (assert (= 10 (get-balance (find-account account-number))))
+    ;; try to withdraw 20 bucks from the account
+    (ignore-errors
+      ;; this will fail with an overdrawn-account error
+      ;; BEFORE the system is modified (nothing was logged)
+      (withdraw account-number 20))
+    ;; check that nothing changed
+    (assert (= 10 (get-balance (find-account account-number))))
+    ;; try to with withdraw 20 bucks using the bogus-withdraw tx
+    (ignore-errors
+      ;; this will fail with a regular error
+      ;; AFTER the system is modified (nothing was logged)
+      (execute *bank-system* (make-transaction 'tx-bogus-withdraw account-number 20)))
+    ;; check that the change went through
+    (assert (= -10 (get-balance (find-account account-number))))
+    ;; --------------------------------------------------------------
+    (format t "Part 2~%")
+    ;; enable the rollback option (off by default)
+    (setf (get-option *bank-system* :rollback-on-error) t)
+    ;; start over
+    (delete-account account-number)
+    (setf account-number (get-number (create-account "bank-test4")))
+    ;; put 20 bucks on the account
+    (deposit account-number 10)
+    ;; check that we have 10 bucks 
+    (assert (= 10 (get-balance (find-account account-number))))
+    ;; try to withdraw 20 bucks from the account
+    (ignore-errors
+      ;; this will fail with an overdrawn-account error
+      ;; BEFORE the system is modified (nothing was logged)
+      ;; NO rollback (condition does not initiate a rollback)
+      (withdraw account-number 20))
+    ;; check that nothing changed
+    (assert (= 10 (get-balance (find-account account-number))))
+    ;; try to with withdraw 20 bucks using the bogus-withdraw tx
+    (ignore-errors
+      ;; this will fail with a regular error
+      ;; AFTER the system is modified (nothing was logged)
+      ;; rollback IS executed (condition does initiate a rollback)
+      (execute *bank-system* (make-transaction 'tx-bogus-withdraw account-number 20)))
+    ;; check that the rollback took place and nothing changed
+    (assert (= 10 (get-balance (find-account account-number))))
+    ;; --------------------------------------------------------------
+    ;; reset
+    (delete-account account-number)
+    (setf (get-option *bank-system* :rollback-on-error) nil)))
+
+;;; a multi-processing example (openmcl & lispworks only)
+
+(defparameter *bank-system-lock*
+  #+openmcl (ccl:make-lock "bank-system-lock")
+  #+lispworks (mp:make-lock :name "bank-system-lock")
+  #+allegro (mp:make-process-lock :name "bank-system-lock")
+  #-(or openmcl lispworks allegro) nil)
+
+(defun bank-system-guard (thunk)
+  #+openmcl (ccl:with-lock-grabbed (*bank-system-lock*) (funcall thunk))
+  #+lispworks (mp:with-lock (*bank-system-lock*) (funcall thunk)) 
+  #+allegro (mp:with-process-lock (*bank-system-lock*) (funcall thunk))
+  #-(or openmcl lispworks allegro) (funcall thunk))
+
+(defun spawn-process (name function)
+  #+openmcl (ccl:process-run-function name function)
+  #+lispworks (mp:process-run-function name nil function)
+  #+allegro (mp:process-run-function name function)
+  #-(or openmcl lispworks allegro) (funcall function))
+
+(defun bank-test-5-setup ()
+  (when *bank-system* (close-open-streams *bank-system*))
+  (setf *bank-system* (make-prevalence-system *bank-system-location*
+					      :prevalence-system-class 'guarded-prevalence-system))
+  (setf (get-guard *bank-system*) #'bank-system-guard)
+  (mapcar #'(lambda (account)
+	      (delete-account (get-number account)))
+	  (list-all-accounts))
+  (dotimes (i 10)
+    (deposit (get-number (create-account (format nil "bank-test-5-account-~d" i))) 100))
+  (assert (= (get-bank-balance *bank-system*) 1000)))
+
+(defparameter *worker-output* *standard-output*)
+
+(defun bank-test-5-worker ()
+  (dotimes (i 10)
+    (let* ((accounts (list-all-accounts))
+	   (from-account (elt accounts (random (length accounts))))
+	   (to-account (elt (remove from-account accounts) (random (1- (length accounts)))))
+	   (amount (random 100)))
+      (catch 'trap-overdraw
+	(handler-bind ((overdrawn-account (lambda (condition)
+					    (format t "Transfer cancelled (~a)~%" condition)
+					    (throw 'trap-overdraw :ignore))))
+	  (format *worker-output* "Tranfering ~d from ~a to ~a~%" amount from-account to-account)
+	  (transfer (get-number from-account)
+		    (get-number to-account)
+		    amount))))))
+
+(defun bank-test-5-invariant ()
+  (dotimes (i 10)
+    (assert (= (query *bank-system* 'get-bank-balance) 1000))))
+
+(defun bank-test-5 ()
+  (bank-test-5-setup)
+  (spawn-process "invariant" #'bank-test-5-invariant)
+  (dotimes (i 10)
+    (spawn-process (format nil "bank-test-5-worker-~d" i)
+		   #'bank-test-5-worker)
+    (spawn-process "invariant" #'bank-test-5-invariant))
+  (spawn-process "invariant" #'bank-test-5-invariant)
+  (sleep 1)
+  (spawn-process "invariant" #'bank-test-5-invariant))
+  
+;;;; eof

File test/test-prevalence.lisp

+;;;; -*- mode: Lisp -*-
+;;;;
+;;;; $Id$
+;;;;
+;;;; Testing Object Prevalence in Common Lisp
+;;;;
+;;;; Copyright (C) 2003, 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :cl-prevalence)
+
+(defvar *test-system*)
+
+;; Create a new prevalence system for testing purposes
+
+(let ((directory (pathname "/tmp/test-prevalence-system/")))
+  ;; Throw away any xml files that we find: we want to start from scratch
+  (when (probe-file directory)
+    (dolist (pathname (directory (merge-pathnames "*.xml" directory)))
+      (delete-file pathname)))
+  (setf *test-system* (make-prevalence-system directory)))
+
+;; A Test CLOS class
+
+(defclass person ()
+  ((id :initarg :id :accessor get-id)
+   (firstname :initarg :firstname :accessor get-firstname)
+   (lastname :initarg :lastname :accessor get-lastname)))
+
+;; Some basic functions to construct transactions from
+
+(defun tx-create-id-counter (system)
+  (setf (get-root-object system :id-counter) 0))
+
+(defun tx-get-next-id (system)
+  (incf (get-root-object system :id-counter)))
+
+(defun tx-create-persons-root (system)
+  (setf (get-root-object system :persons) (make-hash-table)))
+
+(defun tx-create-person (system firstname lastname)
+  (let* ((persons (get-root-object system :persons))
+	 (id (tx-get-next-id system))
+	 (person (make-instance 'person :id id :firstname firstname :lastname lastname)))
+    (setf (gethash id persons) person)))
+
+(defun tx-delete-person (system id)
+  (let ((persons (get-root-object system :persons)))
+    (remhash id persons)))
+
+;; Create a new id counter
+
+(execute *test-system* (make-transaction 'tx-create-id-counter))
+
+(assert (zerop (get-root-object *test-system* :id-counter)))
+
+;; Create the hash-table holding all known persistent persons and mapping person id' to person objects
+
+(execute *test-system* (make-transaction 'tx-create-persons-root))
+
+(assert (hash-table-p (get-root-object *test-system* :persons)))
+
+;; A place to store our test person's id outside of the system
+
+(defvar *jlp*)
+
+;; Create a new test person
+
+(let ((person (execute *test-system* (make-transaction 'tx-create-person "Jean-Luc" "Picard"))))
+  (assert (eq (class-of person) (find-class 'person)))
+  (assert (equal (get-firstname person) "Jean-Luc"))
+  (assert (equal (get-lastname person) "Picard"))
+  (setf *jlp* (get-id person)))
+
+(let ((person (gethash *jlp* (get-root-object *test-system* :persons))))
+  (assert (eq (class-of person) (find-class 'person)))
+  (assert (equal (get-firstname person) "Jean-Luc"))
+  (assert (equal (get-lastname person) "Picard")))
+
+;; Throw away the previous prevalence instance and start over,
+;; counting on a restore operation using the transaction log
+
+(let ((directory (pathname "/tmp/test-prevalence-system/")))
+  (setf *test-system* (make-prevalence-system directory)))
+
+(let ((person (gethash *jlp* (get-root-object *test-system* :persons))))
+  (assert (eq (class-of person) (find-class 'person)))
+  (assert (equal (get-firstname person) "Jean-Luc"))
+  (assert (equal (get-lastname person) "Picard")))
+
+;; Create a snapshot of our test system
+
+(snapshot *test-system*)
+
+(let ((person (gethash *jlp* (get-root-object *test-system* :persons))))
+  (assert (eq (class-of person) (find-class 'person)))
+  (assert (equal (get-firstname person) "Jean-Luc"))
+  (assert (equal (get-lastname person) "Picard")))
+
+;; Throw away the previous prevalence instance and start over,
+;; counting on a restore operation using the snapshot
+
+(let ((directory (pathname "/tmp/test-prevalence-system/")))
+  (setf *test-system* (make-prevalence-system directory)))
+
+(let ((person (gethash *jlp* (get-root-object *test-system* :persons))))
+  (assert (eq (class-of person) (find-class 'person)))
+  (assert (equal (get-firstname person) "Jean-Luc"))
+  (assert (equal (get-lastname person) "Picard")))
+
+;; Create another test person
+
+(defvar *kj*)
+
+(let ((person (execute *test-system* (make-transaction 'tx-create-person "Kathryn" "Janeway"))))
+  (assert (eq (class-of person) (find-class 'person)))
+  (assert (equal (get-firstname person) "Kathryn"))
+  (assert (equal (get-lastname person) "Janeway"))
+  (setf *kj* (get-id person)))
+
+(let ((person (gethash *kj* (get-root-object *test-system* :persons))))
+  (assert (eq (class-of person) (find-class 'person)))
+  (assert (equal (get-firstname person) "Kathryn"))
+  (assert (equal (get-lastname person) "Janeway")))
+
+;; Throw away the previous prevalence instance and start over,
+;; counting on a restore operation using both the snapshot and the transaction log
+
+(let ((directory (pathname "/tmp/test-prevalence-system/")))
+  (setf *test-system* (make-prevalence-system directory)))
+
+(let ((person (gethash *jlp* (get-root-object *test-system* :persons))))
+  (assert (eq (class-of person) (find-class 'person)))
+  (assert (equal (get-firstname person) "Jean-Luc"))
+  (assert (equal (get-lastname person) "Picard")))
+
+(let ((person (gethash *kj* (get-root-object *test-system* :persons))))
+  (assert (eq (class-of person) (find-class 'person)))
+  (assert (equal (get-firstname person) "Kathryn"))
+  (assert (equal (get-lastname person) "Janeway")))
+
+(mapcar #'(lambda (pair)
+	    (execute *test-system* (make-transaction 'tx-create-person (car pair) (cadr pair))))
+	'(("Benjamin" "Sisko") ("James T." "Kirk") ("Jonathan" "Archer")))
+
+(assert (= (hash-table-count (get-root-object *test-system* :persons)) 5))
+
+;;; testing a guarded prevalence system
+
+(defvar *guard*)
+
+(defun guard (thunk)
+  (setf *guard* t)
+  (funcall thunk))
+
+(let ((directory (pathname "/tmp/test-prevalence-system/")))
+  (setf *test-system* (make-prevalence-system directory :prevalence-system-class 'guarded-prevalence-system))
+  (setf (get-guard *test-system*) #'guard))
+
+(let (new-person)
+  (setf *guard* nil)
+  (setf new-person (execute *test-system* (make-transaction 'tx-create-person "John" "Doe")))
+  (assert *guard*)
+  (setf *guard* nil)
+  (execute *test-system* (make-transaction 'tx-delete-person (get-id new-person)))
+  (assert *guard*))
+
+;;; eof

File test/test-serialization.lisp

+;;;; -*- mode: Lisp -*-
+;;;;
+;;;; $Id$
+;;;;
+;;;; Testing XML and S-Expression based Serialization for Common Lisp and CLOS
+;;;;
+;;;; Copyright (C) 2003, 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :s-serialization)
+
+(defun serialize-and-deserialize (object)
+  (with-input-from-string
+    (in (with-output-to-string (out)
+	  (serialize-xml object out)))
+    (deserialize-xml in))
+  (with-input-from-string
+    (in (with-output-to-string (out)
+	  (serialize-sexp object out)))
+    (deserialize-sexp in)))
+
+;; primitives
+
+(assert
+ (null (serialize-and-deserialize nil)))
+
+(assert
+ (eq (serialize-and-deserialize t)
+     t))
+
+(assert
+ (= (serialize-and-deserialize 100)
+    100))
+
+(assert
+ (= (serialize-and-deserialize (/ 3))
+    (/ 3)))
+
+(assert
+ (= (serialize-and-deserialize pi)
+    pi))
+
+(assert
+ (= (serialize-and-deserialize (complex 1.5 2.5))
+    (complex 1.5 2.5)))
+
+(assert
+ (eq (serialize-and-deserialize 'foo)
+     'foo))
+
+(assert
+ (eq (serialize-and-deserialize :foo)
+     :foo))
+
+(assert
+ (eq (serialize-and-deserialize 'room)
+     'room))
+
+(assert
+ (equal (serialize-and-deserialize "Hello")
+	"Hello"))
+
+(assert
+ (equal (serialize-and-deserialize "Hello <foo> & </bar>!")
+	"Hello <foo> & </bar>!"))
+
+;; simple sequences
+
+(assert
+ (reduce #'(lambda (x &optional (y t)) (and x y))
+	 (map 'list
+	      #'eql
+	      (serialize-and-deserialize (list 1 2 3))
+	      (list 1 2 3))))
+
+(assert
+ (equal (serialize-and-deserialize (list 1 2 3))
+	(list 1 2 3)))
+
+;; simple objects
+
+(defclass foobar ()
+  ((foo :accessor get-foo :initarg :foo)
+   (bar :accessor get-bar :initarg :bar)))
+
+(defparameter *foobar* (make-instance 'foobar :foo 100 :bar "Bar"))
+
+(assert
+ (let ((foobar (serialize-and-deserialize *foobar*)))
+   (and (equal (get-foo foobar) (get-foo *foobar*))
+	(equal (get-bar foobar) (get-bar *foobar*))
+	(eq (class-of foobar) (class-of *foobar*)))))
+
+;; standard structs
+
+(defstruct foobaz
+  foo
+  baz)
+
+(defparameter *foobaz* (make-foobaz :foo 100 :baz "Baz"))
+
+(assert
+ (let ((foobaz (serialize-and-deserialize *foobaz*)))
+   (and (foobaz-p foobaz)
+	(equal (foobaz-foo foobaz) (foobaz-foo *foobaz*))
+	(equal (foobaz-baz foobaz) (foobaz-baz *foobaz*)))))
+
+;;; hash-tables
+
+(defparameter *hashtable* 
+  (let ((hashtable (make-hash-table :test 'equal)))
+    (map nil
+       #'(lambda (feature) (setf (gethash (symbol-name feature) hashtable) feature))
+       *features*)
+    hashtable))
+
+(let (h2)
+  (setf h2 (serialize-and-deserialize *hashtable*))
+  (maphash #'(lambda (k v) (assert (equal v (gethash k h2)))) *hashtable*) 
+  (maphash #'(lambda (k v) (assert (equal v (gethash k *hashtable*)))) h2))
+
+;;; eof