[cl-prevalence-cvs] CVS cl-prevalence/src
scaekenberghe
scaekenberghe at common-lisp.net
Tue Jan 31 12:41:48 UTC 2006
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 at 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
More information about the Cl-prevalence-cvs
mailing list