r5036: *** empty log message ***

[hyperobject.git] / views.lisp

diff --git a/views.lisp b/views.lisp
index 70819fd276faa89a894cb03156d4e386fd4db58a..0aeafe1bda4b2401a7d617dcea6c321a66bb246d 100644 (file)
--- a/views.lisp
+++ b/views.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: views.lisp,v 1.46 2003/05/22 20:40:03 kevin Exp $
+;;;; $Id: views.lisp,v 1.48 2003/05/26 21:43:05 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
@@ -134,7 +134,7 @@
                                 :category :compact-text)))
        view))
     ((consp view-def)
-     (eval `(make-instance ,view-def)))
+     (apply #'make-instance 'object-view view-def))
     (t
      (error "Invalid parameter to make-object-view: ~S" view-def))))
 
@@ -177,12 +177,10 @@
   (let* ((slot-data (slot-value obj name))
         (fmt-data (if formatter
                       (funcall formatter slot-data)
-                  slot-data))
-        (data (if cdata
-                  (kmrcl:xml-cdata fmt-data)
-                  fmt-data)))
-    (write-simple data strm)))
-
+                      slot-data)))
+    (if cdata
+       (write-xml-cdata fmt-data strm)
+       (write-simple fmt-data strm))))
 
 (defun ppfc-html (title name type formatter cdata print-func)
   (vector-push-extend '(write-string "<span class=\"" s) print-func)
@@ -237,9 +235,9 @@
 (defun push-print-fun-code (category slot nlink print-func)
   (let* ((formatter (esd-print-formatter slot))
         (name (slot-definition-name slot))
-        (namestr-lower (string-downcase (symbol-name name)))
-        (xml-namestr (escape-xml-string namestr-lower))
-        (xml-tag (escape-xml-string namestr-lower))
+        (user-name (esd-user-name slot))
+        (xml-user-name (escape-xml-string user-name))
+        (xml-tag (escape-xml-string user-name))
         (type (slot-value slot 'type))
         (cdata (not (null
                      (and (in category :xml :xhtml :xml-link :xhtml-link
@@ -255,44 +253,44 @@
        (vector-push-extend
        `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func))
       (:compact-text-labels
-       (vector-push-extend `(write-string ,namestr-lower s) print-func)
+       (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))
       ((or :html :xhtml)
-       (ppfc-html namestr-lower name type formatter cdata print-func))
+       (ppfc-html user-name name type formatter cdata print-func))
       (:xml
        (ppfc-xml xml-tag name type formatter cdata print-func))
       (:html-labels
-       (ppfc-html-labels namestr-lower name type formatter cdata print-func))
+       (ppfc-html-labels user-name name type formatter cdata print-func))
       (:xhtml-labels
-       (ppfc-xhtml-labels xml-namestr namestr-lower name type formatter cdata print-func))
+       (ppfc-xhtml-labels xml-user-name user-name name type formatter cdata print-func))
       (:xml-labels
-       (ppfc-xml-labels xml-namestr xml-tag name type formatter cdata print-func))
+       (ppfc-xml-labels xml-user-name xml-tag name type formatter cdata print-func))
       ((or :html-link :xhtml-link)
        (if hyperlink
           (ppfc-html-link name type formatter cdata nlink print-func)
-          (ppfc-html namestr-lower name type formatter cdata print-func)))
+          (ppfc-html user-name name 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)))
       (:html-link-labels
        (if hyperlink
-          (ppfc-html-link-labels namestr-lower name type formatter cdata nlink
+          (ppfc-html-link-labels user-name name type formatter cdata nlink
                                  print-func)
-          (ppfc-html-labels namestr-lower name type formatter cdata print-func)))
+          (ppfc-html-labels user-name name type formatter cdata print-func)))
       (:xhtml-link-labels
        (if hyperlink
-          (ppfc-html-link-labels xml-namestr name type formatter cdata nlink
+          (ppfc-html-link-labels xml-user-name name type formatter cdata nlink
                                  print-func)
-          (ppfc-xhtml-labels xml-tag namestr-lower name type formatter cdata
+          (ppfc-xhtml-labels xml-tag user-name name type formatter cdata
                              print-func)))
       ((or :xml-link-labels :ie-xml-link-labels)
        (if hyperlink
-          (ppfc-html-link-labels xml-namestr name type formatter cdata nlink
+          (ppfc-html-link-labels xml-user-name name type formatter cdata nlink
                                  print-func)
-          (ppfc-xml-labels xml-tag namestr-lower name type formatter cdata
+          (ppfc-xml-labels xml-tag user-name name type formatter cdata
                            print-func))))))
 
 
@@ -331,12 +329,12 @@
       (when (and (view-has-links-p view) (esd-hyperlink slot))
        (push (slot-definition-name slot) links)))
 
-    (when (plusp (length print-func))
-      (setf (obj-data-print-code view) `(lambda (x s links)
-                                        (declare (ignorable links))
-                                        ,@(map 'list #'identity print-func)))
-      (setf (obj-data-printer view)
-           (compile nil (eval (obj-data-print-code view)))))
+    (vector-push-extend 'x print-func) ;; return object
+    (setf (obj-data-print-code view) `(lambda (x s links)
+                                      (declare (ignorable links))
+                                      ,@(map 'list #'identity print-func)))
+    (setf (obj-data-printer view)
+         (compile nil (eval (obj-data-print-code view))))
     
     (setf (link-slots view) (nreverse links)))