r9602: add display-table view type

diff --git a/views.lisp b/views.lisp
index f6b811ae0ae8913492498c9001d91fa0e8a338de..b8074830479fe8f40096c7fc3cae324858ced219 100644 (file)
--- a/views.lisp
+++ b/views.lisp
@@ -2,14 +2,14 @@
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;

-;;;; Name:          views.lisp
-;;;; Purpose:       View methods for Hyperobjects
-;;;; Programmer:    Kevin M. Rosenberg
-;;;; Date Started:  Apr 2000
+;;;; Name:     views.lisp
+;;;; Purpose:  View methods for Hyperobjects
+;;;; Author:   Kevin M. Rosenberg
+;;;; Created:  Apr 2000

 ;;;;
 ;;;; $Id$
 ;;;;
 ;;;;
 ;;;; $Id$
 ;;;;

-;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
+;;;; This file is Copyright (c) 2000-2004 by Kevin M. Rosenberg

 ;;;; *************************************************************************
  
 (in-package #:hyperobject)
 ;;;; *************************************************************************
  
 (in-package #:hyperobject)


@@ -92,7 +92,6 @@
   (:default-initargs :link-page "meta-search.html")
   (:documentation "View class for a hyperobject"))
 
   (:default-initargs :link-page "meta-search.html")
   (:documentation "View class for a hyperobject"))
 

