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

Modified Files: serialization.lisp Log Message: added patches and tests contributed by Henrik Hjelte (henrik@evahjelte.com) to (de)serialize improper lists and conses

--- /project/cl-prevalence/cvsroot/cl-prevalence/src/serialization.lisp 2005/01/24 10:04:15 1.9 +++ /project/cl-prevalence/cvsroot/cl-prevalence/src/serialization.lisp 2006/01/31 12:41:48 1.10 @@ -1,6 +1,6 @@ ;;;; -*- mode: Lisp -*- ;;;; -;;;; $Id: serialization.lisp,v 1.9 2005/01/24 10:04:15 scaekenberghe Exp $ +;;;; $Id: serialization.lisp,v 1.10 2006/01/31 12:41:48 scaekenberghe Exp $ ;;;; ;;;; XML and S-Expression based Serialization for Common Lisp and CLOS ;;;; @@ -244,51 +244,88 @@ (declare (ignore serialization-state)) (print-symbol object stream))

+(defun sequence-type-and-length(sequence) + (if (listp sequence) + (handler-case + (let ((length (list-length sequence))) + (if length + (values :proper-list length) + (values :circular-list nil))) + (type-error () + (values :dotted-list nil))) + (values :proper-sequence (length sequence)))) + (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))))) + (flet ((proper-sequence (length) + (let ((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 stream) + (write-string "">" stream) + (map nil + #'(lambda (element) + (serialize-xml-internal element stream serialization-state)) + object) + (write-string "</SEQUENCE>" stream))) + (improper-list () + (let ((id (set-known-object serialization-state object))) + (write-string "<CONS ID="" stream) + (prin1 id stream) + (write-string "">" stream) + (serialize-xml-internal (car object) stream serialization-state) + (write-char #\Space stream) + (serialize-xml-internal (cdr object) stream serialization-state) + (write-string "</CONS>" stream)))) + (let ((id (known-object-id serialization-state object))) + (if id + (progn + (write-string "<REF ID="" stream) + (prin1 id stream) + (write-string ""/>" stream)) + (multiple-value-bind (seq-type length) (sequence-type-and-length object) + (ecase seq-type + ((:proper-sequence :proper-list) (proper-sequence length)) + ((:dotted-list :circular-list) (improper-list))))))))

(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))))) + (flet ((proper-sequence (length) + (let ((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))) + (improper-list () + (let ((id (set-known-object serialization-state object))) + (write-string "(:CONS " stream) + (prin1 id stream) + (write-char #\Space stream) + (serialize-sexp-internal (car object) stream serialization-state) + (write-char #\Space stream) + (serialize-sexp-internal (cdr object) stream serialization-state) + (write-string " ) " stream)))) + (let ((id (known-object-id serialization-state object))) + (if id + (progn + (write-string "(:REF . " stream) + (prin1 id stream) + (write-string ")" stream)) + (multiple-value-bind (seq-type length) (sequence-type-and-length object) + (ecase seq-type + ((:proper-sequence :proper-list) (proper-sequence length)) + ((:dotted-list :circular-list) (improper-list))))))))

(defmethod serialize-xml-internal ((object hash-table) stream serialization-state) (let ((id (known-object-id serialization-state object))) @@ -297,23 +334,23 @@ (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))))) + (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))) @@ -322,28 +359,28 @@ (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))))) + (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))) @@ -456,6 +493,9 @@ (class (read-from-string (get-attribute-value :class attributes)))) (setf (gethash id *deserialized-objects*) (make-instance class)))) + (:cons (setf (gethash (parse-integer (get-attribute-value :id attributes)) + *deserialized-objects*) + (cons nil nil))) (:struct (let ((id (parse-integer (get-attribute-value :id attributes))) (class (read-from-string (get-attribute-value :class attributes)))) (setf (gethash id *deserialized-objects*) @@ -483,24 +523,28 @@ (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) + (map-into sequence #'identity (nreverse seed)))) + (:cons (let* ((id (parse-integer (get-attribute-value :id attributes))) + (cons-pair (gethash id *deserialized-objects*))) + (rplaca cons-pair (second seed)) + (rplacd cons-pair (first seed)))) + (:object (let* ((id (parse-integer (get-attribute-value :id attributes))) + (object (gethash id *deserialized-objects*))) + (dolist (pair seed object) (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) + (:struct (let* ((id (parse-integer (get-attribute-value :id attributes))) + (object (gethash id *deserialized-objects*))) + (dolist (pair seed object) (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) - (setf (gethash (car pair) hash-table) (cadr pair))))) - (:ref (let ((id (parse-integer (get-attribute-value :id attributes)))) - (gethash id *deserialized-objects*)))) - parent-seed)) + (: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)) @@ -509,40 +553,46 @@ (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) - (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) - (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))))) + (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) + (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) + (when (slot-exists-p object (first slot)) + (setf (slot-value object (first slot)) + (deserialize-sexp-internal (rest slot) deserialized-objects)))) + object))) + (:cons (destructuring-bind (id cons-car cons-cdr) (rest sexp) + (let ((conspair (cons nil nil))) + (setf (gethash id deserialized-objects) + conspair) + (rplaca conspair (deserialize-sexp-internal cons-car deserialized-objects)) + (rplacd conspair (deserialize-sexp-internal cons-cdr deserialized-objects))))) + (:ref (gethash (rest sexp) deserialized-objects)))))

;;;; eof