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