X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=views.lisp;h=ef116ac0c25c2ed6768f54fb6fe78c2022603904;hb=247fa39146e69b658f5adf5145a3472487eab321;hp=70819fd276faa89a894cb03156d4e386fd4db58a;hpb=0bb5498ce669d7f3c6d619bea10056b24db30b0a;p=hyperobject.git diff --git a/views.lisp b/views.lisp index 70819fd..ef116ac 100644 --- a/views.lisp +++ b/views.lisp @@ -7,15 +7,12 @@ ;;;; 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.57 2003/06/20 08:35:21 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg ;;;; ************************************************************************* -(in-package :hyperobject) - -(eval-when (:compile-toplevel :execute) - (declaim (optimize (speed 2) (safety 2) (compilation-speed 0) (debug 2)))) +(in-package #:hyperobject) (defclass object-view () @@ -58,6 +55,14 @@ :accessor obj-end-printer) (obj-end-indent :initform nil :initarg :obj-end-indent :accessor obj-end-indent) + (subobj-start-printer :type (or string function null) :initform nil :initarg :subobj-start-printer + :accessor subobj-start-printer) + (subobj-start-indent :initform nil :initarg :subobj-start-indent + :accessor subobj-start-indent) + (subobj-end-printer :type (or string function null) :initform nil :initarg :subobj-end-printer + :accessor subobj-end-printer) + (subobj-end-indent :initform nil :initarg :subobj-end-indent + :accessor subobj-end-indent) (obj-data-indent :initform nil :initarg :obj-data-indent :accessor obj-data-indent) (obj-data-printer :type (or function null) :initform nil @@ -66,21 +71,28 @@ (obj-data-print-code :type (or function null) :initform nil :initarg :obj-data-print-code :accessor obj-data-print-code) - (obj-data-end-str :type (or string null) :initform nil - :initarg :obj-data-end-str - :accessor obj-data-end-str) + (obj-data-start-printer :type (or function string null) :initform nil + :initarg :obj-data-start-printer + :accessor obj-data-start-printer) + (obj-data-end-printer :type (or string null) :initform nil + :initarg :obj-data-end-printer + :accessor obj-data-end-printer) + (indenter :type (or function null) :initform nil + :accessor indenter + :documentation "Function that performs hierarchical indenting") (link-slots :type list :initform nil :documentation "List of slot names that have hyperlinks" :accessor link-slots) - (link-page-name :type (or string null) :initform nil :initarg :link-page-name - :accessor link-page-name) + (link-page :type (or string null) :initform nil + :initarg :link-page + :accessor link-page) (link-href-start :type (or string null) :initform nil :initarg :link-href-start :accessor link-href-start) (link-href-end :type (or string null) :initform nil :initarg :link-href-end :accessor link-href-end) (link-ampersand :type (or string null) :initform nil :initarg :link-ampersand :accessor link-ampersand)) - (:default-initargs :link-page-name "disp-func1") + (:default-initargs :link-page "disp-func1") (:documentation "View class for a hyperobject")) @@ -134,7 +146,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)))) @@ -164,9 +176,8 @@ `(typecase ,v (string (write-string ,v ,s)) - #+allegro (fixnum - (excl::print-fixnum ,s 10 ,v)) + (write-fixnum ,v ,s)) (symbol (write-string (symbol-name ,v) ,s)) (t @@ -177,12 +188,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 " s) print-func)) (defun ppfc-html-link-labels (label name type formatter cdata nlink print-func) - (vector-push-extend '(write-string " " s) print-func) + (vector-push-extend '(write-string " " s) print-func) (ppfc-html-link name type formatter cdata nlink 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 @@ -255,44 +264,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 +340,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 s 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))) @@ -347,8 +356,10 @@ (case (category view) ((or :compact-text :compact-text-labels) (initialize-text-view view)) - ((or :html :xhtml :html-labels :xhtml-labels) + ((or :html :html-labels) (initialize-html-view view)) + ((or :xhtml :xhtml-labels) + (initialize-xhtml-view view)) ((or :xml :xml-labels) (initialize-xml-view view)) ((or :html-link :html-link-labels) @@ -357,7 +368,7 @@ (setf (link-href-end view) "a") (setf (link-ampersand view) "&")) ((or :xhtml-link :xhtml-link-labels) - (initialize-html-view view) + (initialize-xhtml-view view) (setf (link-href-start view) "a href=") (setf (link-href-end view) "a") (setf (link-ampersand view) "&")) @@ -393,48 +404,69 @@ (defun initialize-text-view (view) (setf (list-start-printer view) (compile nil - (eval '(lambda (obj nitems strm) + (eval '(lambda (obj nitems indent strm) + (declare (ignore indent)) (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+)) + (setf (obj-data-end-printer view) +newline-string+) + (setf (indenter view) #'indent-spaces)) -(defun html-list-start-func (obj nitems strm) - (write-string "
" strm)
+(defun html-list-start-func (obj nitems indent strm)
+ (write-string "" strm)
+ (write-string "
" strm)
(write-char #\newline strm))
(defun initialize-html-view (view)
(initialize-text-view view)
+ (setf (indenter view) #'indent-spaces)
(setf (file-start-str view) (format nil "~%"))
(setf (file-end-str view) (format nil "~%"))
(setf (list-start-indent view) t)
(setf (list-start-printer view) #'html-list-start-func)
- (setf (list-end-printer view) (format nil "