- cl-prevalence-cvs@common-lisp.net - mailman3.common-lisp.net

[cl-prevalence-cvs] CVS update: cl-prevalence/src/serialization.lisp
by scaekenberghe＠common-lisp.net 22 Jan '05

22 Jan '05

Update of /project/cl-prevalence/cvsroot/cl-prevalence/src In directory common-lisp.net:/tmp/cvs-serv5673/src Modified Files: serialization.lisp Log Message: added serialization support for characters (suggested by ian eslick) Date: Sat Jan 22 11:23:55 2005 Author: scaekenberghe Index: cl-prevalence/src/serialization.lisp diff -u cl-prevalence/src/serialization.lisp:1.7 cl-prevalence/src/serialization.lisp:1.8 --- cl-prevalence/src/serialization.lisp:1.7 Fri Jan 21 01:05:01 2005 +++ cl-prevalence/src/serialization.lisp Sat Jan 22 11:23:54 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: Lisp -*- ;;;; -;;;; $Id: serialization.lisp,v 1.7 2005/01/21 09:05:01 scaekenberghe Exp $ +;;;; $Id: serialization.lisp,v 1.8 2005/01/22 19:23:54 scaekenberghe Exp $ ;;;; ;;;; XML and S-Expression based Serialization for Common Lisp and CLOS ;;;; @@ -204,6 +204,12 @@ (s-xml:print-string-xml object stream) (write-string "</STRING>" stream)) +(defmethod serialize-xml-internal ((object character) stream serialization-state) + (declare (ignore serialization-state)) + (write-string "<CHARACTER>" stream) + (s-xml:print-string-xml (princ-to-string object) stream) + (write-string "</CHARACTER>" stream)) + (defmethod serialize-xml-internal ((object symbol) stream serialization-state) (declare (ignore serialization-state)) (write-string "<SYMBOL>" stream) @@ -222,6 +228,10 @@ (declare (ignore serialization-state)) (prin1 object stream)) +(defmethod serialize-sexp-internal ((object character) 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)) @@ -457,6 +467,7 @@ (:null nil) (:true t) (:string (or seed "")) + (:character (char seed 0)) (:key (car seed)) (:value (car seed)) (:entry (nreverse seed))

1 0

[cl-prevalence-cvs] CVS update: cl-prevalence/ChangeLog
by scaekenberghe＠common-lisp.net 22 Jan '05

22 Jan '05

Update of /project/cl-prevalence/cvsroot/cl-prevalence In directory common-lisp.net:/tmp/cvs-serv5673 Added Files: ChangeLog Log Message: added serialization support for characters (suggested by ian eslick) Date: Sat Jan 22 11:23:53 2005 Author: scaekenberghe

1 0

[cl-prevalence-cvs] CVS update: cl-prevalence/src/serialization.lisp
by scaekenberghe＠common-lisp.net 21 Jan '05

21 Jan '05

Update of /project/cl-prevalence/cvsroot/cl-prevalence/src In directory common-lisp.net:/tmp/cvs-serv30145 Modified Files: serialization.lisp Log Message: implemented sbcl versions of platform dependent mop code (thx to Peter Scott) Date: Fri Jan 21 01:05:02 2005 Author: scaekenberghe Index: cl-prevalence/src/serialization.lisp diff -u cl-prevalence/src/serialization.lisp:1.6 cl-prevalence/src/serialization.lisp:1.7 --- cl-prevalence/src/serialization.lisp:1.6 Mon Oct 4 08:13:15 2004 +++ cl-prevalence/src/serialization.lisp Fri Jan 21 01:05:01 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: Lisp -*- ;;;; -;;;; $Id: serialization.lisp,v 1.6 2004/10/04 15:13:15 scaekenberghe Exp $ +;;;; $Id: serialization.lisp,v 1.7 2005/01/21 09:05:01 scaekenberghe Exp $ ;;;; ;;;; XML and S-Expression based Serialization for Common Lisp and CLOS ;;;; @@ -121,6 +121,8 @@ (mapcar #'car (if (symbolp (caar slots)) slots (cdr slots)))) #+cmu (mapcar #'pcl:slot-definition-name (pcl:class-slots (class-of object))) + #+sbcl + (mapcar #'sb-pcl:slot-definition-name (sb-pcl:class-slots (class-of object))) #+lispworks (structure:structure-class-slot-names (class-of object)) #+allegro @@ -138,6 +140,8 @@ (class-of object))) #+cmu (mapcar #'pcl:slot-definition-name (pcl:class-slots (class-of object))) + #+sbcl + (mapcar #'sb-pcl:slot-definition-name (sb-pcl:class-slots (class-of object))) #+lispworks (mapcar #'hcl:slot-definition-name (hcl:class-slots (class-of object))) #+allegro

1 0

[cl-prevalence-cvs] CVS update: cl-prevalence/src/package.lisp
by scaekenberghe＠common-lisp.net 21 Jan '05

21 Jan '05

Update of /project/cl-prevalence/cvsroot/cl-prevalence/src In directory common-lisp.net:/tmp/cvs-serv30121 Modified Files: package.lisp Log Message: added exports for index-related api Date: Fri Jan 21 01:02:36 2005 Author: scaekenberghe Index: cl-prevalence/src/package.lisp diff -u cl-prevalence/src/package.lisp:1.5 cl-prevalence/src/package.lisp:1.6 --- cl-prevalence/src/package.lisp:1.5 Mon Oct 4 07:25:13 2004 +++ cl-prevalence/src/package.lisp Fri Jan 21 01:02:35 2005 @@ -1,6 +1,6 @@ ;;;; -*- Mode: LISP -*- ;;;; -;;;; $Id: package.lisp,v 1.5 2004/10/04 14:25:13 scaekenberghe Exp $ +;;;; $Id: package.lisp,v 1.6 2005/01/21 09:02:35 scaekenberghe Exp $ ;;;; ;;;; Package definitions for the CL-PREVALENCE project ;;;; @@ -74,6 +74,9 @@ #:get-preference #:all-preferences-keys #:tx-set-preference + #:index-on + #:drop-index-on + #:find-object-with-slot #:start-master-client #:stop-master-client

1 0

[cl-prevalence-cvs] CVS update: cl-prevalence/src/managed-prevalence.lisp
by Sven Van Caekenberghe 05 Oct '04

05 Oct '04

Update of /project/cl-prevalence/cvsroot/cl-prevalence/src In directory common-lisp.net:/tmp/cvs-serv1797/src Modified Files: managed-prevalence.lisp Log Message: added a fallback for find-object-with-slot in case there are no indexes Date: Tue Oct 5 13:44:36 2004 Author: scaekenberghe Index: cl-prevalence/src/managed-prevalence.lisp diff -u cl-prevalence/src/managed-prevalence.lisp:1.2 cl-prevalence/src/managed-prevalence.lisp:1.3 --- cl-prevalence/src/managed-prevalence.lisp:1.2 Tue Oct 5 13:35:28 2004 +++ cl-prevalence/src/managed-prevalence.lisp Tue Oct 5 13:44:36 2004 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: managed-prevalence.lisp,v 1.2 2004/10/05 11:35:28 scaekenberghe Exp $ +;;;; $Id: managed-prevalence.lisp,v 1.3 2004/10/05 11:44:36 scaekenberghe Exp $ ;;;; ;;;; 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. @@ -58,18 +58,19 @@ (when index (gethash id index)))) -(defgeneric find-object-with-slot (system class slot value) - (:documentation "Find and return the object in system of class with slot, null if not found")) +(defgeneric find-object-with-slot (system class slot value &optional (test #'equalp)) + (:documentation "Find and return the object in system of class with slot equal to value, null if not found")) -(defmethod find-object-with-slot ((system prevalence-system) class slot value) - "Find and return the object in system of class with slot, null if not found. - This constitutes some duplicated effort with FIND-OBJECT-WITH-ID." +(defmethod find-object-with-slot ((system prevalence-system) class slot value &optional (test #'equalp)) + "Find and return the object in system of class with slot equal to value, null if not found" (let* ((index-name (get-objects-slot-index-name class slot)) (index (get-root-object system index-name))) - (when index - (find-object-with-id system class (gethash value index))))) + (if index + (find-object-with-id system class (gethash value index)) + (find value (find-all-objects system class) + :key #'(lambda (object) (slot-value object slot)) :test test)))) -(defun tx-create-objects-slot-index (system class slot &optional (test 'equalp)) +(defun tx-create-objects-slot-index (system class slot &optional (test #'equalp)) "Create an index for this object on this slot, with an optional test for the hash table (add existing objects)" (let ((index-name (get-objects-slot-index-name class slot))) (unless (get-root-object system index-name)

1 0

[cl-prevalence-cvs] CVS update: cl-prevalence/test/test-managed-prevalence.lisp cl-prevalence/test/test-prevalence.lisp
by Sven Van Caekenberghe 05 Oct '04

05 Oct '04

Update of /project/cl-prevalence/cvsroot/cl-prevalence/test In directory common-lisp.net:/tmp/cvs-serv1751/test Modified Files: test-prevalence.lisp Added Files: test-managed-prevalence.lisp Log Message: merged in a contribution from randall randall: you can now create indexes on slots using index-on (or delete them using drop-index-on) and query using those indexes using find-object-with-slot Date: Tue Oct 5 13:35:31 2004 Author: scaekenberghe Index: cl-prevalence/test/test-prevalence.lisp diff -u cl-prevalence/test/test-prevalence.lisp:1.2 cl-prevalence/test/test-prevalence.lisp:1.3 --- cl-prevalence/test/test-prevalence.lisp:1.2 Fri Jun 25 18:19:05 2004 +++ cl-prevalence/test/test-prevalence.lisp Tue Oct 5 13:35:30 2004 @@ -1,6 +1,6 @@ ;;;; -*- mode: Lisp -*- ;;;; -;;;; $Id: test-prevalence.lisp,v 1.2 2004/06/25 16:19:05 scaekenberghe Exp $ +;;;; $Id: test-prevalence.lisp,v 1.3 2004/10/05 11:35:30 scaekenberghe Exp $ ;;;; ;;;; Testing Object Prevalence in Common Lisp ;;;; @@ -33,12 +33,6 @@ (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)))

1 0

[cl-prevalence-cvs] CVS update: cl-prevalence/src/managed-prevalence.lisp
by Sven Van Caekenberghe 05 Oct '04

05 Oct '04

Update of /project/cl-prevalence/cvsroot/cl-prevalence/src In directory common-lisp.net:/tmp/cvs-serv1751/src Modified Files: managed-prevalence.lisp Log Message: merged in a contribution from randall randall: you can now create indexes on slots using index-on (or delete them using drop-index-on) and query using those indexes using find-object-with-slot Date: Tue Oct 5 13:35:28 2004 Author: scaekenberghe Index: cl-prevalence/src/managed-prevalence.lisp diff -u cl-prevalence/src/managed-prevalence.lisp:1.1.1.1 cl-prevalence/src/managed-prevalence.lisp:1.2 --- cl-prevalence/src/managed-prevalence.lisp:1.1.1.1 Sun Jun 20 21:13:38 2004 +++ cl-prevalence/src/managed-prevalence.lisp Tue Oct 5 13:35:28 2004 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: managed-prevalence.lisp,v 1.1.1.1 2004/06/20 19:13:38 scaekenberghe Exp $ +;;;; $Id: managed-prevalence.lisp,v 1.2 2004/10/05 11:35:28 scaekenberghe Exp $ ;;;; ;;;; 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. @@ -34,10 +34,11 @@ (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))) +(defun get-objects-slot-index-name (class &optional (slot 'id)) + "Return the keyword symbol naming the specified index of instances of class." + (let ((classname (if (symbolp class) (string class) (class-name class))) + (slotname (symbol-name slot))) + (intern (concatenate 'string classname "-" slotname "-INDEX") :keyword))) (defgeneric find-all-objects (system class) (:documentation "Return an unordered collection of all objects in system that are instances of class")) @@ -52,33 +53,84 @@ (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)) + (let* ((index-name (get-objects-slot-index-name class 'id)) (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)))) +(defgeneric find-object-with-slot (system class slot value) + (:documentation "Find and return the object in system of class with slot, null if not found")) + +(defmethod find-object-with-slot ((system prevalence-system) class slot value) + "Find and return the object in system of class with slot, null if not found. + This constitutes some duplicated effort with FIND-OBJECT-WITH-ID." + (let* ((index-name (get-objects-slot-index-name class slot)) + (index (get-root-object system index-name))) + (when index + (find-object-with-id system class (gethash value index))))) + +(defun tx-create-objects-slot-index (system class slot &optional (test 'equalp)) + "Create an index for this object on this slot, with an optional test for the hash table (add existing objects)" + (let ((index-name (get-objects-slot-index-name class slot))) + (unless (get-root-object system index-name) + (let ((index (make-hash-table :test test))) + (setf (get-root-object system index-name) index) + (dolist (object (find-all-objects system class)) + (add-object-to-slot-index system class slot object)))))) + +(defun tx-remove-objects-slot-index (system class slot) + "Remove an index for this object on this slot" + (let ((index-name (get-objects-slot-index-name class slot))) + (unless (get-root-object system index-name) + (remove-root-object system index-name)))) + +(defun add-object-to-slot-index (system class slot object) + "Add an index entry using this slot to this object" + (let* ((index-name (get-objects-slot-index-name class slot)) + (index (get-root-object system index-name))) + (when (and index (slot-boundp object slot)) + (setf (gethash (slot-value object slot) index) (get-id object))))) + +(defun remove-object-from-slot-index (system class slot object) + "Remove the index entry using this slot to this object" + (let* ((index-name (get-objects-slot-index-name class slot)) + (index (get-root-object system index-name))) + (when (and index (slot-boundp object slot)) + (remhash (slot-value object slot) index)))) + +(defun index-on (system class &optional slots (test 'equalp)) + "Create indexes on each of the slots provided." + (dolist (slot slots) + (execute-transaction (tx-create-objects-slot-index system class slot test)))) + +(defun drop-index-on (system class &optional slots) + "Drop indexes on each of the slots provided" + (dolist (slot slots) + (execute-transaction (tx-remove-objects-slot-index system class slot)))) + +(defun slot-value-changed-p (object slot value) + "Return true when slot in object is not eql to value (or when the slot was unbound)" + (or (not (slot-boundp object slot)) + (not (eql (slot-value object slot) value)))) -(defun tx-create-object (system &optional class slots-and-values) +(defun tx-create-object (system class &optional 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-name (get-objects-slot-index-name class 'id)) (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))) + (setf (gethash id index) object) + (tx-change-object-slots system class id slots-and-values) + object)) (defun tx-delete-object (system class id) - "Delete the object of class with if from the system" + "Delete the object of class with id 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))) + (index-name (get-objects-slot-index-name class 'id))) (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)))) @@ -86,10 +138,13 @@ (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)))) - + (unless object (error "no object of class ~a with id ~d found in ~s" system class id)) + (loop :for (slot value) :in slots-and-values + :do (when (slot-value-changed-p object slot value) + (remove-object-from-slot-index system class slot object) + (setf (slot-value object slot) value) + (add-object-to-slot-index system class slot object))))) + ;; We use a simple id counter to generate unique object identifiers (defun tx-create-id-counter (system)

1 0

[cl-prevalence-cvs] CVS update: cl-prevalence/src/serialization.lisp
by Sven Van Caekenberghe 04 Oct '04

04 Oct '04

Update of /project/cl-prevalence/cvsroot/cl-prevalence/src In directory common-lisp.net:/tmp/cvs-serv23652/src Modified Files: serialization.lisp Log Message: added code to deal with unbound slots when serializing (noted by anthony juckel) and code to deal with missing slots when deserializing Date: Mon Oct 4 17:13:15 2004 Author: scaekenberghe Index: cl-prevalence/src/serialization.lisp diff -u cl-prevalence/src/serialization.lisp:1.5 cl-prevalence/src/serialization.lisp:1.6 --- cl-prevalence/src/serialization.lisp:1.5 Mon Oct 4 16:41:37 2004 +++ cl-prevalence/src/serialization.lisp Mon Oct 4 17:13:15 2004 @@ -1,6 +1,6 @@ ;;;; -*- mode: Lisp -*- ;;;; -;;;; $Id: serialization.lisp,v 1.5 2004/10/04 14:41:37 scaekenberghe Exp $ +;;;; $Id: serialization.lisp,v 1.6 2004/10/04 15:13:15 scaekenberghe Exp $ ;;;; ;;;; XML and S-Expression based Serialization for Common Lisp and CLOS ;;;; @@ -384,13 +384,13 @@ (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)) + (loop :for slot :in (get-serializable-slots serialization-state object) + :do (when (slot-boundp object 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))) (write-string "</OBJECT>" stream))))) (defmethod serialize-sexp-internal ((object standard-object) stream serialization-state) @@ -408,13 +408,13 @@ (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)) + (loop :for slot :in serializable-slots + :do (when (slot-boundp object slot) + (write-string " (" stream) + (print-symbol slot stream) + (write-string " . " stream) + (serialize-sexp-internal (slot-value object slot) stream serialization-state) + (write-string ")" stream)))) (write-string " ) )" stream))))) ;;; Deserialize CLOS instances and Lisp primitives from the XML representation @@ -464,11 +464,13 @@ (: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))))) + (when (slot-exists-p object (car pair)) + (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))))) + (when (slot-exists-p object (car pair)) + (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) @@ -505,16 +507,18 @@ (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))) + (when (slot-exists-p object (first slot)) + (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))) + (when (slot-exists-p object (first slot)) + (setf (slot-value object (first slot)) + (deserialize-sexp-internal (rest slot) deserialized-objects)))) object))) (:ref (gethash (rest sexp) deserialized-objects)))))