-

 (defun get-default-view-id (obj-cl)
   (aif (views obj-cl)
       (id (car it))
 (defun get-default-view-id (obj-cl)
   (aif (views obj-cl)
       (id (car it))


@@ -237,6 +236,11 @@
   (vector-push-extend `(write-string ,tag s) print-func)
   (vector-push-extend '(write-char #\> s) print-func))
 
   (vector-push-extend `(write-string ,tag s) print-func)
   (vector-push-extend '(write-char #\> s) print-func))
 

+(defun ppfc-display-table (title name type formatter cdata print-func)
+  (vector-push-extend '(write-string "<td>" s) print-func)
+  (ppfc-html title name type formatter cdata print-func)
+  (vector-push-extend '(write-string "</td>" s) print-func))
+                     

 (defun ppfc-html-labels (label name type formatter cdata print-func)
   (vector-push-extend '(write-string "<span class=\"label\">" s) print-func)
   (vector-push-extend `(write-string ,label s) print-func)
 (defun ppfc-html-labels (label name type formatter cdata print-func)
   (vector-push-extend '(write-string "<span class=\"label\">" s) print-func)
   (vector-push-extend `(write-string ,label s) print-func)


@@ -304,6 +308,8 @@
        (ppfc-html-labels user-name name type formatter cdata print-func))
       (:xhtml-labels
        (ppfc-xhtml-labels xml-user-name user-name name type formatter cdata print-func))
        (ppfc-html-labels user-name name type formatter cdata print-func))
       (:xhtml-labels
        (ppfc-xhtml-labels xml-user-name user-name name type formatter cdata print-func))

+      ((:display-table :display-table-labels)
+       (ppfc-display-table user-name name type formatter cdata print-func))

       (:xml-labels
        (ppfc-xml-labels xml-user-name xml-tag name type formatter cdata print-func))
       ((or :html-link :xhtml-link)
       (:xml-labels
        (ppfc-xml-labels xml-user-name xml-tag name type formatter cdata print-func))
       ((or :html-link :xhtml-link)


@@ -347,7 +353,7 @@
       :xhtml-link :html-link
       :xml :xml-labels :xml-link :ie-xml-link
       :xml-link-labels :ie-xml-link-labels
       :xhtml-link :html-link
       :xml :xml-labels :xml-link :ie-xml-link
       :xml-link-labels :ie-xml-link-labels

-      :display-table :edit-table))
+      :display-table :display-table-labels :edit-table :edit-table-labels))

 
 (defun initialize-view-by-id (obj-cl view)
   "Initialize a view based upon a preset vid"
 
 (defun initialize-view-by-id (obj-cl view)
   "Initialize a view based upon a preset vid"


@@ -406,6 +412,13 @@
      (setf (link-href-start view) "a href=")
      (setf (link-href-end view) "a")
      (setf (link-ampersand view) "&amp;"))
      (setf (link-href-start view) "a href=")
      (setf (link-href-end view) "a")
      (setf (link-ampersand view) "&amp;"))

+    ((or :display-table :display-table-labels :edit-tables)
+     (initialize-table-view view)
+     (when (in (id view) :display-table-labels :edit-table-labels)
+       (setf (list-start-printer view) #'table-label-list-start-func))
+     (setf (link-href-start view) "a href=")
+     (setf (link-href-end view) "a")
+     (setf (link-ampersand view) "&amp;"))

     ((or :xml-link :xml-link-labels)
      (initialize-xml-view view)
      (setf (link-href-start view)
     ((or :xml-link :xml-link-labels)
      (initialize-xml-view view)
      (setf (link-href-start view)


@@ -449,7 +462,7 @@
   (setf (indenter view) #'indent-spaces))
 
 (defun html-list-start-func (obj nitems indent strm)
   (setf (indenter view) #'indent-spaces))
 
 (defun html-list-start-func (obj nitems indent strm)

-  (write-string "<div class=\"ho-username\" :style=\"margin-left:" 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-fixnum (+ indent indent) strm)
   (write-string "em;\">" strm)
   (write-user-name-maybe-plural obj nitems strm)


@@ -475,16 +488,49 @@
   (setf (obj-data-indent view) nil))
 
 (defun xhtml-list-start-func (obj nitems indent strm)
   (setf (obj-data-indent view) nil))
 
 (defun xhtml-list-start-func (obj nitems indent strm)

-  (write-string "<div class=\"ho-username\" :style=\"margin-left:" 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-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-string "<div style=\"margin-left:" strm)

   (write-fixnum (+ indent indent) strm)
   (write-string "em;\">" strm)
   (write-char #\newline strm))
 
   (write-fixnum (+ indent indent) strm)
   (write-string "em;\">" strm)
   (write-char #\newline strm))
 

+(defun table-list-start-func (obj nitems 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-char #\newline strm)
+  (write-string "<table style=\"margin-left:" strm)
+  (write-fixnum (+ indent indent) strm)
+  (write-string "em;\">" strm)
+  (write-string "<tbody>" strm)
+  (write-char #\newline strm))
+
+(defun table-label-list-start-func (obj nitems 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-char #\newline strm)
+  (write-string "<table style=\"margin-left:" strm)
+  (write-fixnum (+ indent indent) strm)
+  (write-string "em;\">" strm)
+  (write-string "<thead>" strm)
+  (dolist (slot (default-print-slots (class-of obj)))
+    (write-string "<th>" strm)
+    (write-string (write-to-string slot) strm)
+    (write-string "</th>" strm))
+  (write-string "</thead>" strm)
+  (write-char #\newline strm)
+  (write-string "<tbody>" 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 html-obj-start (obj indent strm)
   (declare (ignore obj indent))
   (write-string "<div style=\"margin-left:2em;\">" strm))


@@ -503,6 +549,21 @@
   (setf (obj-end-printer view) (format nil "</div>~%"))
   (setf (obj-data-indent view) nil))
 
   (setf (obj-end-printer view) (format nil "</div>~%"))
   (setf (obj-data-indent view) nil))
 

+(defun initialize-table-view (view)
+  (initialize-text-view view)
+  (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) #'table-list-start-func)
+  (setf (list-end-printer view) (format nil "</tbody>~%</table>~%"))
+  (setf (list-end-indent view) nil)
+  (setf (obj-start-indent view) nil)
+  (setf (obj-start-printer view) #'html-obj-start)
+  (setf (obj-start-printer view) (format nil "<tr>"))
+  (setf (obj-end-printer view) (format nil "</tr>~%"))
+  (setf (obj-data-indent view) nil))
+

 (defun xmlformat-list-end-func (x strm)
   (write-string "</" strm)
   (write-string (class-name-of x) strm)
 (defun xmlformat-list-end-func (x strm)
   (write-string "</" strm)
   (write-string (class-name-of x) strm)