From 3537a8422aeb2817b41ee835c5ff45ba1d973c98 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Tue, 17 Jun 2003 17:50:45 +0000 Subject: [PATCH] r5152: *** empty log message *** --- metaclass.lisp | 11 ++-- views.lisp | 133 ++++++++++++++++++++++++++++++++++++------------- 2 files changed, 102 insertions(+), 42 deletions(-) diff --git a/metaclass.lisp b/metaclass.lisp index 60c89d2..814e5d9 100644 --- a/metaclass.lisp +++ b/metaclass.lisp @@ -8,7 +8,7 @@ ;;;; Date Started: Apr 2000 ;;;; ;;;; -;;;; $Id: metaclass.lisp,v 1.8 2003/06/06 21:59:29 kevin Exp $ +;;;; $Id: metaclass.lisp,v 1.9 2003/06/17 17:50:45 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg ;;;; ************************************************************************* @@ -20,11 +20,10 @@ :direct-rules) "List of class options for hyperobjects.") (defparameter *slot-options* - '(:value-type :print-formatter :description :user-name - :subobject :hyperlink :hyperlink-parameters - :index :inverse :unique :sql-name :null-allowed :stored - :input-filter :unbound-lookup - :value-constraint :nil-text) + '(:value-type :print-formatter :description :short-description :user-name + :subobject :hyperlink :hyperlink-parameters :index :inverse :unique + :sql-name :null-allowed :stored :input-filter :unbound-lookup + :value-constraint :void-text) "Slot options that can appear as an initarg") (defparameter *slot-options-no-initarg* '(:ho-type :sql-type :length) diff --git a/views.lisp b/views.lisp index 836a43c..6776e39 100644 --- a/views.lisp +++ b/views.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: views.lisp,v 1.55 2003/06/17 04:56:02 kevin Exp $ +;;;; $Id: views.lisp,v 1.56 2003/06/17 17:50:45 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg ;;;; ************************************************************************* @@ -55,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 @@ -63,9 +71,15 @@ (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) @@ -343,8 +357,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) @@ -353,7 +369,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) "&")) @@ -389,49 +405,62 @@ (defun initialize-text-view (view) (setf (list-start-printer view) (compile nil - (eval '(lambda (obj nitems strm) + (eval '(lambda (obj nitems indent strm) (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) +(defun html-list-start-func (obj nitems indent strm) (write-string "
" strm) (write-user-name-maybe-plural obj nitems strm) - (write-string "
" strm) + (write-char #\newline strm) + (write-string "~%")) + (setf (list-end-printer view) (format nil "~%")) (setf (list-end-indent view) t) - (setf (obj-start-indent view) t) + (setf (obj-start-indent view) nil) (setf (obj-start-printer view) "
  • ") - (setf (obj-end-indent view) t) + (setf (obj-end-indent view) nil) (setf (obj-end-printer view) (format nil "
    • ~%")) + (setf (obj-data-end-printer view) nil) (setf (obj-data-indent view) nil)) +(defun xhtml-list-start-func (obj nitems indent strm) + (write-string "
    " strm) + (indent-html-spaces indent strm) + (write-user-name-maybe-plural obj nitems strm) + (write-string "
    " strm) + (write-char #\newline strm)) + (defun initialize-xhtml-view (view) (initialize-text-view view) + (setf (indenter view) #'indent-html-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 "~%")) - (setf (list-end-indent view) t) - (setf (obj-start-indent view) t) - (setf (obj-start-printer view) "
  • ") - (setf (obj-end-indent view) t) - (setf (obj-end-printer view) (format nil "
    • ~%")) - (setf (obj-data-indent view) nil)) + (setf (list-start-indent view) nil) + (setf (list-start-printer view) #'xhtml-list-start-func) + (setf (list-end-printer view) (format nil "~%")) + (setf (list-end-indent view) nil) + (setf (obj-start-indent view) nil) + (setf (obj-start-printer view) nil) + (setf (obj-end-printer view) (format nil "~%")) + (setf (obj-data-start-printer view) "
    ") + (setf (obj-data-end-printer view) nil) + (setf (obj-end-indent view) nil) + (setf (obj-data-indent view) t)) (defun xmlformat-list-end-func (x strm) (write-string "" strm) (write-char #\newline strm)) -(defun xmlformat-list-start-func (x nitems strm) +(defun xmlformat-list-start-func (x nitems indent strm) (write-char #\< strm) (write-string (class-name-of x) strm) (write-string "list>" strm) @@ -457,8 +486,8 @@ (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-printer view) (format nil "</~(~a~)>~%" (object-class-name view))) - (setf (obj-end-indent view) nil) + (setf (subobj-end-printer view) (format nil "</~(~a~)>~%" (object-class-name view))) + (setf (subobj-end-indent view) nil) (setf (obj-data-indent view) nil)) @@ -476,16 +505,18 @@ (defun fmt-list-start (obj view strm indent num-items) (when (list-start-indent view) - (indent-spaces indent strm)) + (awhen (indenter view) + (funcall it indent strm))) (awhen (list-start-printer view) (if (stringp it) (write-string it strm) - (funcall it obj num-items strm)))) + (funcall it obj num-items indent strm)))) (defun fmt-list-end (obj view strm indent num-items) (declare (ignore num-items)) (when (list-end-indent view) - (indent-spaces indent strm)) + (awhen (indenter view) + (funcall it indent strm))) (awhen (list-end-printer view) (if (stringp it) (write-string it strm) @@ -493,9 +524,11 @@ ;;; Object Start and Ends + (defun fmt-obj-start (obj view strm indent) (when (obj-start-indent view) - (indent-spaces indent strm)) + (awhen (indenter view) + (funcall it indent strm))) (awhen (obj-start-printer view) (if (stringp it) (write-string it strm) @@ -503,11 +536,30 @@ (defun fmt-obj-end (obj view strm indent) (when (obj-end-indent view) - (indent-spaces indent strm)) + (awhen (indenter view) + (funcall it indent strm))) (awhen (obj-end-printer view) (if (stringp it) (write-string it strm) (funcall it obj strm)))) + +(defun fmt-subobj-start (obj view strm indent) + (when (subobj-start-indent view) + (awhen (indenter view) + (funcall it indent strm))) + (awhen (subobj-start-printer view) + (if (stringp it) + (write-string it strm) + (funcall it obj strm)))) + +(defun fmt-subobj-end (obj view strm indent) + (when (subobj-end-indent view) + (awhen (indenter view) + (funcall it indent strm))) + (awhen (subobj-end-printer view) + (if (stringp it) + (write-string it strm) + (funcall it obj strm)))) ;;; Object Data @@ -539,13 +591,20 @@ (link-href-end view)) (defun fmt-obj-data (obj view strm indent refvars link-printer) + (awhen (obj-data-start-printer view) + (if (stringp it) + (write-string it strm) + (funcall it obj strm))) (when (obj-data-indent view) - (indent-spaces indent strm)) + (awhen (indenter view) + (funcall it indent strm))) (if (link-slots view) (fmt-obj-data-with-link obj view strm refvars link-printer) (fmt-obj-data-plain obj view strm)) - (awhen (obj-data-end-str view) - (write-string it strm))) + (awhen (obj-data-end-printer view) + (if (stringp it) + (write-string it strm) + (funcall it obj strm)))) (defun fmt-obj-data-plain (obj view strm) (awhen (obj-data-printer view) @@ -595,6 +654,8 @@ (unless (and filter (not (funcall filter obj))) (fmt-obj-start obj view strm indent) (fmt-obj-data obj view strm (1+ indent) refvars link-printer) + (fmt-obj-end obj view strm indent) + (fmt-subobj-start obj view strm indent) (when (and subobjects (hyperobject-class-subobjects obj)) (dolist (subobj (hyperobject-class-subobjects obj)) (aif (slot-value obj (name-slot subobj)) @@ -603,7 +664,7 @@ category) category strm (1+ indent) filter subobjects refvars link-printer)))) - (fmt-obj-end obj view strm indent))) + (fmt-subobj-end obj view strm indent))) (fmt-list-end (car objlist) view strm indent nobjs))) objs) -- 2.34.1