1 0

[cl-prevalence-cvs] CVS update: cl-prevalence/test/test-serialization.lisp
by Sven Van Caekenberghe 04 Oct '04

04 Oct '04

Update of /project/cl-prevalence/cvsroot/cl-prevalence/test In directory common-lisp.net:/tmp/cvs-serv22666/test Modified Files: test-serialization.lisp Log Message: now testing xml and sexp serialization seperately, added empty string test thanks to randall randall Date: Mon Oct 4 16:52:52 2004 Author: scaekenberghe Index: cl-prevalence/test/test-serialization.lisp diff -u cl-prevalence/test/test-serialization.lisp:1.1.1.1 cl-prevalence/test/test-serialization.lisp:1.2 --- cl-prevalence/test/test-serialization.lisp:1.1.1.1 Sun Jun 20 21:13:42 2004 +++ cl-prevalence/test/test-serialization.lisp Mon Oct 4 16:52:52 2004 @@ -1,6 +1,6 @@ ;;;; -*- mode: Lisp -*- ;;;; -;;;; $Id: test-serialization.lisp,v 1.1.1.1 2004/06/20 19:13:42 scaekenberghe Exp $ +;;;; $Id: test-serialization.lisp,v 1.2 2004/10/04 14:52:52 scaekenberghe Exp $ ;;;; ;;;; Testing XML and S-Expression based Serialization for Common Lisp and CLOS ;;;; @@ -12,11 +12,13 @@ (in-package :s-serialization) -(defun serialize-and-deserialize (object) +(defun serialize-and-deserialize-xml (object) (with-input-from-string (in (with-output-to-string (out) (serialize-xml object out))) - (deserialize-xml in)) + (deserialize-xml in))) + +(defun serialize-and-deserialize-sexp (object) (with-input-from-string (in (with-output-to-string (out) (serialize-sexp object out))) @@ -25,46 +27,97 @@ ;; primitives (assert - (null (serialize-and-deserialize nil))) + (null (serialize-and-deserialize-xml nil))) + +(assert + (null (serialize-and-deserialize-sexp nil))) (assert - (eq (serialize-and-deserialize t) + (eq (serialize-and-deserialize-xml t) t)) (assert - (= (serialize-and-deserialize 100) + (eq (serialize-and-deserialize-sexp t) + t)) + +(assert + (= (serialize-and-deserialize-xml 100) + 100)) + +(assert + (= (serialize-and-deserialize-sexp 100) 100)) (assert - (= (serialize-and-deserialize (/ 3)) + (= (serialize-and-deserialize-xml (/ 3)) (/ 3))) (assert - (= (serialize-and-deserialize pi) + (= (serialize-and-deserialize-sexp (/ 3)) + (/ 3))) + +(assert + (= (serialize-and-deserialize-xml pi) + pi)) + +(assert + (= (serialize-and-deserialize-sexp pi) pi)) (assert - (= (serialize-and-deserialize (complex 1.5 2.5)) + (= (serialize-and-deserialize-xml (complex 1.5 2.5)) + (complex 1.5 2.5))) + +(assert + (= (serialize-and-deserialize-sexp (complex 1.5 2.5)) (complex 1.5 2.5))) (assert - (eq (serialize-and-deserialize 'foo) + (eq (serialize-and-deserialize-xml 'foo) + 'foo)) + +(assert + (eq (serialize-and-deserialize-sexp 'foo) 'foo)) (assert - (eq (serialize-and-deserialize :foo) + (eq (serialize-and-deserialize-xml :foo) :foo)) (assert - (eq (serialize-and-deserialize 'room) + (eq (serialize-and-deserialize-sexp :foo) + :foo)) + +(assert + (eq (serialize-and-deserialize-xml 'room) 'room)) (assert - (equal (serialize-and-deserialize "Hello") + (eq (serialize-and-deserialize-sexp 'room) + 'room)) + +(assert + (equal (serialize-and-deserialize-xml "Hello") + "Hello")) + +(assert + (equal (serialize-and-deserialize-sexp "Hello") "Hello")) +(assert + (equal (serialize-and-deserialize-xml "") + "")) + +(assert + (equal (serialize-and-deserialize-sexp "") + "")) + +(assert + (equal (serialize-and-deserialize-xml "Hello <foo> & </bar>!") + "Hello <foo> & </bar>!")) + (assert - (equal (serialize-and-deserialize "Hello <foo> & </bar>!") + (equal (serialize-and-deserialize-sexp "Hello <foo> & </bar>!") "Hello <foo> & </bar>!")) ;; simple sequences @@ -73,11 +126,22 @@ (reduce #'(lambda (x &optional (y t)) (and x y)) (map 'list #'eql - (serialize-and-deserialize (list 1 2 3)) + (serialize-and-deserialize-xml (list 1 2 3)) (list 1 2 3)))) (assert - (equal (serialize-and-deserialize (list 1 2 3)) + (reduce #'(lambda (x &optional (y t)) (and x y)) + (map 'list + #'eql + (serialize-and-deserialize-sexp (list 1 2 3)) + (list 1 2 3)))) + +(assert + (equal (serialize-and-deserialize-xml (list 1 2 3)) + (list 1 2 3))) + +(assert + (equal (serialize-and-deserialize-sexp (list 1 2 3)) (list 1 2 3))) ;; simple objects @@ -89,7 +153,13 @@ (defparameter *foobar* (make-instance 'foobar :foo 100 :bar "Bar")) (assert - (let ((foobar (serialize-and-deserialize *foobar*))) + (let ((foobar (serialize-and-deserialize-xml *foobar*))) + (and (equal (get-foo foobar) (get-foo *foobar*)) + (equal (get-bar foobar) (get-bar *foobar*)) + (eq (class-of foobar) (class-of *foobar*))))) + +(assert + (let ((foobar (serialize-and-deserialize-sexp *foobar*))) (and (equal (get-foo foobar) (get-foo *foobar*)) (equal (get-bar foobar) (get-bar *foobar*)) (eq (class-of foobar) (class-of *foobar*))))) @@ -103,7 +173,13 @@ (defparameter *foobaz* (make-foobaz :foo 100 :baz "Baz")) (assert - (let ((foobaz (serialize-and-deserialize *foobaz*))) + (let ((foobaz (serialize-and-deserialize-xml *foobaz*))) + (and (foobaz-p foobaz) + (equal (foobaz-foo foobaz) (foobaz-foo *foobaz*)) + (equal (foobaz-baz foobaz) (foobaz-baz *foobaz*))))) + +(assert + (let ((foobaz (serialize-and-deserialize-sexp *foobaz*))) (and (foobaz-p foobaz) (equal (foobaz-foo foobaz) (foobaz-foo *foobaz*)) (equal (foobaz-baz foobaz) (foobaz-baz *foobaz*))))) @@ -118,7 +194,12 @@ hashtable)) (let (h2) - (setf h2 (serialize-and-deserialize *hashtable*)) + (setf h2 (serialize-and-deserialize-xml *hashtable*)) + (maphash #'(lambda (k v) (assert (equal v (gethash k h2)))) *hashtable*) + (maphash #'(lambda (k v) (assert (equal v (gethash k *hashtable*)))) h2)) + +(let (h2) + (setf h2 (serialize-and-deserialize-sexp *hashtable*)) (maphash #'(lambda (k v) (assert (equal v (gethash k h2)))) *hashtable*) (maphash #'(lambda (k v) (assert (equal v (gethash k *hashtable*)))) h2))

1 0

[cl-prevalence-cvs] CVS update: cl-prevalence/src/serialization.lisp
by Sven Van Caekenberghe 04 Oct '04

04 Oct '04

Update of /project/cl-prevalence/cvsroot/cl-prevalence/src In directory common-lisp.net:/tmp/cvs-serv21752/src Modified Files: serialization.lisp Log Message: added serializable-slots implementation for sbcl thanks to Anthony W. Juckel Date: Mon Oct 4 16:41:37 2004 Author: scaekenberghe Index: cl-prevalence/src/serialization.lisp diff -u cl-prevalence/src/serialization.lisp:1.4 cl-prevalence/src/serialization.lisp:1.5 --- cl-prevalence/src/serialization.lisp:1.4 Mon Oct 4 16:25:13 2004 +++ cl-prevalence/src/serialization.lisp Mon Oct 4 16:41:37 2004 @@ -1,6 +1,6 @@ ;;;; -*- mode: Lisp -*- ;;;; -;;;; $Id: serialization.lisp,v 1.4 2004/10/04 14:25:13 scaekenberghe Exp $ +;;;; $Id: serialization.lisp,v 1.5 2004/10/04 14:41:37 scaekenberghe Exp $ ;;;; ;;;; XML and S-Expression based Serialization for Common Lisp and CLOS ;;;; @@ -124,7 +124,11 @@ #+lispworks (structure:structure-class-slot-names (class-of object)) #+allegro - (mapcar #'mop:slot-definition-name (mop:class-slots (class-of object)))) + (mapcar #'mop:slot-definition-name (mop:class-slots (class-of object))) + #+sbcl + (mapcar #'sb-mop:slot-definition-name (sb-mop:class-slots (class-of object))) + #-(or openmcl cmu lispworks allegro sbcl) + (error "not yet implemented")) (defmethod serializable-slots ((object standard-object)) #+openmcl @@ -137,7 +141,11 @@ #+lispworks (mapcar #'hcl:slot-definition-name (hcl:class-slots (class-of object))) #+allegro - (mapcar #'mop:slot-definition-name (mop:class-slots (class-of object)))) + (mapcar #'mop:slot-definition-name (mop:class-slots (class-of object))) + #+sbcl + (mapcar #'sb-mop:slot-definition-name (sb-mop:class-slots (class-of object))) + #-(or openmcl cmu lispworks allegro sbcl) + (error "not yet implemented")) (defmethod get-serializable-slots ((serialization-state serialization-state) object) (with-slots (known-slots) serialization-state

1 0