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