views.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:     views.lisp
   6 ;;;; Purpose:  View methods for Hyperobjects
   7 ;;;; Author:   Kevin M. Rosenberg
   8 ;;;; Created:  Apr 2000
   9 ;;;;
  10 ;;;; $Id$
  11 ;;;;
  12 ;;;; This file is Copyright (c) 2000-2004 by Kevin M. Rosenberg
  13 ;;;; *************************************************************************
  14
  15 (in-package #:hyperobject)
  16
  17
  18 (defclass object-view ()
  19   ((object-class :initform nil :initarg :object-class
  20                  :accessor object-class
  21                  :documentation "Class of object to be viewed.")
  22    (slots :initform nil :initarg :slots :accessor slots
  23           :documentation "List of effective slots for object to be viewed.")
  24    (id :initform nil :initarg :id :accessor id
  25        :documentation "id for this view.")
  26    (source-code :initform nil :initarg :source-code :accessor source-code
  27                 :documentation "Source code for generating view.")
  28    (country-language :initform :en :initarg :country-language
  29                      :documentation "Country's Language for this view.")
  30    (printer :initform nil :initarg :printer :accessor printer
  31             :documentation "default function that prints the object")
  32    ;;
  33    (file-start-str :type (or string null) :initform nil :initarg :file-start-str
  34                    :accessor file-start-str)
  35    (file-end-str :type (or string null) :initform nil :initarg :file-end-str
  36                  :accessor file-end-str)
  37    (list-start-printer :type (or string function null) :initform nil
  38                            :initarg :list-start-printer
  39                       :accessor list-start-printer)
  40    (list-start-indent :initform nil :initarg :list-start-indent
  41                       :accessor list-start-indent)
  42    (list-end-printer :type (or string function null) :initform nil
  43                          :initarg :list-end-printer
  44                     :accessor list-end-printer)
  45    (list-end-indent :initform nil :initarg :list-end-indent
  46                     :accessor list-end-indent)
  47    (obj-start-printer :type (or string function null) :initform nil :initarg :obj-start-printer
  48                      :accessor obj-start-printer)
  49    (obj-start-indent :initform nil :initarg :obj-start-indent
  50                      :accessor obj-start-indent)
  51    (obj-end-printer :type (or string function null) :initform nil :initarg :obj-end-printer
  52                    :accessor obj-end-printer)
  53    (obj-end-indent :initform nil :initarg :obj-end-indent
  54                    :accessor obj-end-indent)
  55    (subobj-start-printer :type (or string function null) :initform nil :initarg :subobj-start-printer
  56                      :accessor subobj-start-printer)
  57    (subobj-start-indent :initform nil :initarg :subobj-start-indent
  58                      :accessor subobj-start-indent)
  59    (subobj-end-printer :type (or string function null) :initform nil :initarg :subobj-end-printer
  60                    :accessor subobj-end-printer)
  61    (subobj-end-indent :initform nil :initarg :subobj-end-indent
  62                    :accessor subobj-end-indent)
  63    (obj-data-indent :initform nil :initarg :obj-data-indent
  64                     :accessor obj-data-indent)
  65    (obj-data-printer :type (or function null) :initform nil
  66                         :initarg :obj-data-printer
  67                         :accessor obj-data-printer)
  68    (obj-data-print-code :type (or function list null) :initform nil
  69                   :initarg :obj-data-print-code
  70                   :accessor obj-data-print-code)
  71    (obj-data-start-printer :type (or function string null) :initform nil
  72                      :initarg :obj-data-start-printer
  73                      :accessor obj-data-start-printer)
  74    (obj-data-end-printer :type (or string null) :initform nil
  75                         :initarg :obj-data-end-printer
  76                         :accessor obj-data-end-printer)
  77    (indenter :type (or function null) :initform nil
  78              :accessor indenter
  79              :documentation "Function that performs hierarchical indenting")
  80    (link-slots :type list :initform nil
  81                :documentation "List of slot names that have hyperlinks"
  82                :accessor link-slots)
  83    (link-page :type (or string null) :initform nil
  84                       :initarg :link-page
  85                       :accessor link-page)
  86    (link-href-start :type (or string null) :initform nil :initarg :link-href-start
  87                     :accessor link-href-start)
  88    (link-href-end :type (or string null) :initform nil :initarg :link-href-end
  89                   :accessor link-href-end)
  90    (link-ampersand :type (or string null) :initform nil :initarg :link-ampersand
  91                    :accessor link-ampersand))
  92   (:default-initargs :link-page "meta-search.html")
  93   (:documentation "View class for a hyperobject"))
  94
  95 (defun get-default-view-id (obj-cl)
  96   (aif (views obj-cl)
  97       (id (car it))
  98       :compact-text))
  99
 100 (defun find-view-id-in-class-precedence (obj-cl vid)
 101   "Looks for a view in class and parent classes"
 102   (when (typep obj-cl 'hyperobject-class)
 103     (aif (find vid (views obj-cl) :key #'id :test #'eq)
 104          it
 105          (let (cpl)
 106            (handler-case
 107                (setq cpl (class-precedence-list obj-cl))
 108              (error (e)
 109                (declare (ignore e))
 110                ;; can't get cpl unless class finalized
 111                (make-instance (class-name obj-cl))
 112                (setq cpl (class-precedence-list obj-cl))))
 113            (find-view-id-in-class-precedence (second cpl) vid)))))
 114
 115
 116 (defun get-view-id (obj vid &optional slots)
 117   "Find or make a category view for an object"
 118   (let ((obj-cl (class-of obj)))
 119     (unless vid
 120       (setq vid (get-default-view-id obj-cl)))
 121     (aif (find-view-id-in-class-precedence obj-cl vid)
 122          it
 123          (let ((view
 124                 (make-instance 'object-view
 125                   :object-class (class-name obj-cl)
 126                   :id vid
 127                   :slots slots)))
 128            (push view (views obj-cl))
 129            view))))
 130
 131 ;;;; *************************************************************************
 132 ;;;;  Metaclass Intialization
 133 ;;;; *************************************************************************
 134
 135 (defun finalize-views (cl)
 136   "Finalize all views that are given on a objects initialization"
 137   (unless (default-print-slots cl)
 138     (setf (default-print-slots cl)
 139           (mapcar #'slot-definition-name (class-slots cl))))
 140   (setf (views cl)
 141     (loop for view-def in (direct-views cl)
 142         collect (make-object-view cl view-def))))
 143
 144 (defun make-object-view (cl view-def)
 145   "Make an object view from a definition. Do nothing if a class is passed so that reinitialization will be a no-op"
 146   (cond
 147     ((typep view-def 'object-view)
 148      view-def)
 149     ((eq view-def :default)
 150      (make-instance 'object-view
 151        :object-class (class-name cl)
 152        :id :compact-text))
 153     ((consp view-def)
 154      (make-instance 'object-view
 155                     :object-class (class-name cl)
 156                     :id (getf view-def :id)
 157                     :slots (getf view-def :slots)
 158                     :source-code (getf view-def :source-code)))
 159     (t
 160      (error "Invalid parameter to make-object-view: ~S" view-def))))
 161
 162 (defmethod initialize-instance :after ((self object-view)
 163                                        &rest initargs
 164                                        &key
 165                                        &allow-other-keys)
 166   (declare (ignore initargs))
 167   (initialize-view self))
 168
 169 (defun initialize-view (view)
 170   "Calculate all view slots for a hyperobject class"
 171   (let ((obj-cl (find-class (object-class view))))
 172     (cond
 173      ((source-code view)
 174       (initialize-view-by-source-code view))
 175      ((id view)
 176       (initialize-view-by-id obj-cl view))
 177      (t
 178       (setf (id view) :compact-text)
 179       (initialize-view-by-id obj-cl view)))))
 180
 181
 182
 183 (defun initialize-view-by-source-code (view)
 184   "Initialize a view based upon a source code"
 185   (let* ((source-code (source-code view))
 186          (printer `(lambda
 187                        (,(intern (symbol-name '#:self)
 188                                  (symbol-package (object-class view)))
 189                         ,(intern (symbol-name '#:s)
 190                                  (symbol-package (object-class view))))
 191                      (declare (ignorable
 192                                ,(intern (symbol-name '#:self)
 193                                         (symbol-package (object-class view)))
 194                                ,(intern (symbol-name '#:s)
 195                                         (symbol-package (object-class view)))))
 196                      (with-slots ,(slots view)
 197                          ,(intern (symbol-name '#:self)
 198                                   (symbol-package (object-class view)))
 199                        ,@source-code))))
 200     (setf (printer view)
 201       (compile nil (eval printer)))))
 202
 203 (defmacro write-simple (v s)
 204   `(typecase ,v
 205     (string
 206      (write-string ,v ,s))
 207     (fixnum
 208      (write-fixnum ,v ,s))
 209     (symbol
 210      (write-string (symbol-name ,v) ,s))
 211     (t
 212      (write-string (write-to-string ,v) ,s))))
 213
 214 (defun write-ho-value (obj name type formatter cdata strm)
 215   (declare (ignorable type))
 216   (let* ((slot-data (slot-value obj name))
 217          (fmt-data (if formatter
 218                        (funcall formatter slot-data)
 219                        slot-data)))
 220     (if cdata
 221         (write-cdata fmt-data strm)
 222         (write-simple fmt-data strm))))
 223
 224 (defun ppfc-html (title name type formatter cdata print-func)
 225   (vector-push-extend '(write-string "<span class=\"" s) print-func)
 226   (vector-push-extend `(write-string ,title s) print-func)
 227   (vector-push-extend '(write-string "\">" s) print-func)
 228   (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func)
 229   (vector-push-extend '(write-string "</span>" s) print-func))
 230
 231 (defun ppfc-xml (tag name type formatter cdata print-func)
 232   (vector-push-extend '(write-char #\< s) print-func)
 233   (vector-push-extend `(write-string ,tag s) print-func)
 234   (vector-push-extend '(write-char #\> s) print-func)
 235   (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func)
 236   (vector-push-extend '(write-string "</" s) print-func)
 237   (vector-push-extend `(write-string ,tag s) print-func)
 238   (vector-push-extend '(write-char #\> s) print-func))
 239
 240 (defun ppfc-display-table (title name type formatter cdata print-func)
 241   (vector-push-extend '(write-string "<td>" s) print-func)
 242   (ppfc-html title name type formatter cdata print-func)
 243   (vector-push-extend '(write-string "</td>" s) print-func))
 244
 245 (defun ppfc-html-labels (label name type formatter cdata print-func)
 246   (vector-push-extend '(write-string "<span class=\"label\">" s) print-func)
 247   (vector-push-extend `(when (stringp ,label) (write-string ,label s)) print-func)
 248   (vector-push-extend '(write-string "</span> " s) print-func)
 249   (ppfc-html label name type formatter cdata print-func))
 250
 251 (defun ppfc-xhtml-labels (label tag name type formatter cdata print-func)
 252   (vector-push-extend '(write-string "<span class=\"label\">" s) print-func)
 253   (vector-push-extend `(when (stringp ,label) (write-string ,label s)) print-func)
 254   (vector-push-extend '(write-string "</span> " s) print-func)
 255   (ppfc-html tag name type formatter cdata print-func))
 256
 257 (defun ppfc-xml-labels (label tag name type formatter cdata print-func)
 258   (vector-push-extend '(write-string "<label>" s) print-func)
 259   (vector-push-extend `(when (stringp ,label) (write-string ,label s)) print-func)
 260   (vector-push-extend '(write-string "</label> " s) print-func)
 261   (ppfc-xml tag name type formatter cdata print-func))
 262
 263 (defun ppfc-html-link (name type formatter cdata nlink print-func)
 264   (declare (fixnum nlink))
 265   (vector-push-extend '(write-char #\< s) print-func)
 266   (vector-push-extend `(when (stringp (nth ,(+ nlink nlink) links))
 267                          (write-string (nth ,(+ nlink nlink) links) s)) print-func)
 268   (vector-push-extend '(write-char #\> s) print-func)
 269   (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func)
 270   (vector-push-extend '(write-string "</" s) print-func)
 271   (vector-push-extend `(when (stringp (nth ,(+ nlink nlink 1) links))
 272                          (write-string (nth ,(+ nlink nlink 1) links) s)) print-func)
 273   (vector-push-extend '(write-char #\> s) print-func))
 274
 275 (defun ppfc-html-link-labels (label name type formatter cdata nlink print-func)
 276   (vector-push-extend '(write-string "<span class=\"label\">" s) print-func)
 277   (vector-push-extend `(when (stringp ,label) (write-string ,label s)) print-func)
 278   (vector-push-extend '(write-string "</span> " s) print-func)
 279   (ppfc-html-link name type formatter cdata nlink print-func))
 280
 281 (defun push-print-fun-code (vid slot nlink print-func)
 282   (let* ((formatter (esd-print-formatter slot))
 283          (name (slot-definition-name slot))
 284          (user-name (esd-user-name slot))
 285          (xml-user-name (escape-xml-string user-name))
 286          (xml-tag (escape-xml-string user-name))
 287          (value-type (slot-value slot 'value-type))
 288          (cdata (and (in vid :xml :xhtml :xml-link :xhtml-link
 289                              :xml-labels :ie-xml-labels
 290                              :xhtml-link-labels :xml-link-labels :ie-xml-link
 291                              :ie-xml-link-labels)
 292                      (or formatter
 293                          (value-type-is-a-string value-type))
 294                      t))
 295          (hyperlink (esd-hyperlink slot)))
 296
 297     (case vid
 298       (:compact-text
 299        (vector-push-extend
 300         `(write-ho-value x ',name ',value-type ',formatter ,cdata s) print-func))
 301       (:compact-text-labels
 302        (vector-push-extend `(write-string ,user-name s) print-func)
 303        (vector-push-extend '(write-char #\space s) print-func)
 304        (vector-push-extend
 305         `(write-ho-value x ',name ',value-type ',formatter ,cdata s) print-func))
 306       ((or :html :xhtml)
 307        (ppfc-html user-name name value-type formatter cdata print-func))
 308       (:xml
 309        (ppfc-xml xml-tag name value-type formatter cdata print-func))
 310       (:html-labels
 311        (ppfc-html-labels user-name name value-type formatter cdata print-func))
 312       (:xhtml-labels
 313        (ppfc-xhtml-labels xml-user-name user-name name value-type formatter cdata print-func))
 314       ((:display-table :display-table-labels)
 315        (ppfc-display-table user-name name value-type formatter cdata print-func))
 316       (:xml-labels
 317        (ppfc-xml-labels xml-user-name xml-tag name value-type formatter cdata print-func))
 318       ((or :html-link :xhtml-link)
 319        (if hyperlink
 320            (ppfc-html-link name value-type formatter cdata nlink print-func)
 321            (ppfc-html user-name name value-type formatter cdata print-func)))
 322       ((or :xml-link :ie-xml-link)
 323        (if hyperlink
 324            (ppfc-html-link name value-type formatter cdata nlink print-func)
 325            (ppfc-xml xml-tag name value-type formatter cdata print-func)))
 326       (:html-link-labels
 327        (if hyperlink
 328            (ppfc-html-link-labels user-name name value-type formatter cdata nlink
 329                                   print-func)
 330            (ppfc-html-labels user-name name value-type formatter cdata print-func)))
 331       (:xhtml-link-labels
 332        (if hyperlink
 333            (ppfc-html-link-labels xml-user-name name value-type formatter cdata nlink
 334                                   print-func)
 335            (ppfc-xhtml-labels xml-tag user-name name value-type formatter cdata
 336                               print-func)))
 337       ((or :xml-link-labels :ie-xml-link-labels)
 338        (if hyperlink
 339            (ppfc-html-link-labels xml-user-name name value-type formatter cdata nlink
 340                                   print-func)
 341            (ppfc-xml-labels xml-tag user-name name value-type formatter cdata
 342                             print-func))))))
 343
 344
 345 (defun view-has-links-p (view)
 346   (in (id view) :html-link :xhtml-link :xml-link :ie-xml-link
 347       :html-link-labels :xhtml-link-labels :xml-link-labels
 348       :ie-xml-link-labels))
 349
 350 (defun creatable-view-id-p (obj-cl vid)
 351   "Returns T if a view id can be created for this class"
 352   (declare (ignore obj-cl))
 353   (in vid :compact-text :compact-text-labels
 354       :html :html-labels :html-link-labels
 355       :xhtml :xhtml-labels :xhtml-link-labels
 356       :xhtml-link :html-link
 357       :xml :xml-labels :xml-link :ie-xml-link
 358       :xml-link-labels :ie-xml-link-labels
 359       :display-table :display-table-labels :edit-table :edit-table-labels))
 360
 361 (defun initialize-view-by-id (obj-cl view)
 362   "Initialize a view based upon a preset vid"
 363   (unless (creatable-view-id-p obj-cl (id view))
 364     (error "Unable to automatically create view id ~A" (id view)))
 365
 366   (unless (slots view) (setf (slots view) (default-print-slots obj-cl)))
 367
 368   (let ((links '())
 369         (print-func (make-array 20 :fill-pointer 0 :adjustable t)))
 370
 371     (do* ((slots (slots view) (cdr slots))
 372           (slot-name (car slots) (car slots))
 373           (slot (find-slot-by-name obj-cl slot-name)
 374                 (find-slot-by-name obj-cl slot-name)))
 375          ((null slots))
 376       (unless slot
 377         (error "Slot ~A is not found in class ~S" slot-name obj-cl))
 378
 379       (push-print-fun-code (id view) slot (length links) print-func)
 380       (when (> (length slots) 1)
 381         (vector-push-extend '(write-char #\space s) print-func))
 382
 383       (when (and (view-has-links-p view) (esd-hyperlink slot))
 384         (push (slot-definition-name slot) links)))
 385
 386     (vector-push-extend 'x print-func) ;; return object
 387     (setf (obj-data-print-code view) `(lambda (x s links)
 388                                        (declare (ignorable s links))
 389                                        ,@(map 'list #'identity print-func)))
 390     (setf (obj-data-printer view)
 391           (compile nil (eval (obj-data-print-code view))))
 392
 393     (setf (link-slots view) (nreverse links)))
 394
 395   (finalize-view-by-id view)
 396   view)
 397
 398 (defun finalize-view-by-id (view)
 399   (case (id view)
 400     ((or :compact-text :compact-text-labels)
 401      (initialize-text-view view))
 402     ((or :html :html-labels)
 403      (initialize-html-view view))
 404     ((or :xhtml :xhtml-labels)
 405      (initialize-xhtml-view view))
 406     ((or :xml :xml-labels)
 407      (initialize-xml-view view))
 408     ((or :html-link :html-link-labels)
 409      (initialize-html-view view)
 410      (setf (link-href-start view) "a href=")
 411      (setf (link-href-end view) "a")
 412      (setf (link-ampersand view) "&"))
 413     ((or :xhtml-link :xhtml-link-labels)
 414      (initialize-xhtml-view view)
 415      (setf (link-href-start view) "a href=")
 416      (setf (link-href-end view) "a")
 417      (setf (link-ampersand view) "&amp;"))
 418     ((or :display-table :display-table-labels :edit-tables)
 419      (initialize-table-view view)
 420      (when (in (id view) :display-table-labels :edit-table-labels)
 421        (setf (list-start-printer view) #'table-label-list-start-func))
 422      (setf (link-href-start view) "a href=")
 423      (setf (link-href-end view) "a")
 424      (setf (link-ampersand view) "&amp;"))
 425     ((or :xml-link :xml-link-labels)
 426      (initialize-xml-view view)
 427      (setf (link-href-start view)
 428            "xmllink xlink:type=\"simple\" xlink:href=")
 429      (setf (link-href-end view) "xmllink")
 430      (setf (link-ampersand view) "&amp;"))
 431     ((or :ie-xml-link :ie-xml-link-labels)
 432      (initialize-xml-view view)
 433      (setf (link-href-start view) "html:a href=")
 434      (setf (link-href-end view) "html:a")
 435      (setf (link-ampersand view) "&amp;"))))
 436
 437
 438 ;;;; *************************************************************************
 439 ;;;;  View Data Format Section
 440 ;;;; *************************************************************************
 441
 442 (defun class-name-of (obj)
 443   (string-downcase (class-name (class-of obj))))
 444
 445 (defvar +newline-string+ (format nil "~%"))
 446
 447 (defun write-user-name-maybe-plural (obj nitems strm)
 448   (write-string
 449    (if (> nitems 1)
 450        (hyperobject-class-user-name-plural obj)
 451        (hyperobject-class-user-name obj))
 452    strm))
 453
 454 (defun initialize-text-view (view)
 455   (setf (list-start-printer view)
 456         (compile nil
 457                  (eval '(lambda (obj nitems indent strm)
 458                          (declare (ignore indent))
 459                          (write-user-name-maybe-plural obj nitems strm)
 460                          (write-char #\: strm)
 461                          (write-char #\Newline strm)))))
 462   (setf (list-start-indent view) t)
 463   (setf (obj-data-indent view) t)
 464   (setf (obj-data-end-printer view) +newline-string+)
 465   (setf (indenter view) #'indent-spaces))
 466
 467 (defun html-list-start-func (obj nitems indent strm)
 468   (write-string "<div class=\"ho-username\" style=\"margin-left:" strm)
 469   (write-fixnum (+ indent indent) strm)
 470   (write-string "em;\">" strm)
 471   (write-user-name-maybe-plural obj nitems strm)
 472   (write-string "</div>" strm)
 473   (write-char #\newline strm)
 474   (write-string "<ul>" strm)
 475   (write-char #\newline strm))
 476
 477 (defun initialize-html-view (view)
 478   (initialize-text-view view)
 479   (setf (indenter view) #'indent-spaces)
 480   (setf (file-start-str view) (format nil "<html><body>~%"))
 481   (setf (file-end-str view) (format nil "</body><html>~%"))
 482   (setf (list-start-indent view) t)
 483   (setf (list-start-printer view) #'html-list-start-func)
 484   (setf (list-end-printer view) (format nil "</ul>~%"))
 485   (setf (list-end-indent view) t)
 486   (setf (obj-start-indent view) nil)
 487   (setf (obj-start-printer view) "<li>")
 488   (setf (obj-end-indent view)  nil)
 489   (setf (obj-end-printer view)  (format nil "</li>~%"))
 490   (setf (obj-data-end-printer view) nil)
 491   (setf (obj-data-indent view) nil))
 492
 493 (defun xhtml-list-start-func (obj nitems indent strm)
 494   (write-string "<div class=\"ho-username\" style=\"margin-left:" strm)
 495   (write-fixnum (+ indent indent) strm)
 496   (write-string "em;\">" strm)
 497   (write-user-name-maybe-plural obj nitems strm)
 498   (write-string "</div>" strm)
 499   (write-string "<div style=\"margin-left:" strm)
 500   (write-fixnum (+ indent indent) strm)
 501   (write-string "em;\">" strm)
 502   (write-char #\newline strm))
 503
 504 (defun table-list-start-func (obj nitems indent strm)
 505   (write-string "<div class=\"ho-username\" style=\"margin-left:" strm)
 506   (write-fixnum (+ indent indent) strm)
 507   (write-string "em;\">" strm)
 508   (write-user-name-maybe-plural obj nitems strm)
 509   (write-string "</div>" strm)
 510   (write-char #\newline strm)
 511   (write-string "<table style=\"margin-left:" strm)
 512   (write-fixnum (+ indent indent) strm)
 513   (write-string "em;\">" strm)
 514   (write-string "<tbody>" strm)
 515   (write-char #\newline strm))
 516
 517 (defun table-label-list-start-func (obj nitems indent strm)
 518   (write-string "<div class=\"ho-username\" style=\"margin-left:" strm)
 519   (write-fixnum (+ indent indent) strm)
 520   (write-string "em;\">" strm)
 521   (write-user-name-maybe-plural obj nitems strm)
 522   (write-string "</div>" strm)
 523   (write-char #\newline strm)
 524   (write-string "<table style=\"margin-left:" strm)
 525   (write-fixnum (+ indent indent) strm)
 526   (write-string "em;\">" strm)
 527   (write-string "<thead>" strm)
 528   (dolist (slot (default-print-slots (class-of obj)))
 529     (write-string "<th>" strm)
 530     (write-string (write-to-string slot) strm)
 531     (write-string "</th>" strm))
 532   (write-string "</thead>" strm)
 533   (write-char #\newline strm)
 534   (write-string "<tbody>" strm)
 535   (write-char #\newline strm))
 536
 537 (defun html-obj-start (obj indent strm)
 538   (declare (ignore obj indent))
 539   (write-string "<div style=\"margin-left:2em;\">" strm))
 540
 541 (defun initialize-xhtml-view (view)
 542   (initialize-text-view view)
 543   (setf (indenter view) #'indent-spaces)
 544   (setf (file-start-str view) (format nil "<html><body>~%"))
 545   (setf (file-end-str view) (format nil "</body><html>~%"))
 546   (setf (list-start-indent view) nil)
 547   (setf (list-start-printer view) #'xhtml-list-start-func)
 548   (setf (list-end-printer view) (format nil "</div>~%"))
 549   (setf (list-end-indent view) nil)
 550   (setf (obj-start-indent view) nil)
 551   (setf (obj-start-printer view) #'html-obj-start)
 552   (setf (obj-end-printer view) (format nil "</div>~%"))
 553   (setf (obj-data-indent view) nil))
 554
 555 (defun initialize-table-view (view)
 556   (initialize-text-view view)
 557   (setf (indenter view) #'indent-spaces)
 558   (setf (file-start-str view) (format nil "<html><body>~%"))
 559   (setf (file-end-str view) (format nil "</body><html>~%"))
 560   (setf (list-start-indent view) nil)
 561   (setf (list-start-printer view) #'table-list-start-func)
 562   (setf (list-end-printer view) (format nil "</tbody>~%</table>~%"))
 563   (setf (list-end-indent view) nil)
 564   (setf (obj-start-indent view) nil)
 565   (setf (obj-start-printer view) #'html-obj-start)
 566   (setf (obj-start-printer view) (format nil "<tr>"))
 567   (setf (obj-end-printer view) (format nil "</tr>~%"))
 568   (setf (obj-data-indent view) nil))
 569
 570 (defun xmlformat-list-end-func (x strm)
 571   (write-string "</" strm)
 572   (write-string (class-name-of x) strm)
 573   (write-string "list" strm)
 574   (write-string ">" strm)
 575   (write-char #\newline strm))
 576
 577 (defun xmlformat-list-start-func (x nitems indent strm)
 578   (declare (ignore indent))
 579   (write-char #\< strm)
 580   (write-string (class-name-of x) strm)
 581   (write-string "list><title>" strm)
 582   (write-user-name-maybe-plural x nitems strm)
 583   (write-string ":</title>" strm)
 584   (write-char #\newline strm))
 585
 586 (defun initialize-xml-view (view)
 587   (let ((name (string-downcase (symbol-name (object-class view)))))
 588     (setf (file-start-str view) "")     ; (std-xml-header)
 589     (setf (list-start-indent view)  t)
 590     (setf (list-start-printer view) #'xmlformat-list-start-func)
 591     (setf (list-end-indent view) t)
 592     (setf (list-end-printer view) #'xmlformat-list-end-func)
 593     (setf (obj-start-printer view) (format nil "<~(~a~)>" name))
 594     (setf (obj-start-indent view) t)
 595     (setf (obj-end-printer view) (format nil "</~(~a~)>~%" name))
 596 ;;    (setf (subobj-end-printer view) (format nil "</~(~a~)>~%" name))
 597     (setf (subobj-end-printer view) nil)
 598     (setf (subobj-end-indent view) nil)
 599     (setf (obj-data-indent view) nil)))
 600
 601
 602 ;;; File Start and Ends
 603
 604 (defun fmt-file-start (view strm)
 605   (awhen (file-start-str view)
 606          (write-string it strm)))
 607
 608 (defun fmt-file-end (view strm)
 609   (awhen (file-end-str view)
 610          (write-string it strm)))
 611
 612 ;;; List Start and Ends
 613
 614 (defun fmt-list-start (obj view strm indent num-items)
 615   (when (list-start-indent view)
 616     (awhen (indenter view)
 617            (funcall it indent strm)))
 618   (awhen (list-start-printer view)
 619          (if (stringp it)
 620              (write-string it strm)
 621              (funcall it obj num-items indent strm))))
 622
 623 (defun fmt-list-end (obj view strm indent num-items)
 624   (declare (ignore num-items))
 625   (when (list-end-indent view)
 626     (awhen (indenter view)
 627            (funcall it indent strm)))
 628   (awhen (list-end-printer view)
 629          (if (stringp it)
 630              (write-string it strm)
 631              (funcall it obj strm))))
 632
 633 ;;; Object Start and Ends
 634
 635
 636 (defun fmt-obj-start (obj view strm indent)
 637   (when (obj-start-indent view)
 638     (awhen (indenter view)
 639            (funcall it indent strm)))
 640   (awhen (obj-start-printer view)
 641          (if (stringp it)
 642              (write-string it strm)
 643              (funcall it obj indent strm))))
 644
 645 (defun fmt-obj-end (obj view strm indent)
 646   (when (obj-end-indent view)
 647     (awhen (indenter view)
 648            (funcall it indent strm)))
 649   (awhen (obj-end-printer view)
 650          (if (stringp it)
 651              (write-string it strm)
 652              (funcall it obj strm))))
 653
 654 (defun fmt-subobj-start (obj view strm indent)
 655   (when (subobj-start-indent view)
 656     (awhen (indenter view)
 657            (funcall it indent strm)))
 658   (awhen (subobj-start-printer view)
 659          (if (stringp it)
 660              (write-string it strm)
 661              (funcall it obj indent strm))))
 662
 663 (defun fmt-subobj-end (obj view strm indent)
 664   (when (subobj-end-indent view)
 665     (awhen (indenter view)
 666            (funcall it indent strm)))
 667   (awhen (subobj-end-printer view)
 668          (if (stringp it)
 669              (write-string it strm)
 670              (funcall it obj strm))))
 671
 672 ;;; Object Data
 673
 674
 675 (defun make-link-start (view fieldfunc fieldvalue refvars link-printer)
 676   (with-output-to-string (s)
 677     (write-string (link-href-start view) s)
 678     (write-char #\" s)
 679     (let ((link-page (link-page view)))
 680       (cond
 681         ((null link-printer)
 682          (write-string (make-url link-page) s)
 683          (write-string "?func=" s)
 684          (write-simple fieldfunc s)
 685          (write-string (link-ampersand view) s)
 686          (write-string "key=" s)
 687          (write-simple fieldvalue s)
 688          (dolist (var refvars)
 689            (write-string (link-ampersand view) s)
 690            (write-simple (car var) s)
 691            (write-char #\= s)
 692            (write-simple (cdr var) s)))
 693         (link-printer
 694          (funcall link-printer link-page fieldfunc fieldvalue refvars s))))
 695     (write-char #\" s)))
 696
 697 (defun make-link-end (obj view fieldname)
 698   (declare (ignore obj fieldname))
 699   (link-href-end view))
 700
 701 (defun fmt-obj-data (obj view strm indent refvars link-printer)
 702   (awhen (obj-data-start-printer view)
 703          (if (stringp it)
 704              (write-string it strm)
 705              (funcall it obj strm)))
 706   (when (obj-data-indent view)
 707     (awhen (indenter view)
 708            (funcall it indent strm)))
 709   (if (link-slots view)
 710       (fmt-obj-data-with-link obj view strm refvars link-printer)
 711       (fmt-obj-data-plain obj view strm))
 712   (awhen (obj-data-end-printer view)
 713          (if (stringp it)
 714              (write-string it strm)
 715              (funcall it obj strm))))
 716
 717 (defun fmt-obj-data-plain (obj view strm)
 718   (awhen (obj-data-printer view)
 719          (funcall it obj strm nil)))
 720
 721 (defun fmt-obj-data-with-link (obj view strm refvars link-printer)
 722   (let ((refvalues '()))
 723     (declare (dynamic-extent refvalues))
 724     ;; make list of hyperlink link fields for printing to refstr template
 725     (dolist (name (link-slots view))
 726       (awhen (find name (hyperobject-class-hyperlinks obj) :key #'name)
 727              (push (make-link-start view (lookup it) (slot-value obj name)
 728                                     (append (link-parameters it) refvars)
 729                                     link-printer)
 730                    refvalues)
 731              (push (make-link-end obj view name) refvalues)))
 732     (funcall (obj-data-printer view) obj strm (nreverse refvalues))))
 733
 734 (defun obj-data (obj view)
 735   "Returns the objects data as a string. Used by common-graphics outline function"
 736   (with-output-to-string (s) (fmt-obj-data-plain obj view s)))
 737
 738 ;;; Display method for objects
 739
 740
 741 (defun load-all-subobjects (objs)
 742   "Load all subobjects if they have not already been loaded."
 743   (dolist (obj (mklist objs))
 744     (dolist (subobj (hyperobject-class-subobjects obj))
 745       (awhen (slot-value obj (name-slot subobj))
 746              (load-all-subobjects it))))
 747   objs)
 748
 749 (defun view-subobjects (obj strm &optional vid (indent 0) filter
 750                         subobjects refvars link-printer)
 751   (when (hyperobject-class-subobjects obj)
 752     (dolist (subobj (hyperobject-class-subobjects obj))
 753       (aif (slot-value obj (name-slot subobj))
 754            (view-hyperobject
 755             it (get-view-id (car (mklist it)) vid)
 756             strm vid (1+ indent) filter subobjects refvars
 757             link-printer)))))
 758
 759
 760 (defun view-hyperobject (objs view strm &optional vid (indent 0) filter
 761                          subobjects refvars link-printer)
 762   "Display a single or list of hyperobject-class instances and their subobjects"
 763   (let-when (objlist (mklist objs))
 764     (let ((nobjs (length objlist))
 765           (*print-pretty* nil)
 766           (*print-circle* nil)
 767           (*print-escape* nil)
 768           (*print-readably* nil)
 769           (*print-length* nil)
 770           (*print-level* nil))
 771       (fmt-list-start (car objlist) view strm indent nobjs)
 772       (dolist (obj objlist)
 773         (awhen (printer view)
 774                (funcall it obj strm))
 775         (unless (and filter (not (funcall filter obj)))
 776           (fmt-obj-start obj view strm indent)
 777           (fmt-obj-data obj view strm (1+ indent) refvars link-printer)
 778           (fmt-obj-end obj view strm indent)
 779           (if subobjects
 780               (progn
 781                 (fmt-subobj-start obj view strm indent)
 782                 (view-subobjects obj strm vid indent filter subobjects
 783                                  refvars link-printer)
 784                 (fmt-subobj-end obj view strm indent))
 785             (fmt-subobj-start obj view strm indent))))
 786       (fmt-list-end (car objlist) view strm indent nobjs)))
 787   objs)
 788
 789
 790 (defun view (objs &key (stream *standard-output*) vid view
 791              filter subobjects refvars file-wrapper link-printer)
 792   "EXPORTED Function: prints hyperobject-class objects. Calls view-hyperobject"
 793   (let-when (objlist (mklist objs))
 794     (unless view
 795       (setq view (get-view-id (car objlist) vid)))
 796     (when file-wrapper
 797       (fmt-file-start view stream))
 798     (view-hyperobject objlist view stream vid 0 filter subobjects refvars
 799                       link-printer)
 800     (when file-wrapper
 801       (fmt-file-end view stream)))
 802   objs)
 803
 804
 805 ;;; Misc formatting
 806
 807 (defun fmt-comma-integer (i)
 808   (format nil "~:d" i))