X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=views.lisp;h=dfd6aaa6332190f72d336c683c7330bb50a2a92d;hb=4e78f4f0086c35ac3fd4459e3fff1186d13bc07f;hp=2c2713e54079a34f850fac50dd68040ba18382ed;hpb=2272c8f3fad706bece472bc5a1909e3ea0cc53e3;p=hyperobject.git diff --git a/views.lisp b/views.lisp index 2c2713e..dfd6aaa 100644 --- a/views.lisp +++ b/views.lisp @@ -7,10 +7,9 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: views.lisp,v 1.35 2003/05/14 04:45:05 kevin Exp $ -;;;; -;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg +;;;; $Id: views.lisp,v 1.49 2003/05/30 18:46:35 kevin Exp $ ;;;; +;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg ;;;; ************************************************************************* (in-package :hyperobject) @@ -41,29 +40,29 @@ :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) @@ -135,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)))) @@ -161,23 +160,27 @@ ) ) +(defmacro write-simple (v s) + `(typecase ,v + (string + (write-string ,v ,s)) + #+allegro + (fixnum + (excl::print-fixnum ,s 10 ,v)) + (symbol + (write-string (symbol-name ,v) ,s)) + (t + (write-string (write-to-string ,v) ,s)))) (defun write-ho-value (obj name type formatter cdata strm) (declare (ignorable type)) (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))) - (typecase data - (string - (write-string data strm)) - (number - (write-string (write-to-string data) strm)) - (t - (format strm "~A" data))))) + 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 "" value-fmt ""))) - (:xml - (string-append fmtstr (concatenate 'string "<" namestr-lower ">" value-fmt "" namestr-lower ">"))) - (:html-labels - (string-append fmtstr (concatenate 'string "" namestr-lower " " value-fmt ""))) - (:xhtml-labels - (string-append fmtstr (concatenate 'string "" xml-namestr " " value-fmt ""))) - (:xml-labels - (string-append fmtstr (concatenate 'string " <" xml-tag ">" value-fmt "" xml-tag ">"))) - ((or :html-link :xhtml-link) - (push name links) - (if (esd-hyperlink slot) - (string-append fmtstr "<~~a>" value-fmt "~~a>") - (string-append fmtstr (concatenate 'string "" value-fmt "")))) - ((or :xml-link :ie-xml-link) - (push name links) - (if (esd-hyperlink slot) - (string-append fmtstr "<~~a>" value-fmt "~~a>") - (string-append fmtstr (concatenate 'string "<" xml-tag ">" value-fmt "" xml-tag ">")))) - (:html-link-labels - (push name links) - (if (esd-hyperlink slot) - (string-append fmtstr "" namestr-lower " <~~a>" value-fmt "~~a>") - (string-append fmtstr (concatenate 'string "" namestr-lower " " value-fmt "")))) - (:xhtml-link-labels - (push name links) - (if (esd-hyperlink slot) - (string-append fmtstr "" xml-namestr " <~~a>" value-fmt "~~a>") - (string-append fmtstr (concatenate 'string "" xml-namestr " " value-fmt "")))) - ((or :xml-link-labels :ie-xml-link-labels) - (push name links) - (if (esd-hyperlink slot) - (string-append fmtstr " <~~a>" value-fmt "~~a>") - (string-append fmtstr (concatenate 'string " <" xml-tag ">" value-fmt "" xml-tag ">"))))) - ) ;; let value-fmt - - (let ((func (if print-formatter - `(,print-formatter (slot-value x (quote ,name))) - `(slot-value x (quote ,name))))) - (when (and (in category :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 print-formatter - (lisp-type-is-a-string type))) - (setq func `(kmrcl:xml-cdata ,func))) - (push func value-func)) - ))) - - (when value-func - (setq value-func - (compile nil (eval `(lambda (x) (values ,@(nreverse value-func))))))) - - (setf (obj-data-fmtstr view) fmtstr) - (setf (obj-data-value-func view) value-func) - (setf (link-slots view) (nreverse links)) - - (case category - ((or :compact-text :compact-text-labels) - (initialize-text-view view)) - ((or :html :xhtml :html-labels :xhtml-labels) - (initialize-html-view view)) - ((or :xml :xml-labels) - (initialize-xml-view view)) - ((or :html-link :html-link-labels) - (initialize-html-view view) - (setf (link-href-start view) "a href=") - (setf (link-href-end view) "a") - (setf (link-ampersand view) "&")) - ((or :xhtml-link :xhtml-link-labels) - (initialize-html-view view) - (setf (link-href-start view) "a href=") - (setf (link-href-end view) "a") - (setf (link-ampersand view) "&")) - ((or :xml-link :xml-link-labels) - (initialize-xml-view view) - (setf (link-href-start view) - "xmllink xlink:type=\"simple\" xlink:href=") - (setf (link-href-end view) "xmllink") - (setf (link-ampersand view) "&")) - ((or :ie-xml-link :ie-xml-link-labels) - (initialize-xml-view view) - (setf (link-href-start view) "html:a href=") - (setf (link-href-end view) "html:a") - (setf (link-ampersand view) "&")))) - view) - ;;;; ************************************************************************* ;;;; View Data Format Section @@ -512,19 +381,28 @@ (defvar +newline-string+ (format nil "~%")) +(defun write-user-name-maybe-plural (obj nitems strm) + (write-string + (if (> nitems 1) + (hyperobject-class-user-name-plural obj) + (hyperobject-class-user-name obj)) + 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) - (format strm "~a~P:~%" - (hyperobject-class-user-name obj) nitems))))) + (write-user-name-maybe-plural obj nitems strm) + (write-char #\: strm) + (write-char #\Newline strm))))) (setf (list-start-indent view) t) (setf (obj-data-indent view) t) (setf (obj-data-end-str view) +newline-string+)) (defun html-list-start-func (obj nitems strm) - (format strm "
~a~p: