;;;; in Text, HTML, and XML formats. This includes hyperlinking\r
;;;; capability and sub-objects.\r
;;;;\r
-;;;; $Id: mop.lisp,v 1.74 2003/05/17 22:24:38 kevin Exp $\r
+;;;; $Id: mop.lisp,v 1.75 2003/05/26 21:43:05 kevin Exp $\r
;;;;\r
;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg\r
;;;; *************************************************************************\r
(setf (slot-value esd 'length) length)\r
(setf (slot-value esd 'type) (value-type-to-lisp-type value-type))\r
(setf (slot-value esd 'value-type) value-type)\r
+ (setf (slot-value esd 'user-name)\r
+ (aif (slot-value dsd 'user-name)\r
+ it\r
+ (string-downcase (symbol-name (slot-definition-name dsd)))))\r
(dolist (name '(print-formatter subobject hyperlink hyperlink-parameters\r
- description value-constraint index null-allowed user-name))\r
+ description value-constraint index null-allowed))\r
(setf (slot-value esd name) (slot-value dsd name)))\r
esd)))\r
\r
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: views.lisp,v 1.47 2003/05/22 21:03:52 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
;;;; *************************************************************************
(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)
(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
(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))))))