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