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