From: Kevin M. Rosenberg <kevin@rosenberg.net>
Date: Sun, 13 Jun 2004 19:07:54 +0000 (+0000)
Subject: r9602: add display-table view type
X-Git-Tag: debian-2.11.0-2~22
X-Git-Url: http://git.kpe.io/?p=hyperobject.git;a=commitdiff_plain;h=15567a20f92d9af44aaba8b8c697b215215816fa

r9602: add display-table view type
---

diff --git a/views.lisp b/views.lisp
index f6b811a..b807483 100644
--- a/views.lisp
+++ b/views.lisp
@@ -2,14 +2,14 @@
 ;;;; *************************************************************************
 ;;;; 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$
 ;;;;
-;;;; 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)
@@ -92,7 +92,6 @@
   (: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))
@@ -237,6 +236,11 @@
   (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)
@@ -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))
+      ((: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)
@@ -347,7 +353,7 @@
       :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"
@@ -406,6 +412,13 @@
      (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)
@@ -449,7 +462,7 @@
   (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)
@@ -475,16 +488,49 @@
   (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-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))
 
+(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))
@@ -503,6 +549,21 @@
   (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)