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.6 2002/12/03 00:12:55 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 ;;;; *************************************************************************
  23 ;;;;  Metaclass Intialization
  24 ;;;; *************************************************************************
  25
  26 (defun finalize-hyperlinks (cl)
  27   (let ((hyperlinks '()))
  28     (dolist (esd (class-slots cl))
  29       (awhen (slot-value esd 'hyperlink)
  30         (push
  31          (make-instance 'hyperlink
  32                         :name (slot-definition-name esd)
  33                         :lookup it
  34                         :link-parameters (slot-value esd 'hyperlink-parameters))
  35          hyperlinks)))
  36     (setf (slot-value cl 'hyperlinks) hyperlinks)))
  37
  38
  39 (defun finalize-views (cl)
  40   "Calculate all view slots for a hyperobject class"
  41   (let ((fmtstr-text "")
  42         (fmtstr-html "")
  43         (fmtstr-xml "")
  44         (fmtstr-text-labels "")
  45         (fmtstr-html-labels "")
  46         (fmtstr-xml-labels "")
  47         (fmtstr-html-ref "")
  48         (fmtstr-xml-ref "")
  49         (fmtstr-html-ref-labels "")
  50         (fmtstr-xml-ref-labels "")
  51         (first-field t)
  52         (value-func '())
  53         (xmlvalue-func '())
  54         (classname (class-name cl))
  55         (package (symbol-package (class-name cl)))
  56         (hyperlinks nil))
  57     (declare (ignore classname))
  58     (check-type (slot-value cl 'print-slots) list)
  59     (dolist (slot-name (slot-value cl 'print-slots))
  60       (let ((slot (find-slot-by-name cl slot-name)))
  61         (unless slot
  62           (error "Slot ~A is not found in class ~S" slot-name cl))
  63         (let ((name (slot-definition-name slot))
  64               (namestr (symbol-name (slot-definition-name slot)))
  65               (namestr-lower (string-downcase (symbol-name (slot-definition-name slot))))
  66               (type (slot-value slot 'ho-type))
  67               (print-formatter (slot-value slot 'print-formatter))
  68               (value-fmt "~a")
  69               (plain-value-func nil)
  70               html-str xml-str html-label-str xml-label-str)
  71
  72           (when (or (eql type :integer) (eql type :fixnum))
  73             (setq value-fmt "~d"))
  74
  75           (when (eql type :boolean)
  76             (setq value-fmt "~a"))
  77
  78           (if first-field
  79               (setq first-field nil)
  80               (progn
  81                 (string-append fmtstr-text " ")
  82                 (string-append fmtstr-html " ")
  83                 (string-append fmtstr-xml " ")
  84                 (string-append fmtstr-text-labels " ")
  85                 (string-append fmtstr-html-labels " ")
  86                 (string-append fmtstr-xml-labels " ")
  87                 (string-append fmtstr-html-ref " ")
  88                 (string-append fmtstr-xml-ref " ")
  89                 (string-append fmtstr-html-ref-labels " ")
  90                 (string-append fmtstr-xml-ref-labels " ")))
  91
  92           (setq html-str (concatenate 'string "<span class=\"" namestr-lower "\">" value-fmt "</span>"))
  93           (setq xml-str (concatenate 'string "<" namestr-lower ">" value-fmt "</" namestr-lower ">"))
  94           (setq html-label-str (concatenate 'string "<span class=\"label\">" namestr-lower "</span> <span class=\"" namestr-lower "\">" value-fmt "</span>"))
  95           (setq xml-label-str (concatenate 'string "<label>" namestr-lower "</label> <" namestr-lower ">" value-fmt "</" namestr-lower ">"))
  96
  97           (string-append fmtstr-text value-fmt)
  98           (string-append fmtstr-html html-str)
  99           (string-append fmtstr-xml xml-str)
 100           (string-append fmtstr-text-labels namestr-lower " " value-fmt)
 101           (string-append fmtstr-html-labels html-label-str)
 102           (string-append fmtstr-xml-labels xml-label-str)
 103
 104           (if (slot-value slot 'hyperlink)
 105               (progn
 106                 (string-append fmtstr-html-ref "<~~a>" value-fmt "</~~a>")
 107                 (string-append fmtstr-xml-ref "<~~a>" value-fmt "</~~a>")
 108                 (string-append fmtstr-html-ref-labels "<span class=\"label\">" namestr-lower "</span> <~~a>" value-fmt "</~~a>")
 109                 (string-append fmtstr-xml-ref-labels "<label>" namestr-lower "</label> <~~a>" value-fmt "</~~a>")
 110                 (push (make-instance 'hyperlink :name name
 111                                      :lookup (slot-value slot 'hyperlink))
 112                       hyperlinks))
 113               (progn
 114                 (string-append fmtstr-html-ref html-str)
 115                 (string-append fmtstr-xml-ref xml-str)
 116                 (string-append fmtstr-html-ref-labels html-label-str)
 117                 (string-append fmtstr-xml-ref-labels xml-label-str)))
 118
 119           (if print-formatter
 120               (setq plain-value-func
 121                     (list `(,print-formatter (slot-value x ',(intern namestr package)))))
 122               (setq plain-value-func
 123                     (list `(slot-value x ',(intern namestr package)))))
 124           (setq value-func (append value-func plain-value-func))
 125
 126           (if (eql type :cdata)
 127               (setq xmlvalue-func (append xmlvalue-func (list `(xml-cdata ,@plain-value-func))))
 128               (setq xmlvalue-func (append xmlvalue-func plain-value-func)))
 129           )))
 130
 131     (setf (slot-value cl 'hyperlinks) hyperlinks)
 132
 133     (if value-func
 134         (setq value-func `(lambda (x) (values ,@value-func)))
 135         (setq value-func `(lambda () (values))))
 136     (setq value-func (compile nil (eval value-func)))
 137
 138     (if xmlvalue-func
 139         (setq xmlvalue-func `(lambda (x) (values ,@xmlvalue-func)))
 140         (setq xmlvalue-func `(lambda () (values))))
 141     (setq xmlvalue-func (compile nil (eval xmlvalue-func)))
 142
 143     (setf (slot-value cl 'fmtstr-text) fmtstr-text)
 144     (setf (slot-value cl 'fmtstr-html) fmtstr-html)
 145     (setf (slot-value cl 'fmtstr-xml) fmtstr-xml)
 146     (setf (slot-value cl 'fmtstr-text-labels) fmtstr-text-labels)
 147     (setf (slot-value cl 'fmtstr-html-labels) fmtstr-html-labels)
 148     (setf (slot-value cl 'fmtstr-xml-labels) fmtstr-xml-labels)
 149     (setf (slot-value cl 'fmtstr-html-ref) fmtstr-html-ref)
 150     (setf (slot-value cl 'fmtstr-xml-ref) fmtstr-xml-ref)
 151     (setf (slot-value cl 'fmtstr-html-ref-labels) fmtstr-html-ref-labels)
 152     (setf (slot-value cl 'fmtstr-xml-ref-labels) fmtstr-xml-ref-labels)
 153     (setf (slot-value cl 'value-func) value-func)
 154     (setf (slot-value cl 'xmlvalue-func) xmlvalue-func))
 155   (values))
 156
 157
 158 ;;;; *************************************************************************
 159 ;;;;  View Data Format Section
 160 ;;;; *************************************************************************
 161
 162 (defparameter *default-textformat* nil)
 163 (defparameter *default-htmlformat* nil)
 164 (defparameter *default-htmlrefformat* nil)
 165 (defparameter *default-xhtmlformat* nil)
 166 (defparameter *default-xhtmlrefformat* nil)
 167 (defparameter *default-xmlformat* nil)
 168 (defparameter *default-xmlrefformat* nil)
 169 (defparameter *default-ie-xmlrefformat* nil)
 170 (defparameter *default-nullformat* nil)
 171 (defparameter *default-init-format?* nil)
 172
 173 (defun make-format-instance (fmt)
 174   (unless *default-init-format?*
 175     (setq *default-textformat* (make-instance 'textformat))
 176     (setq *default-htmlformat* (make-instance 'htmlformat))
 177     (setq *default-htmlrefformat* (make-instance 'htmlrefformat))
 178     (setq *default-xhtmlformat* (make-instance 'xhtmlformat))
 179     (setq *default-xhtmlrefformat* (make-instance 'xhtmlrefformat))
 180     (setq *default-xmlformat* (make-instance 'xmlformat))
 181     (setq *default-xmlrefformat* (make-instance 'xmlrefformat))
 182     (setq *default-ie-xmlrefformat* (make-instance 'ie-xmlrefformat))
 183     (setq *default-nullformat* (make-instance 'nullformat))
 184     (setq *default-init-format?* t))
 185
 186   (case fmt
 187       (:text *default-textformat*)
 188       (:html *default-htmlformat*)
 189       (:htmlref *default-htmlrefformat*)
 190       (:xhtml  *default-xhtmlformat*)
 191       (:xhtmlref *default-xhtmlrefformat*)
 192       (:xml  *default-xmlformat*)
 193       (:xmlref *default-xmlrefformat*)
 194       (:ie-xmlref *default-ie-xmlrefformat*)
 195       (:null *default-nullformat*)
 196       (otherwise *default-textformat*)))
 197
 198 ;;;; Output format classes for print hyperobject-classes
 199
 200 (defclass dataformat ()
 201   ((file-start-str :type string :initarg :file-start-str :reader file-start-str)
 202    (file-end-str :type string :initarg :file-end-str :reader file-end-str)
 203    (list-start-fmtstr :type string :initarg :list-start-fmtstr :reader list-start-fmtstr)
 204    (list-start-value-func :type function :initarg :list-start-value-func :reader list-start-value-func)
 205    (list-start-indent :initarg :list-start-indent :reader list-start-indent)
 206    (list-end-fmtstr :type string :initarg :list-end-fmtstr :reader list-end-fmtstr)
 207    (list-end-value-func :type function :initarg :list-end-value-func :reader list-end-value-func)
 208    (list-end-indent :initarg :list-end-indent :reader list-end-indent)
 209    (obj-start-fmtstr :type string :initarg :obj-start-fmtstr :reader obj-start-fmtstr)
 210    (obj-start-value-func :initarg :obj-start-value-func :reader obj-start-value-func)
 211    (obj-start-indent :initarg :obj-start-indent :reader obj-start-indent)
 212    (obj-end-fmtstr :type string :initarg :obj-end-fmtstr :reader obj-end-fmtstr)
 213    (obj-end-value-func :initarg :obj-end-value-func :reader obj-end-value-func)
 214    (obj-end-indent :initarg :obj-end-indent :reader obj-end-indent)
 215    (obj-data-indent :initarg :obj-data-indent :reader obj-data-indent)
 216    (obj-data-fmtstr :initarg :obj-data-fmtstr :reader  obj-data-fmtstr)
 217    (obj-data-fmtstr-labels :initarg :obj-data-fmtstr-labels :reader  obj-data-fmtstr-labels)
 218    (obj-data-end-fmtstr :initarg :obj-data-end-fmtstr :reader obj-data-end-fmtstr)
 219    (obj-data-value-func :initarg :obj-data-value-func :reader obj-data-value-func)
 220    (link-ref :initarg :link-ref :reader link-ref))
 221   (:default-initargs :file-start-str nil :file-end-str nil :list-start-fmtstr nil :list-start-value-func nil
 222                      :list-start-indent nil :list-end-fmtstr nil :list-end-value-func nil :list-end-indent nil
 223                      :obj-start-fmtstr nil :obj-start-value-func nil :obj-start-indent nil
 224                      :obj-end-fmtstr nil :obj-end-value-func nil :obj-end-indent nil
 225                      :obj-data-indent nil :obj-data-fmtstr nil :obj-data-fmtstr-labels nil :obj-data-end-fmtstr nil
 226                      :obj-data-value-func nil :link-ref nil)
 227   (:documentation "Parent for all dataformat objects"))
 228
 229 (defclass binaryformat (dataformat)
 230   ())
 231
 232 (defclass nullformat (dataformat)
 233   ())
 234
 235 (defun text-list-start-value-func (obj nitems)
 236   (values (hyperobject-class-title obj) nitems))
 237
 238 (defclass textformat (dataformat)
 239   ()
 240   (:default-initargs :list-start-fmtstr "~a~P:~%"
 241     :list-start-value-func #'text-list-start-value-func
 242     :list-start-indent t
 243     :obj-data-indent t
 244     :obj-data-fmtstr #'hyperobject-class-fmtstr-text
 245     :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-text-labels
 246     :obj-data-end-fmtstr "~%"
 247     :obj-data-value-func #'hyperobject-class-value-func))
 248
 249
 250 (defun class-name-of (obj)
 251   (string-downcase (class-name (class-of obj))))
 252
 253 (defun htmlformat-list-start-value-func (x nitems)
 254   (values (hyperobject-class-title x) nitems (class-name-of x)))
 255
 256 (defclass htmlformat (textformat)
 257   ()
 258   (:default-initargs :file-start-str "<html><body>~%"
 259     :file-end-str "</body><html>~%"
 260     :list-start-indent t
 261     :list-start-fmtstr "<p><b>~a~p:</b></p><div class=\"~A\"><ul>~%"
 262     :list-start-value-func #'htmlformat-list-start-value-func
 263     :list-end-fmtstr "</ul></div>~%"
 264     :list-end-indent t
 265     :list-end-value-func #'identity
 266     :obj-start-indent t
 267     :obj-start-fmtstr "<li>"
 268     :obj-start-value-func #'identity
 269     :obj-end-indent  t
 270     :obj-end-fmtstr  "</li>~%"
 271     :obj-end-value-func #'identity
 272     :obj-data-indent t
 273     :obj-data-fmtstr #'hyperobject-class-fmtstr-html-labels
 274     :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-html-labels
 275     :obj-data-value-func #'hyperobject-class-value-func))
 276
 277 (defclass xhtmlformat (textformat)
 278   ()
 279   (:default-initargs :file-start-str "<html><body>~%"
 280     :file-end-str "</body><html>~%"
 281     :list-start-indent t
 282     :list-start-fmtstr "<p><b>~a~p:</b></p><div class=\"~A\"><ul>~%"
 283     :list-start-value-func #'htmlformat-list-start-value-func
 284     :list-end-fmtstr "</ul></div>~%"
 285     :list-end-indent t
 286     :list-end-value-func #'identity
 287     :obj-start-indent t
 288     :obj-start-fmtstr "<li>"
 289     :obj-start-value-func #'identity
 290     :obj-end-indent  t
 291     :obj-end-fmtstr  "</li>~%"
 292     :obj-end-value-func #'identity
 293     :obj-data-indent t
 294     :obj-data-fmtstr #'hyperobject-class-fmtstr-html-labels
 295     :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-html-labels
 296     :obj-data-value-func #'hyperobject-class-xmlvalue-func))
 297
 298
 299 (defun xmlformat-list-end-value-func (x)
 300   (format nil "~alist" (class-name-of x)))
 301
 302 (defun xmlformat-list-start-value-func (x nitems)
 303   (values (format nil "~alist" (class-name-of x)) (hyperobject-class-title x) nitems))
 304
 305 (defclass xmlformat (textformat)
 306   ()
 307   (:default-initargs :file-start-str "" ; (std-xml-header)
 308     :list-start-indent  t
 309     :list-start-fmtstr "<~a><title>~a~p:</title> ~%"
 310     :list-start-value-func #'xmlformat-list-start-value-func
 311     :list-end-indent  t
 312     :list-end-fmtstr "</~a>~%"
 313     :list-end-value-func #'xmlformat-list-end-value-func
 314     :obj-start-fmtstr "<~a>"
 315     :obj-start-value-func #'class-name-of
 316     :obj-start-indent t
 317     :obj-end-fmtstr "</~a>~%"
 318     :obj-end-value-func #'class-name-of
 319     :obj-end-indent nil
 320     :obj-data-indent nil
 321     :obj-data-fmtstr #'hyperobject-class-fmtstr-xml
 322     :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-xml-labels
 323     :obj-data-value-func #'hyperobject-class-xmlvalue-func))
 324
 325 (defclass link-ref ()
 326   ((fmtstr :type function :initarg :fmtstr :accessor fmtstr)
 327    (fmtstr-labels :type function :initarg :fmtstr-labels :accessor fmtstr-labels)
 328    (page-name :type string :initarg :page-name :accessor page-name)
 329    (href-head :type string :initarg :href-head :accessor href-head)
 330    (href-end :type string :initarg :href-end :accessor href-end)
 331    (ampersand :type string :initarg :ampersand :accessor ampersand))
 332   (:default-initargs :fmtstr nil
 333     :fmtstr-labels nil
 334     :page-name "disp-func1"
 335     :href-head nil :href-end nil :ampersand nil)
 336   (:documentation "Formatting for a linked hyperlink"))
 337
 338 (defclass html-link-ref (link-ref)
 339   ()
 340   (:default-initargs :fmtstr #'hyperobject-class-fmtstr-html-ref
 341     :fmtstr-labels #'hyperobject-class-fmtstr-html-ref-labels
 342     :href-head "a href="
 343     :href-end "a"
 344     :ampersand "&"))
 345
 346 (defclass xhtml-link-ref (link-ref)
 347   ()
 348   (:default-initargs :fmtstr #'hyperobject-class-fmtstr-html-ref
 349     :fmtstr-labels #'hyperobject-class-fmtstr-html-ref-labels
 350     :href-head "a href="
 351     :href-end "a"
 352     :ampersand "&amp;"))
 353
 354 (defclass xml-link-ref (link-ref)
 355   ()
 356   (:default-initargs :fmtstr #'hyperobject-class-fmtstr-xml-ref
 357                      :fmtstr-labels #'hyperobject-class-fmtstr-xml-ref-labels
 358                      :href-head "xmllink xlink:type=\"simple\" xlink:href="
 359                      :href-end "xmllink"
 360                      :ampersand "&amp;")
 361   (:documentation "Mozilla's and W3's idea of a link with XML"))
 362
 363 (defclass ie-xml-link-ref (xml-link-ref)
 364   ()
 365   (:default-initargs :href-head "html:a href="
 366                      :href-end "html:a" )
 367   (:documentation "Internet Explorer's idea of a link with XML"))
 368
 369
 370 (defclass htmlrefformat (htmlformat)
 371   ()
 372   (:default-initargs :link-ref (make-instance 'html-link-ref)))
 373
 374 (defclass xhtmlrefformat (xhtmlformat)
 375   ()
 376   (:default-initargs :link-ref (make-instance 'xhtml-link-ref)))
 377
 378 (defclass xmlrefformat (xmlformat)
 379   ()
 380   (:default-initargs :link-ref (make-instance 'xml-link-ref)))
 381
 382 (defclass ie-xmlrefformat (xmlformat)
 383   ()
 384   (:default-initargs :link-ref (make-instance 'ie-xml-link-ref)))
 385
 386
 387 ;;; File Start and Ends
 388
 389 (defgeneric fmt-file-start (fmt s))
 390 (defmethod fmt-file-start ((fmt dataformat) (s stream)))
 391
 392 (defmethod fmt-file-start ((fmt textformat) (s stream))
 393   (aif (file-start-str fmt)
 394       (format s it)))
 395
 396 (defgeneric fmt-file-end (fmt s))
 397 (defmethod fmt-file-end ((fmt textformat) (s stream))
 398   (aif (file-end-str fmt)
 399           (format s it)))
 400
 401 ;;; List Start and Ends
 402
 403 (defgeneric fmt-list-start (obj fmt s &optional indent num-items))
 404 (defmethod fmt-list-start (x (fmt textformat) (s stream) &optional (indent 0) (num-items 1))
 405   (if (list-start-indent fmt)
 406       (indent-spaces indent s))
 407   (aif (list-start-fmtstr fmt)
 408           (apply #'format s it
 409                  (multiple-value-list
 410                   (funcall (list-start-value-func fmt) x num-items)))))
 411
 412 (defgeneric fmt-list-end (obj fmt s &optional indent num-items))
 413 (defmethod fmt-list-end (x (fmt textformat) (s stream) &optional (indent 0) (num-items 1))
 414   (declare (ignore num-items))
 415   (if (list-end-indent fmt)
 416       (indent-spaces indent s))
 417   (aif (list-end-fmtstr fmt)
 418           (apply #'format s it
 419                  (multiple-value-list
 420                   (funcall (list-end-value-func fmt) x)))))
 421
 422 ;;; Object Start and Ends
 423
 424 (defgeneric fmt-obj-start (obj fmt s &optional indent))
 425 (defmethod fmt-obj-start (x (fmt textformat) (s stream) &optional (indent 0))
 426   (if (obj-start-indent fmt)
 427       (indent-spaces indent s))
 428   (aif (obj-start-fmtstr fmt)
 429           (apply #'format s it
 430                  (multiple-value-list
 431                   (funcall (obj-start-value-func fmt) x)))))
 432
 433 (defgeneric fmt-obj-end (obj fmt s &optional indent))
 434 (defmethod fmt-obj-end (x (fmt textformat) (s stream) &optional (indent 0))
 435   (if (obj-end-indent fmt)
 436       (indent-spaces indent s))
 437   (aif (obj-end-fmtstr fmt)
 438           (apply #'format s it
 439                  (multiple-value-list
 440                   (funcall (obj-end-value-func fmt) x)))))
 441
 442 ;;; Object Data
 443
 444 (defgeneric make-link-start (obj ref fieldname fieldfunc fieldvalue refvars))
 445 (defmethod make-link-start (obj (ref link-ref) fieldname fieldfunc fieldvalue refvars)
 446   (declare (ignore obj fieldname))
 447   (format nil "~a\"~a?func=~a~akey=~a~a\""
 448           (href-head ref) (make-url (page-name ref)) fieldfunc
 449           (ampersand ref) fieldvalue
 450           (if refvars
 451               (let ((varstr ""))
 452                 (dolist (var refvars)
 453                   (string-append varstr (format nil "~a~a=~a"
 454                                                 (ampersand ref) (car var) (cadr var))))
 455                 varstr)
 456             "")))
 457
 458 (defgeneric make-link-end (obj ref fieldname))
 459 (defmethod make-link-end (obj (ref link-ref) fieldname)
 460   (declare (ignore obj fieldname))
 461   (format nil "~a" (href-end ref))
 462   )
 463
 464 (defgeneric fmt-obj-data (obj fmt s &optional indent label refvars))
 465 (defmethod fmt-obj-data (x (fmt textformat) s
 466                          &optional (indent 0) (label nil) (refvars nil))
 467   (if (obj-data-indent fmt)
 468       (indent-spaces indent s))
 469   (if (link-ref fmt)
 470       (fmt-obj-data-with-ref x fmt s label refvars)
 471     (fmt-obj-data-plain x fmt s label))
 472   (aif (obj-data-end-fmtstr fmt)
 473        (format s it)))
 474
 475 (defgeneric fmt-obj-data-plain (obj fmt s label))
 476 (defmethod fmt-obj-data-plain (x (fmt textformat) s label)
 477   (if label
 478       (apply #'format s
 479              (funcall (obj-data-fmtstr-labels fmt) x)
 480              (multiple-value-list
 481               (funcall (funcall (obj-data-value-func fmt) x) x)))
 482     (apply #'format s (funcall (obj-data-fmtstr fmt) x)
 483            (multiple-value-list
 484             (funcall (funcall (obj-data-value-func fmt) x) x)))))
 485
 486 (defgeneric fmt-obj-data-with-ref (obj fmt s label refvars))
 487 (defmethod fmt-obj-data-with-ref (x (fmt textformat) s label refvars)
 488   (let ((refstr (make-ref-data-str x fmt label))
 489         (refvalues nil)
 490         (field-values
 491          (multiple-value-list
 492           (funcall (funcall (obj-data-value-func fmt) x) x))))
 493
 494     ;; make list of hyperlink link fields for printing to refstr template
 495     (dolist (ref (hyperobject-class-hyperlinks x))
 496       (let ((link-start
 497              (make-link-start x (link-ref fmt) (name ref) (lookup ref)
 498                               (nth (position (name ref)
 499                                              (hyperobject-class-fields x)
 500                                              :key #'(lambda (x)
 501                                                       (slot-definition-name x)))
 502                                    field-values)
 503                               (append (link-parameters ref) refvars)))
 504             (link-end (make-link-end x (link-ref fmt) (name ref))))
 505         (push link-start refvalues)
 506         (push link-end refvalues)))
 507     (setq refvalues (nreverse refvalues))
 508
 509     (apply #'format s refstr refvalues)))
 510
 511 (defgeneric obj-data (obj))
 512 (defmethod obj-data (x)
 513   "Returns the objects data as a string. Used by common-graphics outline function"
 514   (let ((fmt (make-format-instance :text)))
 515     (apply #'format nil (funcall (obj-data-fmtstr fmt) x)
 516            (multiple-value-list
 517             (funcall (funcall (obj-data-value-func fmt) x) x)))))
 518
 519 (defgeneric make-ref-data-str (obj fmt &optional label))
 520 (defmethod make-ref-data-str (x (fmt textformat) &optional (label nil))
 521   "Return fmt string for that contains ~a slots for hyperlink link start and end"
 522   (unless (link-ref fmt)
 523     (error "fmt does not contain a link-ref"))
 524   (let ((refstr
 525          (if label
 526              (apply #'format nil (funcall (fmtstr-labels (link-ref fmt)) x)
 527                     (multiple-value-list
 528                       (funcall (funcall (obj-data-value-func fmt) x) x)))
 529            (apply #'format nil (funcall (fmtstr (link-ref fmt)) x)
 530                   (multiple-value-list (funcall (funcall (obj-data-value-func fmt) x) x))))))
 531     refstr))
 532
 533 ;;; Display method for objects
 534
 535
 536 (defgeneric load-all-subobjects (objs))
 537 (defmethod load-all-subobjects (objs)
 538   "Load all subobjects if they have not already been loaded."
 539   (when objs
 540     (let ((objlist (mklist objs)))
 541       (dolist (obj objlist)
 542         (awhen (hyperobject-class-subobjects obj)  ;; access list of functions
 543           (dolist (child-obj it)   ;; for each child function
 544             (awhen (funcall (reader child-obj) obj)
 545               (load-all-subobjects it))))))
 546     objs))
 547
 548 (defgeneric view-hyperobject (objs fmt strm
 549                                   &optional label english-only-function
 550                                   indent subobjects refvars))
 551
 552 (defmethod view-hyperobject (objs (fmt dataformat) (strm stream)
 553                                  &optional (label nil) (indent 0)
 554                                  (english-only-function nil)
 555                                  (subobjects nil) (refvars nil))
 556 "Display a single or list of hyperobject-class instances and their subobjects"
 557   (when objs
 558     (setq objs (mklist objs))
 559     (let ((nobjs (length objs)))
 560       (fmt-list-start (car objs) fmt strm indent nobjs)
 561       (dolist (obj objs)
 562         (unless (and english-only-function
 563                   (multiple-value-bind (eng term) (funcall english-only-function obj)
 564                     (and term (not eng))))
 565           (fmt-obj-start obj fmt strm indent)
 566           (fmt-obj-data obj fmt strm (1+ indent) label refvars)
 567           (if subobjects
 568               (awhen (hyperobject-class-subobjects obj)  ;; access list of functions
 569                         (dolist (child-obj it)   ;; for each child function
 570                           (awhen (funcall (reader child-obj) obj) ;; access set of child objects
 571                                     (view-hyperobject it fmt strm label
 572                                                      (1+ indent) english-only-function
 573                                                      subobjects refvars)))))
 574           (fmt-obj-end obj fmt strm indent)))
 575       (fmt-list-end (car objs) fmt strm indent nobjs))
 576     t))
 577
 578
 579 (defun view (objs &key (os *standard-output*) (format :text)
 580                       (label nil) (english-only-function nil)
 581                       (subobjects nil) (file-wrapper t) (refvars nil))
 582   "EXPORTED Function: prints hyperobject-class objects. Simplies call to view-hyperobject"
 583   (let ((fmt (make-format-instance format)))
 584     (if file-wrapper
 585         (fmt-file-start fmt os))
 586     (when objs
 587       (view-hyperobject objs fmt os label 0 english-only-function subobjects refvars))
 588     (if file-wrapper
 589         (fmt-file-end fmt os)))
 590   objs)
 591
 592
 593 ;;; Misc formatting
 594
 595 (defun fmt-comma-integer (i)
 596   (format nil "~:d" i))
 597