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