Fix xml printing

diff --git a/mop.lisp b/mop.lisp
index 47a2aaeb3d37a2da6b0a5983383a66bd6cdbfe36..96eb3256058c5bfb8870b274b4ab5d6e3aedc968 100644 (file)
--- a/mop.lisp
+++ b/mop.lisp
@@ -402,6 +402,13 @@ SQL name"
   (or (eq type 'string)
       (and (listp type) (some #'(lambda (x) (eq x 'string)) type))))
 
+(defun value-type-is-a-string (type)
+  (or (eq type 'string)
+      (eq type 'u::cdata)
+      (and (listp type) (some #'(lambda (x) (or (eq x 'string)
+                                                (eq x 'u::cdata)))
+                              type))))
+
 (defun base-value-type (value-type)
   (if (atom value-type)
       value-type

diff --git a/views.lisp b/views.lisp
index dde22fcc913fa4a371139a95b041d7b9c7a683ee..fcd132d647aab0108c1cf5e05b63150961ad57fb 100644 (file)
--- a/views.lisp
+++ b/views.lisp
@@ -284,62 +284,61 @@
          (user-name (esd-user-name slot))
          (xml-user-name (escape-xml-string user-name))
          (xml-tag (escape-xml-string user-name))
-         (type (slot-definition-type slot))
-
-         (cdata (not (null
-                      (and (in vid :xml :xhtml :xml-link :xhtml-link
-                               :xml-labels :ie-xml-labels
-                               :xhtml-link-labels :xml-link-labels :ie-xml-link
-                               :ie-xml-link-labels)
-                           (or formatter
-                               (lisp-type-is-a-string type))))))
+         (value-type (slot-value slot 'value-type))
+         (cdata (and (in vid :xml :xhtml :xml-link :xhtml-link
+                             :xml-labels :ie-xml-labels
+                             :xhtml-link-labels :xml-link-labels :ie-xml-link
+                             :ie-xml-link-labels)
+                     (or formatter
+                         (value-type-is-a-string value-type))
+                     t))
          (hyperlink (esd-hyperlink slot)))
 
     (case vid
       (:compact-text
        (vector-push-extend
-        `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func))
+        `(write-ho-value x ',name ',value-type ',formatter ,cdata s) print-func))
       (:compact-text-labels
        (vector-push-extend `(write-string ,user-name s) print-func)
        (vector-push-extend '(write-char #\space s) print-func)
        (vector-push-extend
-        `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func))
+        `(write-ho-value x ',name ',value-type ',formatter ,cdata s) print-func))
       ((or :html :xhtml)
-       (ppfc-html user-name name type formatter cdata print-func))
+       (ppfc-html user-name name value-type formatter cdata print-func))
       (:xml
-       (ppfc-xml xml-tag name type formatter cdata print-func))
+       (ppfc-xml xml-tag name value-type formatter cdata print-func))
       (:html-labels
-       (ppfc-html-labels user-name name type formatter cdata print-func))
+       (ppfc-html-labels user-name name value-type formatter cdata print-func))
       (:xhtml-labels
-       (ppfc-xhtml-labels xml-user-name user-name name type formatter cdata print-func))
+       (ppfc-xhtml-labels xml-user-name user-name name value-type formatter cdata print-func))
       ((:display-table :display-table-labels)
-       (ppfc-display-table user-name name type formatter cdata print-func))
+       (ppfc-display-table user-name name value-type formatter cdata print-func))
       (:xml-labels
-       (ppfc-xml-labels xml-user-name xml-tag name type formatter cdata print-func))
+       (ppfc-xml-labels xml-user-name xml-tag name value-type formatter cdata print-func))
       ((or :html-link :xhtml-link)
        (if hyperlink
-           (ppfc-html-link name type formatter cdata nlink print-func)
-           (ppfc-html user-name name type formatter cdata print-func)))
+           (ppfc-html-link name value-type formatter cdata nlink print-func)
+           (ppfc-html user-name name value-type formatter cdata print-func)))
       ((or :xml-link :ie-xml-link)
        (if hyperlink
-           (ppfc-html-link name type formatter cdata nlink print-func)
-           (ppfc-xml xml-tag name type formatter cdata print-func)))
+           (ppfc-html-link name value-type formatter cdata nlink print-func)
+           (ppfc-xml xml-tag name value-type formatter cdata print-func)))
       (:html-link-labels
        (if hyperlink
-           (ppfc-html-link-labels user-name name type formatter cdata nlink
+           (ppfc-html-link-labels user-name name value-type formatter cdata nlink
                                   print-func)
-           (ppfc-html-labels user-name name type formatter cdata print-func)))
+           (ppfc-html-labels user-name name value-type formatter cdata print-func)))
       (:xhtml-link-labels
        (if hyperlink
-           (ppfc-html-link-labels xml-user-name name type formatter cdata nlink
+           (ppfc-html-link-labels xml-user-name name value-type formatter cdata nlink
                                   print-func)
-           (ppfc-xhtml-labels xml-tag user-name name type formatter cdata
+           (ppfc-xhtml-labels xml-tag user-name name value-type formatter cdata
                               print-func)))
       ((or :xml-link-labels :ie-xml-link-labels)
        (if hyperlink
-           (ppfc-html-link-labels xml-user-name name type formatter cdata nlink
+           (ppfc-html-link-labels xml-user-name name value-type formatter cdata nlink
                                   print-func)
-           (ppfc-xml-labels xml-tag user-name name type formatter cdata
+           (ppfc-xml-labels xml-tag user-name name value-type formatter cdata
                             print-func))))))
 
 
@@ -594,7 +593,8 @@
     (setf (obj-start-printer view) (format nil "<~(~a~)>" name))
     (setf (obj-start-indent view) t)
     (setf (obj-end-printer view) (format nil "</~(~a~)>~%" name))
-    (setf (subobj-end-printer view) (format nil "</~(~a~)>~%" name))
+;;    (setf (subobj-end-printer view) (format nil "</~(~a~)>~%" name))
+    (setf (subobj-end-printer view) nil)
     (setf (subobj-end-indent view) nil)
     (setf (obj-data-indent view) nil)))