r5152: *** empty log message ***

diff --git a/metaclass.lisp b/metaclass.lisp
index 60c89d28e0951c7dae8d305b47b91ebd6a5600d5..814e5d92736111cd092541513eef51af0864e1a2 100644 (file)
--- a/metaclass.lisp
+++ b/metaclass.lisp
@@ -8,7 +8,7 @@
 ;;;; Date Started:  Apr 2000
 ;;;;
 ;;;;
 ;;;; 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
 ;;;; *************************************************************************
 ;;;;
 ;;;; 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*
     :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)
   "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 836a43cac97bd011fee9942fb96557f28ee927e5..6776e39e1bc57a8455aa4a7711f09e7a4de281e4 100644 (file)
--- a/views.lisp
+++ b/views.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
 ;;;; 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
 ;;;; *************************************************************************
 ;;;;
 ;;;; 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)
                   :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
    (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-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-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))
   (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))
      (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)
     ((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)
      (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) "&"))
      (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
 (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)
                         (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 "<div class=\"ho-username\">" strm)
   (write-user-name-maybe-plural obj nitems strm)
   (write-string "<div class=\"ho-username\">" strm)
   (write-user-name-maybe-plural obj nitems strm)

-  (write-string "</div><div class=\"" strm)
-  (write-string (class-name-of obj) strm)
-  (write-string "\"><ul>" strm)
+  (write-string "</div>" strm)
+  (write-char #\newline strm)
+  (write-string "<ul>" strm)

   (write-char #\newline strm))
 
 (defun initialize-html-view (view)
   (initialize-text-view view)
   (write-char #\newline strm))
 
 (defun initialize-html-view (view)
   (initialize-text-view view)

+  (setf (indenter view) #'indent-html-spaces)

   (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-printer view) #'html-list-start-func)
   (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-printer view) #'html-list-start-func)

-  (setf (list-end-printer view) (format nil "</ul></div>~%"))
+  (setf (list-end-printer view) (format nil "</ul>~%"))

   (setf (list-end-indent view) t)
   (setf (list-end-indent view) t)

-  (setf (obj-start-indent view) t)
+  (setf (obj-start-indent view) nil)

   (setf (obj-start-printer view) "<li>")
   (setf (obj-start-printer view) "<li>")

-  (setf (obj-end-indent view)  t)
+  (setf (obj-end-indent view)  nil)

   (setf (obj-end-printer view)  (format nil "</li>~%"))
   (setf (obj-end-printer view)  (format nil "</li>~%"))

+  (setf (obj-data-end-printer view) nil)

   (setf (obj-data-indent view) nil))
 
   (setf (obj-data-indent view) nil))
 

+(defun xhtml-list-start-func (obj nitems indent strm)
+  (write-string "<div class=\"ho-username\">" strm)
+  (indent-html-spaces indent strm)
+  (write-user-name-maybe-plural obj nitems strm)
+  (write-string "</div>" strm)
+  (write-char #\newline strm))
+

 (defun initialize-xhtml-view (view)
   (initialize-text-view view)
 (defun initialize-xhtml-view (view)
   (initialize-text-view view)

+  (setf (indenter view) #'indent-html-spaces)

   (setf (file-start-str view) (format nil "<html><body>~%"))
   (setf (file-end-str view) (format nil "</body><html>~%"))
   (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-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-printer view) "<li>")
-  (setf (obj-end-indent view)  t)
-  (setf (obj-end-printer view) (format nil "</li>~%"))
-  (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 "</div>~%"))
+  (setf (obj-data-start-printer view) "<div>")
+  (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)
 
 (defun xmlformat-list-end-func (x strm)
   (write-string "</" strm)


@@ -440,7 +469,7 @@
   (write-string ">" strm)
   (write-char #\newline 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><title>" strm)
   (write-char #\< strm)
   (write-string (class-name-of x) strm)
   (write-string "list><title>" 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 (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))
 
 
   (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)
 
 (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)
   (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)
 
 (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)
   (awhen (list-end-printer view)
         (if (stringp it)
             (write-string it strm)


@@ -493,9 +524,11 @@
 
 ;;; Object Start and Ends
 
 
 ;;; Object Start and Ends
 

+

 (defun fmt-obj-start (obj view strm indent)
   (when (obj-start-indent view)
 (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)
   (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)
 
 (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))))
   (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 
 
   
 ;;; Object Data 
 


@@ -539,13 +591,20 @@
   (link-href-end view))
 
 (defun fmt-obj-data (obj view strm indent refvars link-printer)
   (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)
   (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))
   (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)
 
 (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)
         (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))
           (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))))
                                                        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)
 
       (fmt-list-end (car objlist) view strm indent nobjs)))
   objs)