r5176: *** empty log message ***

[hyperobject.git] / views.lisp
diff --git a/views.lisp b/views.lisp

index 6776e39e1bc57a8455aa4a7711f09e7a4de281e4..c2c71d734edd76677aecc848b114f616126427bc 100644 (file)
--- a/views.lisp
+++ b/views.lisp
@@ -7,7 +7,7 @@
  ;;;; Programmer:    Kevin M. Rosenberg
  ;;;; Date Started:  Apr 2000
  ;;;;
-;;;; $Id: views.lisp,v 1.56 2003/06/17 17:50:45 kevin Exp $
+;;;; $Id: views.lisp,v 1.58 2003/06/23 20:08:06 kevin Exp $
  ;;;;
  ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
  ;;;; *************************************************************************
@@ -168,7 +168,7 @@
  (defun initialize-view-by-source-code (obj-cl view)
    "Initialize a view based upon a source code"
    (let ((source-code (source-code view)))
-    (error "not implemented")
+    (warn "source code compilation is not implemented")
      )
    )
  
@@ -176,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
@@ -318,7 +317,8 @@
               :xhtml :xhtml-labels :xhtml-link-labels
               :xhtml-link :html-link
               :xml :xml-labels :xml-link :ie-xml-link
-             :xml-link-labels :ie-xml-link-labels)
+             :xml-link-labels :ie-xml-link-labels
+             :display-table :edit-table)
      (error "Unknown view category ~A" (category view)))
    
    (unless (slots view) (setf (slots view) (default-print-slots obj-cl)))
@@ -386,6 +386,12 @@
       (setf (link-ampersand view) "&amp;"))))
  
  
+(defun make-std-object-slots-view (class-name slots)
+  #'(lambda (obj strm)
+      )
+    
+  )
+
  ;;;; *************************************************************************
  ;;;;  View Data Format Section
  ;;;; *************************************************************************
@@ -406,6 +412,7 @@
    (setf (list-start-printer view)
         (compile nil
                  (eval '(lambda (obj nitems indent strm)
+                        (declare (ignore indent))
                          (write-user-name-maybe-plural obj nitems strm)
                          (write-char #\: strm)
                          (write-char #\Newline strm)))))
@@ -415,7 +422,9 @@
    (setf (indenter view) #'indent-spaces))
  
  (defun html-list-start-func (obj nitems indent strm)
-  (write-string "<div class=\"ho-username\">" strm)
+  (write-string "<div class=\"ho-username\" :style=\"margin-left:" strm)
+  (write-fixnum (+ indent indent) strm)
+  (write-string "em;\">" strm)
    (write-user-name-maybe-plural obj nitems strm)
    (write-string "</div>" strm)
    (write-char #\newline strm)
@@ -424,7 +433,7 @@
  
  (defun initialize-html-view (view)
    (initialize-text-view view)
-  (setf (indenter view) #'indent-html-spaces)
+  (setf (indenter view) #'indent-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)
@@ -439,28 +448,33 @@
    (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-string "<div class=\"ho-username\" :style=\"margin-left:" strm)
+  (write-fixnum (+ indent indent) strm)
+  (write-string "em;\">" strm)
    (write-user-name-maybe-plural obj nitems strm)
    (write-string "</div>" strm)
+  (write-string "<div :style=\"margin-left:" strm)
+  (write-fixnum (+ indent indent) strm)
+  (write-string "em;\">" strm)
    (write-char #\newline strm))
  
+(defun html-obj-start (obj indent strm)
+  (declare (ignore obj indent))
+  (write-string "<div style=\"margin-left:2em;\">" strm))
+
  (defun initialize-xhtml-view (view)
    (initialize-text-view view)
-  (setf (indenter view) #'indent-html-spaces)
+  (setf (indenter view) #'indent-spaces)
    (setf (file-start-str view) (format nil "<html><body>~%"))
    (setf (file-end-str view) (format nil "</body><html>~%"))
    (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-printer view) (format nil "</div>~%"))
    (setf (list-end-indent view) nil)
    (setf (obj-start-indent view) nil)
-  (setf (obj-start-printer view) nil)
+  (setf (obj-start-printer view) #'html-obj-start)
    (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))
+  (setf (obj-data-indent view) nil))
  
  (defun xmlformat-list-end-func (x strm)
    (write-string "</" strm)
@@ -470,6 +484,7 @@
    (write-char #\newline strm))
  
  (defun xmlformat-list-start-func (x nitems indent strm)
+  (declare (ignore indent))
    (write-char #\< strm)
    (write-string (class-name-of x) strm)
    (write-string "list><title>" strm)
@@ -486,7 +501,7 @@
    (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 (subobj-end-printer view) (format nil "</~(~a~)>~%" (object-class-name view)))
+  (setf (subobj-end-printer view) (format nil "</~(~a~)>" (object-class-name view)))
    (setf (subobj-end-indent view) nil)
    (setf (obj-data-indent view) nil))
  
@@ -532,7 +547,7 @@
    (awhen (obj-start-printer view)
          (if (stringp it)
              (write-string it strm)
-            (funcall it obj strm))))
+            (funcall it obj indent strm))))
  
  (defun fmt-obj-end (obj view strm indent)
    (when (obj-end-indent view)
@@ -550,7 +565,7 @@
    (awhen (subobj-start-printer view)
          (if (stringp it)
              (write-string it strm)
-            (funcall it obj strm))))
+            (funcall it obj indent strm))))
  
  (defun fmt-subobj-end (obj view strm indent)
    (when (subobj-end-indent view)