;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: views.lisp,v 1.45 2003/05/16 07:35:09 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
;;;; *************************************************************************
:accessor file-start-str)
(file-end-str :type (or string null) :initform nil :initarg :file-end-str
:accessor file-end-str)
- (list-start-str-or-func :type (or string function null) :initform nil
- :initarg :list-start-str-or-func
- :accessor list-start-str-or-func)
+ (list-start-printer :type (or string function null) :initform nil
+ :initarg :list-start-printer
+ :accessor list-start-printer)
(list-start-indent :initform nil :initarg :list-start-indent
:accessor list-start-indent)
- (list-end-str-or-func :type (or string function null) :initform nil
- :initarg :list-end-str-or-func
- :accessor list-end-str-or-func)
+ (list-end-printer :type (or string function null) :initform nil
+ :initarg :list-end-printer
+ :accessor list-end-printer)
(list-end-indent :initform nil :initarg :list-end-indent
:accessor list-end-indent)
- (obj-start-str-or-func :type (or string function null) :initform nil :initarg :obj-start-str-or-func
- :accessor obj-start-str-or-func)
+ (obj-start-printer :type (or string function null) :initform nil :initarg :obj-start-printer
+ :accessor obj-start-printer)
(obj-start-indent :initform nil :initarg :obj-start-indent
:accessor obj-start-indent)
- (obj-end-str-or-func :type (or string function null) :initform nil :initarg :obj-end-str-or-func
- :accessor obj-end-str-or-func)
+ (obj-end-printer :type (or string function null) :initform nil :initarg :obj-end-printer
+ :accessor obj-end-printer)
(obj-end-indent :initform nil :initarg :obj-end-indent
:accessor obj-end-indent)
(obj-data-indent :initform nil :initarg :obj-data-indent
:accessor obj-data-indent)
- (obj-data-func :type (or function null) :initform nil
- :initarg :obj-data-func
- :accessor obj-data-func)
+ (obj-data-printer :type (or function null) :initform nil
+ :initarg :obj-data-printer
+ :accessor obj-data-printer)
(obj-data-print-code :type (or function null) :initform nil
:initarg :obj-data-print-code
:accessor obj-data-print-code)
: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))))
(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))))))
(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-func 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)))
strm))
(defun initialize-text-view (view)
- (setf (list-start-str-or-func view)
+ (setf (list-start-printer view)
(compile nil
(eval '(lambda (obj nitems strm)
(write-user-name-maybe-plural obj nitems strm)
(setf (file-start-str view) (format nil "<html><body>~%"))
(setf (file-end-str view) (format nil "</body><html>~%"))
(setf (list-start-indent view) t)
- (setf (list-start-str-or-func view) #'html-list-start-func)
- (setf (list-end-str-or-func view) (format nil "</ul></div>~%"))
+ (setf (list-start-printer view) #'html-list-start-func)
+ (setf (list-end-printer view) (format nil "</ul></div>~%"))
(setf (list-end-indent view) t)
(setf (obj-start-indent view) t)
- (setf (obj-start-str-or-func view) "<li>")
+ (setf (obj-start-printer view) "<li>")
(setf (obj-end-indent view) t)
- (setf (obj-end-str-or-func view) (format nil "</li>~%"))
+ (setf (obj-end-printer view) (format nil "</li>~%"))
(setf (obj-data-indent view) nil))
(defun initialize-xhtml-view (view)
(setf (file-start-str view) (format nil "<html><body>~%"))
(setf (file-end-str view) (format nil "</body><html>~%"))
(setf (list-start-indent view) t)
- (setf (list-start-str-or-func view) #'html-list-start-func)
- (setf (list-end-str-or-func view) (format nil "</ul></div>~%"))
+ (setf (list-start-printer view) #'html-list-start-func)
+ (setf (list-end-printer view) (format nil "</ul></div>~%"))
(setf (list-end-indent view) t)
(setf (obj-start-indent view) t)
- (setf (obj-start-str-or-func view) "<li>")
+ (setf (obj-start-printer view) "<li>")
(setf (obj-end-indent view) t)
- (setf (obj-end-str-or-func view) (format nil "</li>~%"))
+ (setf (obj-end-printer view) (format nil "</li>~%"))
(setf (obj-data-indent view) nil))
(defun xmlformat-list-end-func (x strm)
(initialize-text-view view)
(setf (file-start-str view) "") ; (std-xml-header)
(setf (list-start-indent view) t)
- (setf (list-start-str-or-func view) #'xmlformat-list-start-func)
+ (setf (list-start-printer view) #'xmlformat-list-start-func)
(setf (list-end-indent view) t)
- (setf (list-end-str-or-func view) #'xmlformat-list-end-func)
- (setf (obj-start-str-or-func view) (format nil "<~(~a~)>" (object-class-name view)))
+ (setf (list-end-printer view) #'xmlformat-list-end-func)
+ (setf (obj-start-printer view) (format nil "<~(~a~)>" (object-class-name view)))
(setf (obj-start-indent view) t)
- (setf (obj-end-str-or-func view) (format nil "</~(~a~)>~%" (object-class-name view)))
+ (setf (obj-end-printer view) (format nil "</~(~a~)>~%" (object-class-name view)))
(setf (obj-end-indent view) nil)
(setf (obj-data-indent view) nil))
(defun fmt-list-start (obj view strm indent num-items)
(when (list-start-indent view)
(indent-spaces indent strm))
- (awhen (list-start-str-or-func view)
+ (awhen (list-start-printer view)
(if (stringp it)
(write-string it strm)
(funcall it obj num-items strm))))
(declare (ignore num-items))
(when (list-end-indent view)
(indent-spaces indent strm))
- (awhen (list-end-str-or-func view)
+ (awhen (list-end-printer view)
(if (stringp it)
(write-string it strm)
(funcall it obj strm))))
(defun fmt-obj-start (obj view strm indent)
(when (obj-start-indent view)
(indent-spaces indent strm))
- (awhen (obj-start-str-or-func view)
+ (awhen (obj-start-printer view)
(if (stringp it)
(write-string it strm)
(funcall it obj strm))))
(defun fmt-obj-end (obj view strm indent)
(when (obj-end-indent view)
(indent-spaces indent strm))
- (awhen (obj-end-str-or-func view)
+ (awhen (obj-end-printer view)
(if (stringp it)
(write-string it strm)
(funcall it obj strm))))
(write-string it strm)))
(defun fmt-obj-data-plain (obj view strm)
- (awhen (obj-data-func view)
+ (awhen (obj-data-printer view)
(funcall it obj strm nil)))
(defun fmt-obj-data-with-link (obj view strm refvars)
(append (link-parameters it) refvars))
refvalues)
(push (make-link-end obj view name) refvalues)))
- (funcall (obj-data-func view) obj strm (nreverse refvalues))))
+ (funcall (obj-data-printer view) obj strm (nreverse refvalues))))
(defun obj-data (obj view)
"Returns the objects data as a string. Used by common-graphics outline function"
projects / hyperobject.git / blobdiff