Update of /project/cl-store/cvsroot/cl-store In directory common-lisp.net:/tmp/cvs-serv23541

Modified Files: ChangeLog circularities.lisp cl-store.asd default-backend.lisp package.lisp plumbing.lisp Log Message: See ChangeLog 2004-09-27

Date: Mon Sep 27 13:24:18 2004 Author: sross

Index: cl-store/ChangeLog diff -u cl-store/ChangeLog:1.7 cl-store/ChangeLog:1.8 --- cl-store/ChangeLog:1.7 Sun Sep 5 16:56:06 2004 +++ cl-store/ChangeLog Mon Sep 27 13:24:18 2004 @@ -1,3 +1,8 @@ +2004-09-27 Sean Ross sdr@jhb.ucs.co.za + * plumbing.lisp: Slightly nicer error handling (I think). + All conditions caught in store and restore are resignalled + and rethrown as a store or restore error respectively. + 2004-09-01 Sean Ross sdr@jhb.ucs.co.za * sbcl/custom.lisp, sbcl/custom-xml.lisp: Custom structure storing. * cmucl/custom.lisp, cmucl/custom-xml.lisp: Custom structure storing.

Index: cl-store/circularities.lisp diff -u cl-store/circularities.lisp:1.6 cl-store/circularities.lisp:1.7 --- cl-store/circularities.lisp:1.6 Mon Aug 30 17:10:20 2004 +++ cl-store/circularities.lisp Mon Sep 27 13:24:18 2004 @@ -116,7 +116,7 @@ (defvar *stored-values*)

