X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=views.lisp;h=8d43e6995ac21af847bb9fa4d7df8d7f9fd38b20;hb=9452174b88c426cbd0fe206676c3f74c4225268e;hp=f6b811ae0ae8913492498c9001d91fa0e8a338de;hpb=4e7663474e8f4d70c04379b1a8a2859a03f13abc;p=hyperobject.git diff --git a/views.lisp b/views.lisp index f6b811a..8d43e69 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 "" s) print-func) + (ppfc-html title name type formatter cdata print-func) + (vector-push-extend '(write-string "" s) print-func)) + (defun ppfc-html-labels (label name type formatter cdata print-func) (vector-push-extend '(write-string "" 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" @@ -357,7 +363,7 @@ (unless (slots view) (setf (slots view) (default-print-slots obj-cl))) (let ((links '()) - (print-func (make-array 10 :fill-pointer 0 :adjustable t))) + (print-func (make-array 20 :fill-pointer 0 :adjustable t))) (do* ((slots (slots view) (cdr slots)) (slot-name (car slots) (car slots)) @@ -406,6 +412,13 @@ (setf (link-href-start view) "a href=") (setf (link-href-end view) "a") (setf (link-ampersand view) "&")) + ((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) "&")) ((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 "
" 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 "
" strm) (write-user-name-maybe-plural obj nitems strm) (write-string "
" strm) - (write-string "
" strm) (write-char #\newline strm)) +(defun table-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 "" strm) + (write-string "" strm) + (write-char #\newline strm)) + +(defun table-label-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 "
" strm) + (write-string "" strm) + (dolist (slot (default-print-slots (class-of obj))) + (write-string "" strm)) + (write-string "" strm) + (write-char #\newline strm) + (write-string "" strm) + (write-char #\newline strm)) + (defun html-obj-start (obj indent strm) (declare (ignore obj indent)) (write-string "
" strm)) @@ -503,6 +549,21 @@ (setf (obj-end-printer view) (format nil "
~%")) (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 "~%")) + (setf (file-end-str view) (format nil "~%")) + (setf (list-start-indent view) nil) + (setf (list-start-printer view) #'table-list-start-func) + (setf (list-end-printer view) (format nil "~%
" strm) + (write-string (write-to-string slot) strm) + (write-string "
~%")) + (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 "")) + (setf (obj-end-printer view) (format nil "~%")) + (setf (obj-data-indent view) nil)) + (defun xmlformat-list-end-func (x strm) (write-string "" name)) (setf (obj-start-indent view) t) + (setf (obj-end-printer view) (format nil "~%" name)) (setf (subobj-end-printer view) (format nil "~%" name)) (setf (subobj-end-indent view) nil) (setf (obj-data-indent view) nil))) @@ -710,11 +772,13 @@ (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) - (when subobjects - (fmt-subobj-start obj view strm indent) - (view-subobjects obj strm vid indent filter subobjects - refvars link-printer) - (fmt-subobj-end obj view strm indent)))) + (if subobjects + (progn + (fmt-subobj-start obj view strm indent) + (view-subobjects obj strm vid indent filter subobjects + refvars link-printer) + (fmt-subobj-end obj view strm indent)) + (fmt-subobj-start obj view strm indent)))) (fmt-list-end (car objlist) view strm indent nobjs))) objs)