Commits

Anonymous committed 904bc48

added patches and tests contributed by Henrik Hjelte (henrik@evahjelte.com) to (de)serialize improper lists and conses

Comments (0)

Files changed (4)

+2006-01-31 Sven Van Caekenberghe <svc@mac.com>
+
+	* added patches contributed by Henrik Hjelte (henrik@evahjelte.com) to (de)serialize improper lists and conses
+
 2005-01-22 Sven Van Caekenberghe <svc@mac.com>
 
         * added serialization support for characters (suggested by ian eslick) 

src/serialization.lisp

   (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)))
 	  (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)))
 	  (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)))
 		   (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*)
 		   (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))
 (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

test/test-prevalence.lisp

 
 (defun tx-create-person (system firstname lastname)
   (let* ((persons (get-root-object system :persons))
-	 (id (tx-get-next-id system))
+	 (id (next-id system))
 	 (person (make-instance 'person :id id :firstname firstname :lastname lastname)))
     (setf (gethash id persons) person)))
 

test/test-serialization.lisp

  (equal (serialize-and-deserialize-sexp (list 1 2 3))
 	(list 1 2 3)))
 
+(assert
+ (equal (serialize-and-deserialize-xml (cons 1 2))
+        (cons 1 2)))
+
+(assert
+ (equal (serialize-and-deserialize-sexp (cons 1 2))
+        (cons 1 2)))
+
+(assert 
+ (equal (serialize-and-deserialize-xml '(1 2 3 4 5 6 7 8 9 . 0))
+        '(1 2 3 4 5 6 7 8 9 . 0)))
+
+(assert 
+ (equal (serialize-and-deserialize-sexp '(1 2 3 4 5 6 7 8 9 . 0))
+        '(1 2 3 4 5 6 7 8 9 . 0)))
+
+(assert
+ (equal (serialize-and-deserialize-xml (cons 'hi 2))
+	(cons 'hi 2)))
+
+(assert
+ (equal (serialize-and-deserialize-sexp (cons 'hi 2))
+	(cons 'hi 2)))
+
+(defun circular-list (&rest elements)
+   (let ((cycle (copy-list elements))) 
+     (nconc cycle cycle)))
+
+(assert
+ (equal (third (serialize-and-deserialize-sexp (circular-list 'a 'b)))
+        'a))
+(assert
+ (equal (third (serialize-and-deserialize-xml (circular-list 'a 'b)))
+        'a))
+
+(assert
+ (equal (serialize-and-deserialize-xml (cons 'hi 2))
+	(cons 'hi 2)))
+
+(assert
+ (equal (serialize-and-deserialize-sexp (cons 'hi 2))
+	(cons 'hi 2)))
+
+(assert
+ (equal (third (serialize-and-deserialize-sexp (circular-list 'a 'b)))
+        'a))
+(assert
+ (equal (third (serialize-and-deserialize-xml (circular-list 'a 'b)))
+        'a))
+
 ;; simple objects
 
 (defclass foobar ()