Source

cl-prevalence / src / serialization / xml.lisp

Full commit

(in-package :s-serialization)

(defun serialize-xml (object stream &optional (serialization-state (make-serialization-state)))
  "Write a serialized version of object to stream using XML, optionally reusing a serialization-state"
  (reset serialization-state)
  (serialize-xml-internal object stream serialization-state))

(defun deserialize-xml (stream &optional (serialization-state (make-serialization-state)))
  "Read and return an XML serialized version of a lisp object from stream, optionally reusing a serialization state"
  (reset serialization-state)
  (let ((*deserialized-objects* (get-hashtable serialization-state)))
    (declare (special *deserialized-objects*))
    (car (s-xml:start-parse-xml stream (get-xml-parser-state serialization-state)))))

(defgeneric serialize-xml-internal (object stream serialization-state)
  (:documentation "Write a serialized version of object to stream using XML"))

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


;;;; SERIALIZATION

;;; basic serializers
(defmethod serialize-xml-internal ((object integer) stream serialization-state)
  (declare (ignore serialization-state))
  (write-string "<INT>" stream)
  (prin1 object stream)
  (write-string "</INT>" stream))

(defmethod serialize-xml-internal ((object ratio) stream serialization-state)
  (declare (ignore serialization-state))
  (write-string "<RATIO>" stream)
  (prin1 object stream)
  (write-string "</RATIO>" stream))

(defmethod serialize-xml-internal ((object float) stream serialization-state)
  (declare (ignore serialization-state))
  (write-string "<FLOAT>" stream)
  (prin1 object stream)
  (write-string "</FLOAT>" stream))

(defmethod serialize-xml-internal ((object complex) stream serialization-state)
  (declare (ignore serialization-state))
  (write-string "<COMPLEX>" stream)
  (prin1 object stream)
  (write-string "</COMPLEX>" stream))

(defmethod serialize-sexp-internal ((object number) stream serialize-sexp-internal)
  (declare (ignore serialize-sexp-internal))
  (prin1 object stream))

(defmethod serialize-xml-internal ((object null) stream serialization-state)
  (declare (ignore serialization-state))
  (write-string "<NULL/>" stream))

(defmethod serialize-xml-internal ((object (eql 't)) stream serialization-state)
  (declare (ignore serialization-state))
  (write-string "<TRUE/>" stream))

(defmethod serialize-xml-internal ((object string) stream serialization-state)
  (declare (ignore serialization-state))
  (write-string "<STRING>" stream)
  (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)
  (print-symbol-xml object stream)
  (write-string "</SYMBOL>" stream))

;;; generic sequences
(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))))
    (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))))))))

;;; hash tables
(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)))))

;;; structures
(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)))))

;;; objects
(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)))))


;;;; DESERIALIZATION

(defun get-attribute-value (name attributes)
  (cdr (assoc name attributes :test #'eq)))

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

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

(defun deserialize-xml-text (string seed)
  (declare (ignore seed))
  string)