-(defmethod backend-store ((obj t) (place t) (backend resolving-backend)) +(defmethod backend-store ((obj t) (place stream) (backend resolving-backend)) "Store OBJ into PLACE. Does the setup for counters and seen values." (let ((*stored-counter* 0) (*stored-values* (make-hash-table :test #'eq))) @@ -185,10 +185,10 @@ (*restored-values* (make-hash-table))) (check-stream-element-type place backend) (check-magic-number place backend) - (let ((obj (backend-restore-object place backend))) + (prog1 + (backend-restore-object place backend) (dolist (fn *need-to-fix*) - (funcall (the function fn))) - obj))) + (funcall (the function fn))))))

(defmethod backend-restore-object ((place t) (backend resolving-backend)) "Retrieve a object from PLACE, does housekeeping for circularity fixing."

Index: cl-store/cl-store.asd diff -u cl-store/cl-store.asd:1.7 cl-store/cl-store.asd:1.8 --- cl-store/cl-store.asd:1.7 Sun Sep 5 16:56:06 2004 +++ cl-store/cl-store.asd Mon Sep 27 13:24:18 2004 @@ -39,7 +39,7 @@ :name "CL-STORE" :author "Sean Ross sdr@jhb.ucs.co.za" :maintainer "Sean Ross sdr@jhb.ucs.co.za" - :version "0.2.2" + :version "0.2.3" :description "Serialization package" :long-description "Portable CL Package to serialize data types" :licence "MIT"

Index: cl-store/default-backend.lisp diff -u cl-store/default-backend.lisp:1.5 cl-store/default-backend.lisp:1.6 --- cl-store/default-backend.lisp:1.5 Sun Sep 5 16:56:06 2004 +++ cl-store/default-backend.lisp Mon Sep 27 13:24:18 2004 @@ -3,11 +3,13 @@

;; The cl-store backend.

-;; cater for unicode characters in symbol names -;; Outstanding objects. -;; functions, methods +;; functions ;; closures (once done add initform, and default-initargs) - +;; funcallable instances (methods and generic functions) +;; add variable *store-methods-with-classes* +;; some sort of optimization for bignums +;; cater for unicode characters in symbol names +;; Other MOP classes.

(in-package :cl-store)

@@ -44,6 +46,7 @@ (defconstant +array-code+ (register-code 19 'array)) (defconstant +simple-vector-code+ (register-code 20 'simple-vector)) (defconstant +package-code+ (register-code 21 'package)) +(defconstant +function-code+ (register-code 22 'function))

;; setups for type code mapping (defun output-type-code (code stream)

Index: cl-store/package.lisp diff -u cl-store/package.lisp:1.9 cl-store/package.lisp:1.10 --- cl-store/package.lisp:1.9 Mon Aug 30 17:10:20 2004 +++ cl-store/package.lisp Mon Sep 27 13:24:18 2004 @@ -18,6 +18,7 @@ #:*store-class-slots* #:*nuke-existing-classes* #:*store-class-superclasses* + #:cl-store-error #:store-error #:restore-error #:store

Index: cl-store/plumbing.lisp diff -u cl-store/plumbing.lisp:1.1 cl-store/plumbing.lisp:1.2 --- cl-store/plumbing.lisp:1.1 Tue Aug 17 13:12:43 2004 +++ cl-store/plumbing.lisp Mon Sep 27 13:24:18 2004 @@ -21,22 +21,29 @@

;; conditions -;; Should these be the only errors that are thrown -;; from store and restore? -(define-condition store-error () - ((format-string :accessor format-string :initarg :format-string :initform "Unknown") +;; From 0.2.3 all conditions which are signalled from +;; store or restore will be rethrown as store-error and +;; restore-error respectively. The original condition +;; is still signalled. +(define-condition cl-store-error (condition) + ((caused-by :accessor caused-by :initarg :caused-by + :initform nil) + (format-string :accessor format-string :initarg :format-string + :initform "Unknown") (format-args :accessor format-args :initarg :format-args :initform nil)) (:report (lambda (condition stream) - (apply #'format stream (format-string condition) - (format-args condition)))) + (aif (caused-by condition) + (format stream "~A" it) + (apply #'format stream (format-string condition) + (format-args condition))))) + (:documentation "Root cl-store condition")) + +(define-condition store-error (cl-store-error) + () (:documentation "Error thrown when storing an object fails."))

-(define-condition restore-error () - ((format-string :accessor format-string :initarg :format-string :initform "Unknown") - (format-args :accessor format-args :initarg :format-args :initform nil)) - (:report (lambda (condition stream) - (apply #'format stream (format-string condition) - (format-args condition)))) +(define-condition restore-error (cl-store-error) + () (:documentation "Error thrown when restoring an object fails."))

(defun store-error (format-string &rest args) @@ -46,6 +53,8 @@ (error 'restore-error :format-string format-string :format-args args))

+ + ;; entry points (defun store-to-file (obj place backend) (let* ((backend-type (stream-type backend)) @@ -54,33 +63,36 @@ (integer '(unsigned-byte 8))))) (with-open-file (s place :element-type element-type :direction :output :if-exists :supersede) - (store obj s backend)))) + (backend-store obj s backend))))

(defgeneric store (obj place &optional backend) (:documentation "Entry Point for storing objects.") - (:method ((obj t) (place stream) &optional (backend *default-backend*)) + (:method ((obj t) (place t) &optional (backend *default-backend*)) "Store OBJ into Stream PLACE using backend BACKEND." (let ((*current-backend* backend)) - (backend-store obj place backend))) - (:method ((obj t) (place string) &optional (backend *default-backend*)) - "Store OBJ into file designator PLACE using backend BACKEND." - (store-to-file obj place backend)) - (:method ((obj t) (place pathname) &optional (backend *default-backend*)) - "Store OBJ into file designator PLACE using backend BACKEND." - (store-to-file obj place backend))) - + (handler-case (backend-store obj place backend) + (condition (c) + (signal c) + (error (make-condition 'store-error + :caused-by c)))))))

(defgeneric backend-store (obj place backend) (:argument-precedence-order backend place obj) - (:documentation "Method wrapped by store, override this method for -custom behaviour (see circularities.lisp).") - (:method ((obj t) (place t) (backend t)) + (:method ((obj t) (place stream) (backend t)) "The default. Checks the streams element-type, stores the backend code and calls store-object." (check-stream-element-type place backend) (store-backend-code place backend) (store-object obj place backend) - obj)) + obj) + (:method ((obj t) (place string) (backend t)) + "Store OBJ into file designator PLACE." + (store-to-file obj place backend)) + (:method ((obj t) (place pathname) (backend t)) + "Store OBJ into file designator PLACE." + (store-to-file obj place backend)) + (:documentation "Method wrapped by store, override this method for + custom behaviour (see circularities.lisp)."))

@@ -131,7 +143,10 @@ (:method (place &optional (backend *default-backend*)) "Entry point for restoring objects (setfable)." (let ((*current-backend* backend)) - (backend-restore place backend)))) + (handler-case (backend-restore place backend) + (condition (c) (signal c) + (error (make-condition 'restore-error + :caused-by c)))))))

(defgeneric backend-restore (place backend) (:argument-precedence-order backend place)