From mathrick at gmail.com  Thu Feb 21 11:43:38 2008
From: mathrick at gmail.com (Maciej Katafiasz)
Date: Thu, 21 Feb 2008 12:43:38 +0100
Subject: [cl-prevalence-devel] [PATCH] Use WITH-STANDARD-IO-SYNTAX
In-Reply-To: <50b7e5180802210337r68ded699he483ef1a53700095@mail.gmail.com>
References: <50b7e5180802210337r68ded699he483ef1a53700095@mail.gmail.com>
Message-ID: <50b7e5180802210343h6170e4a0h20348555be11e5c2@mail.gmail.com>

Hi,

 the patch below adds WITH-STANDARD-IO-SYNTAX to all places where
 reading and writing is done, which fixes the breakage when XML is
 (de)serialised across images with different READTABLE-CASE. I did a
 quick test on data that used to break before, and it seems to work
 fine.

 Cheers,
 Maciej

 ? doc
 Index: src/serialization.lisp
 ===================================================================
 RCS file: /project/cl-prevalence/cvsroot/cl-prevalence/src/serialization.lisp,v
 retrieving revision 1.11
 diff -u -u -r1.11 serialization.lisp
 --- src/serialization.lisp      16 Mar 2007 15:37:18 -0000      1.11
 +++ src/serialization.lisp      21 Feb 2008 11:31:19 -0000
 @@ -101,26 +101,28 @@
  (defconstant +keyword-package+ (find-package :keyword))

  (defun print-symbol-xml (symbol stream)
 -  (let ((package (symbol-package symbol))
 -       (name (prin1-to-string symbol)))
 -    (cond ((eq package +cl-package+) (write-string "CL:" stream))
 -         ((eq package +keyword-package+) (write-char #\: stream))
 -         (t (s-xml:print-string-xml (package-name package) stream)
 -            (write-string "::" stream)))
 -    (if (char= (char name (1- (length name))) #\|)
 -        (s-xml:print-string-xml name stream :start (position #\| name))
 -      (s-xml:print-string-xml name stream :start (1+ (or (position
 #\: name :from-end t) -1))))))
 +  (with-standard-io-syntax
 +    (let ((package (symbol-package symbol))
 +          (name (prin1-to-string symbol)))
 +      (cond ((eq package +cl-package+) (write-string "CL:" stream))
 +            ((eq package +keyword-package+) (write-char #\: stream))
 +            (t (s-xml:print-string-xml (package-name package) stream)
 +               (write-string "::" stream)))
 +      (if (char= (char name (1- (length name))) #\|)
 +          (s-xml:print-string-xml name stream :start (position #\| name))
 +          (s-xml:print-string-xml name stream :start (1+ (or
 (position #\: name :from-end t) -1)))))))

  (defun print-symbol (symbol stream)
 -  (let ((package (symbol-package symbol))
 -       (name (prin1-to-string symbol)))
 -    (cond ((eq package +cl-package+) (write-string "CL:" stream))
 -         ((eq package +keyword-package+) (write-char #\: stream))
 -         (t (s-xml:print-string-xml (package-name package) stream)
 -            (write-string "::" stream)))
 -    (if (char= (char name (1- (length name))) #\|)
 -        (write-string name stream :start (position #\| name))
 -      (write-string name stream :start (1+ (or (position #\: name
 :from-end t) -1))))))
 +  (with-standard-io-syntax
 +    (let ((package (symbol-package symbol))
 +          (name (prin1-to-string symbol)))
 +      (cond ((eq package +cl-package+) (write-string "CL:" stream))
 +            ((eq package +keyword-package+) (write-char #\: stream))
 +            (t (s-xml:print-string-xml (package-name package) stream)
 +               (write-string "::" stream)))
 +      (if (char= (char name (1- (length name))) #\|)
 +          (write-string name stream :start (position #\| name))
 +          (write-string name stream :start (1+ (or (position #\: name
 :from-end t) -1)))))))

  (defmethod serializable-slots ((object structure-object))
   #+openmcl
 @@ -234,15 +236,18 @@

  (defmethod serialize-sexp-internal ((object string) stream
serialization-state)
   (declare (ignore serialization-state))
 -  (prin1 object stream))
 +  (with-standard-io-syntax
 +    (prin1 object stream)))

  (defmethod serialize-sexp-internal ((object character) stream
 serialization-state)
   (declare (ignore serialization-state))
 -  (prin1 object stream))
 +  (with-standard-io-syntax
 +    (prin1 object stream)))

  (defmethod serialize-sexp-internal ((object symbol) stream
serialization-state)
   (declare (ignore serialization-state))
 -  (print-symbol object stream))
 +  (with-standard-io-syntax
 +    (print-symbol object stream)))

  (defun sequence-type-and-length(sequence)
   (if (listp sequence)
 @@ -256,226 +261,234 @@
       (values :proper-sequence (length sequence))))

  (defmethod serialize-xml-internal ((object sequence) stream
 serialization-state)
 -  (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))))
 +  (with-standard-io-syntax
 +    (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)
 +  (with-standard-io-syntax
 +    (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)
 +  (with-standard-io-syntax
     (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))))))))
 +            (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))))))

 -(defmethod serialize-sexp-internal ((object sequence) stream
 serialization-state)
 -  (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))))
 +(defmethod serialize-sexp-internal ((object hash-table) stream
 serialization-state)
 +  (with-standard-io-syntax
     (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)))
 -    (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 "<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)))
 -    (if id
 -       (progn
 -         (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))
 -          (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))
 +            (write-string " )" stream))))))

  (defmethod serialize-xml-internal ((object structure-object) 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 "<STRUCT ID=\"" stream)
 -       (prin1 id stream)
 -       (write-string "\" CLASS=\"" stream)
 -       (print-symbol-xml (class-name (class-of object)) stream)
 -       (write-string "\">" 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))
 -       (write-string "</STRUCT>" stream)))))
 +  (with-standard-io-syntax
 +    (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 "<STRUCT ID=\"" stream)
 +            (prin1 id stream)
 +            (write-string "\" CLASS=\"" stream)
 +            (print-symbol-xml (class-name (class-of object)) stream)
 +            (write-string "\">" 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))
 +            (write-string "</STRUCT>" stream))))))

  (defmethod serialize-sexp-internal ((object structure-object) 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 ((serializable-slots (get-serializable-slots
 serialization-state object)))
 -       (setf id (set-known-object serialization-state object))
 -       (write-string "(:STRUCT " stream)
 -       (prin1 id stream)
 -       (write-string " :CLASS " stream)
 -       (print-symbol (class-name (class-of object)) stream)
 -        (when serializable-slots
 -          (write-string " :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))
 -       (write-string " ) )" stream)))))
 +  (with-standard-io-syntax
 +    (let ((id (known-object-id serialization-state object)))
 +      (if id
 +          (progn
 +            (write-string "(:REF . " stream)
 +            (prin1 id stream)
 +            (write-string ")" stream))
 +          (let ((serializable-slots (get-serializable-slots
 serialization-state object)))
 +            (setf id (set-known-object serialization-state object))
 +            (write-string "(:STRUCT " stream)
 +            (prin1 id stream)
 +            (write-string " :CLASS " stream)
 +            (print-symbol (class-name (class-of object)) stream)
 +            (when serializable-slots
 +              (write-string " :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))
 +            (write-string " ) )" stream))))))

  (defmethod serialize-xml-internal ((object standard-object) 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 "<OBJECT ID=\"" stream)
 -       (prin1 id stream)
 -       (write-string "\" CLASS=\"" stream)
 -       (print-symbol-xml (class-name (class-of object)) stream)
 -       (princ "\">" stream)
 -       (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)))))
 +  (with-standard-io-syntax
 +    (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 "<OBJECT ID=\"" stream)
 +            (prin1 id stream)
 +            (write-string "\" CLASS=\"" stream)
 +            (print-symbol-xml (class-name (class-of object)) stream)
 +            (princ "\">" stream)
 +            (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)
 -  (let ((id (known-object-id serialization-state object)))
 -    (if id
 -       (progn
 -         (write-string "(:REF . " stream)
 -         (prin1 id stream)
 -         (write-string ")" stream))
 -      (let ((serializable-slots (get-serializable-slots
 serialization-state object)))
 -       (setf id (set-known-object serialization-state object))
 -       (write-string "(:OBJECT " stream)
 -       (prin1 id stream)
 -       (write-string " :CLASS " stream)
 -       (print-symbol (class-name (class-of object)) stream)
 -        (when serializable-slots
 -          (princ " :SLOTS (" stream)
 -          (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)))))
 +  (with-standard-io-syntax
 +    (let ((id (known-object-id serialization-state object)))
 +      (if id
 +          (progn
 +            (write-string "(:REF . " stream)
 +            (prin1 id stream)
 +            (write-string ")" stream))
 +          (let ((serializable-slots (get-serializable-slots
 serialization-state object)))
 +            (setf id (set-known-object serialization-state object))
 +            (write-string "(:OBJECT " stream)
 +            (prin1 id stream)
 +            (write-string " :CLASS " stream)
 +            (print-symbol (class-name (class-of object)) stream)
 +            (when serializable-slots
 +              (princ " :SLOTS (" stream)
 +              (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

 @@ -484,68 +497,70 @@

  (defun deserialize-xml-new-element (name attributes seed)
   (declare (ignore seed) (special *deserialized-objects*))
 -  (case name
 -    (:sequence (let ((id (parse-integer (get-attribute-value :id attributes)))
 -                    (class (read-from-string (get-attribute-value
:class attributes)))
 -                    (size (parse-integer (get-attribute-value :size
attributes))))
 -                (setf (gethash id *deserialized-objects*)
 -                      (make-sequence class size))))
 -    (:object (let ((id (parse-integer (get-attribute-value :id attributes)))
 -                  (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*)
 -                    (funcall (intern (concatenate 'string "MAKE-" (symbol-name
 class)) (symbol-package class))))))
 -    (:hash-table (let ((id (parse-integer (get-attribute-value :id
 attributes)))
 -                      (test (read-from-string (get-attribute-value
:test attributes)))
 -                      (size (parse-integer (get-attribute-value
:size attributes))))
 -                  (setf (gethash id *deserialized-objects*)
 -                        (make-hash-table :test test :size size)))))
 +  (with-standard-io-syntax
 +    (case name
 +      (:sequence (let ((id (parse-integer (get-attribute-value :id
 attributes)))
 +                       (class (read-from-string (get-attribute-value
 :class attributes)))
 +                       (size (parse-integer (get-attribute-value
 :size attributes))))
 +                   (setf (gethash id *deserialized-objects*)
 +                         (make-sequence class size))))
 +      (:object (let ((id (parse-integer (get-attribute-value :id attributes)))
 +                     (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*)
 +                       (funcall (intern (concatenate 'string "MAKE-"
 (symbol-name class)) (symbol-package class))))))
 +      (:hash-table (let ((id (parse-integer (get-attribute-value :id
 attributes)))
 +                         (test (read-from-string (get-attribute-value
 :test attributes)))
 +                         (size (parse-integer (get-attribute-value
 :size attributes))))
 +                     (setf (gethash id *deserialized-objects*)
 +                           (make-hash-table :test test :size size))))))
   '())

  (defun deserialize-xml-finish-element (name attributes parent-seed seed)
   (declare (special *deserialized-objects*))
 -  (cons (case name
 -         (:int (parse-integer seed))
 -         ((:float :ratio :complex :symbol) (read-from-string seed))
 -         (:null nil)
 -         (:true t)
 -         (:string (or seed ""))
 -          (:character (char seed 0))
 -         (:key (car seed))
 -         (:value (car seed))
 -         (:entry (nreverse seed))
 -         (:slot (let ((name (read-from-string (get-attribute-value :name
 attributes))))
 -                  (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))))
 -          (: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)
 -                       (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))
 +  (with-standard-io-syntax
 +    (cons (case name
 +            (:int (parse-integer seed))
 +            ((:float :ratio :complex :symbol) (read-from-string seed))
 +            (:null nil)
 +            (:true t)
 +            (:string (or seed ""))
 +            (:character (char seed 0))
 +            (:key (car seed))
 +            (:value (car seed))
 +            (:entry (nreverse seed))
 +            (:slot (let ((name (read-from-string (get-attribute-value
 :name attributes))))
 +                     (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))))
 +            (: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)
 +                         (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)))

  (defun deserialize-xml-text (string seed)
   (declare (ignore seed))
-------------- next part --------------
A non-text attachment was scrubbed...
Name: cl-prevalence-standard-io.diff
Type: text/x-patch
Size: 31919 bytes
Desc: not available
URL: <https://mailman.common-lisp.net/pipermail/cl-prevalence-devel/attachments/20080221/c18616dd/attachment.bin>

From scaekenberghe at common-lisp.net  Thu Feb 21 12:55:36 2008
From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe)
Date: Thu, 21 Feb 2008 13:55:36 +0100
Subject: [cl-prevalence-devel] [PATCH] Use WITH-STANDARD-IO-SYNTAX
In-Reply-To: <50b7e5180802210343h6170e4a0h20348555be11e5c2@mail.gmail.com>
References: <50b7e5180802210337r68ded699he483ef1a53700095@mail.gmail.com>
	<50b7e5180802210343h6170e4a0h20348555be11e5c2@mail.gmail.com>
Message-ID: <DF19C91B-6581-4D67-B24D-D1062A01DDF0@common-lisp.net>

Maciej,

On 21 Feb 2008, at 12:43, Maciej Katafiasz wrote:

> Hi,
>
> the patch below adds WITH-STANDARD-IO-SYNTAX to all places where
> reading and writing is done, which fixes the breakage when XML is
> (de)serialised across images with different READTABLE-CASE. I did a
> quick test on data that used to break before, and it seems to work
> fine.
>
> Cheers,
> Maciej

Thanks for submitting this patch; I already applied it to my local  
source tree and had a look at it. As far as I can see, it looks OK.  
However, I have a feeling that maybe there are too many places where  
WITH-STANDARD-IO-SYNTAX is added. Could you maybe supply an example or  
even a test case for the breakage that you encountered - maybe using  
serialization to and from fixed strings ? That way I would feel more  
sure about committing your changes. Maybe the S-XML parser also needs  
this ?

Regards,

Sven