Changeset 2530

Show
Ignore:
Timestamp:
02/18/08 11:36:28 (9 months ago)
Author:
hhubner
Message:

refactor, remove warnings

Files:

Legend:

Unmodified
Added
Removed
Modified
Copied
Moved

  • branches/trunk-reorg/bknr/datastore/src/xml-impex/xml-export.lisp

    r2417 r2530  
    1313  `(let ((*objects-written* (make-hash-table :test #'equal)) 
    1414         (cxml::*current-element* nil) 
    15          (cxml::*sink* #+(or) (cxml:make-character-stream-sink ,output 
    16                                                               :indentation ,indentation :canonical ,canonical))) 
     15         (cxml::*sink* (cxml:make-character-stream-sink ,output 
     16                                                        :indentation ,indentation :canonical ,canonical))) 
    1717     ,@body)) 
    1818 
    …… 
    2020  `(with-xml-export* (:output *standard-output* :indentation 1 :canonical nil) 
    2121     ,@body)) 
    22  
    23 (defgeneric write-to-xml (object &key name no-recurse) 
    24   (:documentation "Write object to XML stream")) 
    25  
    26 (defmethod write-to-xml ((object (eql nil)) &key name no-recurse) 
    27   (declare (ignore name))) 
    28  
    29 (defmethod write-to-xml ((object list) &key (name (error "Can not serialize list to XML without an element name~%")) no-recurse) 
    30   (sax:start-element cxml::*sink* nil nil (cxml::string-rod name) nil) 
    31   (dolist (obj object) 
    32     (write-to-xml obj)) 
    33   (sax:end-element cxml::*sink* nil nil (cxml::string-rod name))) 
    34  
    35 (defmethod write-to-xml ((object string) &key (name (error "Can not serialize string ~A to XML without an element name." object)) no-recurse) 
    36   (sax:start-element cxml::*sink* nil nil (cxml::string-rod name) nil) 
    37   (sax:characters cxml::*sink* (cxml::string-rod object)) 
    38   (sax:end-element cxml::*sink* nil nil (cxml::string-rod name))) 
    39  
    40 (defmethod write-to-xml ((object standard-object) &key &allow-other-keys) 
    41   (cxml:with-element (string-downcase (class-name (class-of object))) 
    42     (dolist (slot (class-slots (class-of object))) 
    43       (cxml:with-element (string-downcase (symbol-name (slot-definition-name slot))) 
    44         (let ((value (slot-value object (slot-definition-name slot)))) 
    45           (when value 
    46             (cxml:text (handler-case 
    47                            (cxml::utf8-string-to-rod (princ-to-string value)) 
    48                          (error (e) 
    49                            (declare (ignore e)) 
    50                            (cxml::utf8-string-to-rod "[unprintable]")))))))))) 
    5122 
    5223(defun write-object-reference (class object unique-id-slot-name name) 
    …… 
    5930    (sax:end-element cxml::*sink* nil nil name))) 
    6031 
    61 (defmethod write-to-xml ((object xml-class) &key name no-recurse) 
    62   (xml-object-check-validity object) 
    63   (let* ((class (class-of object)) 
    64          (qname (cxml::string-rod (or name (xml-class-element class))))) 
     32(defgeneric write-to-xml (object &key) 
     33  (:documentation "Write OBJECT to XML stream") 
    6534 
    66     ;; If this object has been serialized to the XML stream, 
    67     ;; write a reference to the object and return. 
     35  (:method ((object (eql nil)) &key)) 
    6836 
    69     (with-slots (unique-id-slot) class 
    70       (when unique-id-slot 
    71         (if (gethash (slot-value object (first unique-id-slot)) *objects-written*) 
    72             (progn 
    73               (write-object-reference class object (first unique-id-slot) qname) 
    74               (return-from write-to-xml)) 
    75             (setf (gethash (slot-value object (first unique-id-slot)) *objects-written*) t)))) 
     37  (:method ((object list) &key (name (error "Can not serialize list to XML without an element name~%"))) 
     38    (sax:start-element cxml::*sink* nil nil (cxml::string-rod name) nil) 
     39    (dolist (obj object) 
     40      (write-to-xml obj)) 
     41    (sax:end-element cxml::*sink* nil nil (cxml::string-rod name))) 
    7642 
    77     ;; Object has not been written to the XML file or no 
    78     ;; unique-id-slot is defined for this class. 
     43  (:method ((object string) &key (name (error "Can not serialize string ~A to XML without an element name." object))) 
     44    (sax:start-element cxml::*sink* nil nil (cxml::string-rod name) nil) 
     45    (sax:characters cxml::*sink* (cxml::string-rod object)) 
     46    (sax:end-element cxml::*sink* nil nil (cxml::string-rod name))) 
    7947 
    80     (let* ((attr-slots (xml-class-attribute-slots class)) 
    81            (elt-slots (xml-class-element-slots class)) 
    82            (body-slot (xml-class-body-slot class)) 
    83            ;; attributes 
    84            (attributes (loop for slot in attr-slots 
    85                           for name = (slot-definition-name slot) 
    86                           for attdef = (cxml::string-rod (xml-effective-slot-definition-attribute slot)) 
    87                           when (and (slot-boundp object name) 
    88                                     (slot-value object name)) 
    89                           collect (sax:make-attribute 
    90                                    :qname attdef 
    91                                    :value 
    92                                    (cxml::string-rod 
    93                                     (slot-serialize-value slot (slot-value object name))))))) 
    94       (sax:start-element cxml::*sink* nil nil qname attributes) 
     48  (:method ((object standard-object) &key) 
     49    (cxml:with-element (string-downcase (class-name (class-of object))) 
     50      (dolist (slot (class-slots (class-of object))) 
     51        (cxml:with-element (string-downcase (symbol-name (slot-definition-name slot))) 
     52          (let ((value (slot-value object (slot-definition-name slot)))) 
     53            (when value 
     54              (cxml:text (handler-case 
     55                             (cxml::utf8-string-to-rod (princ-to-string value)) 
     56                           (error (e) 
     57                             (declare (ignore e)) 
     58                             (cxml::utf8-string-to-rod "[unprintable]")))))))))) 
    9559 
    96       ;; elements 
    97       (dolist (slot elt-slots) 
    98         (let ((name (slot-definition-name slot)) 
    99               (element-name (xml-effective-slot-definition-element slot))                     
    100               (containment (xml-effective-slot-definition-containment slot))) 
    101           (when (slot-boundp object name) 
    102             (if (consp (slot-value object name)) 
    103                 (dolist (child (slot-value object name)) 
    104                   (if (typep (class-of child) 'xml-class) 
    105                       (write-to-xml child) 
    106                       (write-to-xml (slot-serialize-value slot child) :name element-name))) 
    107                 (let ((child (slot-value object name))) 
    108                   (if (typep (class-of child) 'xml-class) 
    109                       (write-to-xml child) 
    110                       (write-to-xml (slot-serialize-value slot child) :name element-name))))))) 
     60  (:method ((object xml-class) &key name) 
     61    (xml-object-check-validity object) 
     62    (let* ((class (class-of object)) 
     63           (qname (cxml::string-rod (or name (xml-class-element class))))) 
     64       
     65      ;; If this object has been serialized to the XML stream, 
     66      ;; write a reference to the object and return. 
    11167 
    112       ;; body slot 
    113       (when body-slot 
    114         (let ((name (slot-definition-name body-slot))) 
    115           (when (slot-boundp object name) 
    116             (sax:characters 
    117              cxml::*sink* 
    118              (cxml::string-rod 
    119               (funcall (xml-effective-slot-definition-serializer body-slot) 
    120                        (slot-value object name))))))) 
     68      (with-slots (unique-id-slot) class 
     69        (when unique-id-slot 
     70          (if (gethash (slot-value object (first unique-id-slot)) *objects-written*) 
     71              (progn 
     72                (write-object-reference class object (first unique-id-slot) qname) 
     73                (return-from write-to-xml)) 
     74              (setf (gethash (slot-value object (first unique-id-slot)) *objects-written*) t)))) 
     75 
     76      ;; Object has not been written to the XML file or no 
     77      ;; unique-id-slot is defined for this class. 
     78 
     79      (let* ((attr-slots (xml-class-attribute-slots class)) 
     80             (elt-slots (xml-class-element-slots class)) 
     81             (body-slot (xml-class-body-slot class)) 
     82             ;; attributes 
     83             (attributes (loop for slot in attr-slots 
     84                               for name = (slot-definition-name slot) 
     85                               for attdef = (cxml::string-rod (xml-effective-slot-definition-attribute slot)) 
     86                               when (and (slot-boundp object name) 
     87                                         (slot-value object name)) 
     88                               collect (sax:make-attribute 
     89                                        :qname attdef 
     90                                        :value 
     91                                        (cxml::string-rod 
     92                                         (slot-serialize-value slot (slot-value object name))))))) 
     93        (sax:start-element cxml::*sink* nil nil qname attributes) 
     94 
     95        ;; elements 
     96        (dolist (slot elt-slots) 
     97          (let ((name (slot-definition-name slot)) 
     98                (element-name (xml-effective-slot-definition-element slot))) 
     99            (when (slot-boundp object name) 
     100              (if (consp (slot-value object name)) 
     101                  (dolist (child (slot-value object name)) 
     102                    (if (typep (class-of child) 'xml-class) 
     103                        (write-to-xml child) 
     104                        (write-to-xml (slot-serialize-value slot child) :name element-name))) 
     105                  (let ((child (slot-value object name))) 
     106                    (if (typep (class-of child) 'xml-class) 
     107                        (write-to-xml child) 
     108                        (write-to-xml (slot-serialize-value slot child) :name element-name))))))) 
     109 
     110        ;; body slot 
     111        (when body-slot 
     112          (let ((name (slot-definition-name body-slot))) 
     113            (when (slot-boundp object name) 
     114              (sax:characters 
     115               cxml::*sink* 
     116               (cxml::string-rod 
     117                (funcall (xml-effective-slot-definition-serializer body-slot) 
     118                         (slot-value object name))))))) 
    121119         
    122       (sax:end-element cxml::*sink* nil nil qname)))) 
     120        (sax:end-element cxml::*sink* nil nil qname)))))