[cl-prevalence-cvs] CVS update: cl-prevalence/src/package.lisp cl-prevalence/src/prevalence.lisp
Sven Van Caekenberghe
scaekenberghe at common-lisp.net
Mon Jun 21 15:26:21 UTC 2004
Update of /project/cl-prevalence/cvsroot/cl-prevalence/src
In directory common-lisp.net:/tmp/cvs-serv18557/src
Modified Files:
package.lisp prevalence.lisp
Log Message:
preparing to support new serialization protocol
Date: Mon Jun 21 08:26:21 2004
Author: scaekenberghe
Index: cl-prevalence/src/package.lisp
diff -u cl-prevalence/src/package.lisp:1.2 cl-prevalence/src/package.lisp:1.3
--- cl-prevalence/src/package.lisp:1.2 Mon Jun 21 07:38:39 2004
+++ cl-prevalence/src/package.lisp Mon Jun 21 08:26:21 2004
@@ -1,6 +1,6 @@
;;;; -*- Mode: LISP -*-
;;;;
-;;;; $Id: package.lisp,v 1.2 2004/06/21 14:38:39 scaekenberghe Exp $
+;;;; $Id: package.lisp,v 1.3 2004/06/21 15:26:21 scaekenberghe Exp $
;;;;
;;;; Package definitions for the CL-PREVALENCE project
;;;;
@@ -39,6 +39,7 @@
#:transaction
#:no-rollback-error
#:initiates-rollback
+ #:totally-destroy
#:print-transaction-log #:show-transaction-log #:print-snapshot #:transaction-log-tail
Index: cl-prevalence/src/prevalence.lisp
diff -u cl-prevalence/src/prevalence.lisp:1.1.1.1 cl-prevalence/src/prevalence.lisp:1.2
--- cl-prevalence/src/prevalence.lisp:1.1.1.1 Sun Jun 20 12:13:39 2004
+++ cl-prevalence/src/prevalence.lisp Mon Jun 21 08:26:21 2004
@@ -1,6 +1,6 @@
;;;; -*- mode: Lisp -*-
;;;;
-;;;; $Id: prevalence.lisp,v 1.1.1.1 2004/06/20 19:13:39 scaekenberghe Exp $
+;;;; $Id: prevalence.lisp,v 1.2 2004/06/21 15:26:21 scaekenberghe Exp $
;;;;
;;;; Object Prevalence in Common Lisp
;;;;
@@ -64,6 +64,9 @@
(defgeneric backup (system &key directory)
(:documentation "Make backup copies of the current snapshot and transaction-log files"))
+(defgeneric totally-destroy (system &key abort)
+ (:documentation "Totally destroy system from permanent storage by deleting any files that we find"))
+
;;; Classes
(defclass prevalence-system ()
@@ -81,7 +84,16 @@
:accessor get-transaction-log)
(transaction-log-stream ;; :type stream
:accessor get-transaction-log-stream
- :initform nil))
+ :initform nil)
+ (serializer ;; type function
+ :accessor get-serializer
+ :initform #'serialize-xml)
+ (deserializer ;; type function
+ :accessor get-deserializer
+ :initform #'deserialize-xml)
+ (file-extension ;; type string
+ :accessor get-file-extension
+ :initform "xml"))
(:documentation "Base Prevalence system implementation object"))
(defclass guarded-prevalence-system (prevalence-system)
@@ -114,8 +126,11 @@
(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)))
+ (setf (get-snapshot system) (merge-pathnames (make-pathname :name "snapshot" :type (get-file-extension system))
+ directory)
+ (get-transaction-log system) (merge-pathnames (make-pathname :name "transaction-log"
+ :type (get-file-extension system))
+ directory)))
(restore system))
(defmethod get-transaction-log-stream :before ((system prevalence-system))
@@ -134,11 +149,13 @@
(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"
+ "Totally destroy system from permanent storage by deleting any 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))))
+ (dolist (pathname (directory (merge-pathnames (make-pathname :type (get-file-extension system))
+ (get-directory system))))
+ (delete-file pathname)))
+ (clrhash (get-root-objects system)))
(defmethod print-object ((transaction transaction) stream)
(format stream "#<TRANSACTION ~a ~a>"
@@ -174,7 +191,7 @@
(restore system)))))
(execute-on transaction system)))
(out (get-transaction-log-stream system)))
- (serialize-xml transaction out *serialization-state*)
+ (funcall (get-serializer system) transaction out *serialization-state*)
(terpri out)
(finish-output out)
result))
@@ -212,12 +229,16 @@
(snapshot (get-snapshot system)))
(close-open-streams system)
(when (probe-file snapshot)
- (copy-file snapshot (merge-pathnames (format nil "snapshot-~a.xml" timetag) snapshot)))
+ (copy-file snapshot (merge-pathnames (make-pathname :name (format nil "snapshot-~a" timetag)
+ :type (get-file-extension system))
+ 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*))
+ (funcall (get-serializer system) (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))
+ (copy-file transaction-log (merge-pathnames (make-pathname :name (format nil "transaction-log-~a" timetag)
+ :type (get-file-extension system))
+ transaction-log))
(delete-file transaction-log))))
(defmethod backup ((system prevalence-system) &key directory)
@@ -225,9 +246,11 @@
(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)
+ (transaction-log-backup (merge-pathnames (make-pathname :name (format nil "transaction-log-~a" timetag)
+ :type (get-file-extension system))
(or directory transaction-log)))
- (snapshot-backup (merge-pathnames (format nil "snapshot-~a.xml" timetag)
+ (snapshot-backup (merge-pathnames (make-pathname :name (format nil "snapshot-~a" timetag)
+ :type (get-file-extension system))
(or directory snapshot))))
(close-open-streams system)
(when (probe-file transaction-log)
@@ -242,7 +265,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) (deserialize-xml in *serialization-state*))))
+ (setf (get-root-objects system) (funcall (get-deserializer system) in *serialization-state*))))
(when (probe-file (get-transaction-log system))
(let ((position 0))
(handler-bind ((s-xml:xml-parser-error
@@ -252,7 +275,7 @@
(return-from restore))))
(with-open-file (in (get-transaction-log system) :direction :input)
(loop
- (let ((transaction (deserialize-xml in *serialization-state*)))
+ (let ((transaction (funcall (get-deserializer system) in *serialization-state*)))
(setf position (file-position in))
(if transaction
(execute-on transaction system)
More information about the Cl-prevalence-cvs
mailing list