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.11 2002/12/09 10:39:38 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
 222                      :list-start-fmtstr nil :list-start-value-func nil
 223                      :list-start-indent nil :list-end-fmtstr nil
 224                      :list-end-value-func nil :list-end-indent nil
 225                      :obj-start-fmtstr nil :obj-start-value-func nil
 226                      :obj-start-indent nil :obj-end-fmtstr nil
 227                      :obj-end-value-func nil :obj-end-indent nil
 228                      :obj-data-indent nil :obj-data-fmtstr nil
 229                      :obj-data-fmtstr-labels nil :obj-data-end-fmtstr nil
 230                      :obj-data-value-func nil :link-ref nil)
 231   (:documentation "Parent for all dataformat objects"))
 232
 233 (defclass binaryformat (dataformat)
 234   ())
 235
 236 (defclass nullformat (dataformat)
 237   ())
 238
 239 (defun text-list-start-value-func (obj nitems)
 240   (values (hyperobject-class-user-name obj) nitems))
 241
 242 (defclass textformat (dataformat)
 243   ()
 244   (:default-initargs :list-start-fmtstr "~a~P:~%"
 245     :list-start-value-func #'text-list-start-value-func
 246     :list-start-indent t
 247     :obj-data-indent t
 248     :obj-data-fmtstr #'hyperobject-class-fmtstr-text
 249     :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-text-labels
 250     :obj-data-end-fmtstr "~%"
 251     :obj-data-value-func #'hyperobject-class-value-func))
 252
 253
 254 (defun class-name-of (obj)
 255   (string-downcase (class-name (class-of obj))))
 256
 257 (defun htmlformat-list-start-value-func (x nitems)
 258   (values (hyperobject-class-user-name x) nitems (class-name-of x)))
 259
 260 (defclass htmlformat (textformat)
 261   ()
 262   (:default-initargs :file-start-str "<html><body>~%"
 263     :file-end-str "</body><html>~%"
 264     :list-start-indent t
 265     :list-start-fmtstr "<p><b>~a~p:</b></p><div class=\"~A\"><ul>~%"
 266     :list-start-value-func #'htmlformat-list-start-value-func
 267     :list-end-fmtstr "</ul></div>~%"
 268     :list-end-indent t
 269     :list-end-value-func #'identity
 270     :obj-start-indent t
 271     :obj-start-fmtstr "<li>"
 272     :obj-start-value-func #'identity
 273     :obj-end-indent  t
 274     :obj-end-fmtstr  "</li>~%"
 275     :obj-end-value-func #'identity
 276     :obj-data-indent t
 277     :obj-data-fmtstr #'hyperobject-class-fmtstr-html-labels
 278     :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-html-labels
 279     :obj-data-value-func #'hyperobject-class-value-func))
 280
 281 (defclass xhtmlformat (textformat)
 282   ()
 283   (:default-initargs :file-start-str "<html><body>~%"
 284     :file-end-str "</body><html>~%"
 285     :list-start-indent t
 286     :list-start-fmtstr "<p><b>~a~p:</b></p><div class=\"~A\"><ul>~%"
 287     :list-start-value-func #'htmlformat-list-start-value-func
 288     :list-end-fmtstr "</ul></div>~%"
 289     :list-end-indent t
 290     :list-end-value-func #'identity
 291     :obj-start-indent t
 292     :obj-start-fmtstr "<li>"
 293     :obj-start-value-func #'identity
 294     :obj-end-indent  t
 295     :obj-end-fmtstr  "</li>~%"
 296     :obj-end-value-func #'identity
 297     :obj-data-indent t
 298     :obj-data-fmtstr #'hyperobject-class-fmtstr-html-labels
 299     :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-html-labels
 300     :obj-data-value-func #'hyperobject-class-xmlvalue-func))
 301
 302
 303 (defun xmlformat-list-end-value-func (x)
 304   (format nil "~alist" (class-name-of x)))
 305
 306 (defun xmlformat-list-start-value-func (x nitems)
 307   (values (format nil "~alist" (class-name-of x)) (hyperobject-class-user-name x) nitems))
 308
 309 (defclass xmlformat (textformat)
 310   ()
 311   (:default-initargs :file-start-str "" ; (std-xml-header)
 312     :list-start-indent  t
 313     :list-start-fmtstr "<~a><title>~a~p:</title> ~%"
 314     :list-start-value-func #'xmlformat-list-start-value-func
 315     :list-end-indent  t
 316     :list-end-fmtstr "</~a>~%"
 317     :list-end-value-func #'xmlformat-list-end-value-func
 318     :obj-start-fmtstr "<~a>"
 319     :obj-start-value-func #'class-name-of
 320     :obj-start-indent t
 321     :obj-end-fmtstr "</~a>~%"
 322     :obj-end-value-func #'class-name-of
 323     :obj-end-indent nil
 324     :obj-data-indent nil
 325     :obj-data-fmtstr #'hyperobject-class-fmtstr-xml
 326     :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-xml-labels
 327     :obj-data-value-func #'hyperobject-class-xmlvalue-func))
 328
 329 (defclass link-ref ()
 330   ((fmtstr :type function :initarg :fmtstr :accessor fmtstr)
 331    (fmtstr-labels :type function :initarg :fmtstr-labels :accessor fmtstr-labels)
 332    (page-name :type string :initarg :page-name :accessor page-name)
 333    (href-head :type string :initarg :href-head :accessor href-head)
 334    (href-end :type string :initarg :href-end :accessor href-end)
 335    (ampersand :type string :initarg :ampersand :accessor ampersand))
 336   (:default-initargs :fmtstr nil
 337     :fmtstr-labels nil
 338     :page-name "disp-func1"
 339     :href-head nil :href-end nil :ampersand nil)
 340   (:documentation "Formatting for a linked hyperlink"))
 341
 342 (defclass html-link-ref (link-ref)
 343   ()
 344   (:default-initargs :fmtstr #'hyperobject-class-fmtstr-html-ref
 345     :fmtstr-labels #'hyperobject-class-fmtstr-html-ref-labels
 346     :href-head "a href="
 347     :href-end "a"
 348     :ampersand "&"))
 349
 350 (defclass xhtml-link-ref (link-ref)
 351   ()
 352   (:default-initargs :fmtstr #'hyperobject-class-fmtstr-html-ref
 353     :fmtstr-labels #'hyperobject-class-fmtstr-html-ref-labels
 354     :href-head "a href="
 355     :href-end "a"
 356     :ampersand "&amp;"))
 357
 358 (defclass xml-link-ref (link-ref)
 359   ()
 360   (:default-initargs :fmtstr #'hyperobject-class-fmtstr-xml-ref
 361                      :fmtstr-labels #'hyperobject-class-fmtstr-xml-ref-labels
 362                      :href-head "xmllink xlink:type=\"simple\" xlink:href="
 363                      :href-end "xmllink"
 364                      :ampersand "&amp;")
 365   (:documentation "Mozilla's and W3's idea of a link with XML"))
 366
 367 (defclass ie-xml-link-ref (xml-link-ref)
 368   ()
 369   (:default-initargs :href-head "html:a href="
 370                      :href-end "html:a" )
 371   (:documentation "Internet Explorer's idea of a link with XML"))
 372
 373
 374 (defclass htmlrefformat (htmlformat)
 375   ()
 376   (:default-initargs :link-ref (make-instance 'html-link-ref)))
 377
 378 (defclass xhtmlrefformat (xhtmlformat)
 379   ()
 380   (:default-initargs :link-ref (make-instance 'xhtml-link-ref)))
 381
 382 (defclass xmlrefformat (xmlformat)
 383   ()
 384   (:default-initargs :link-ref (make-instance 'xml-link-ref)))
 385
 386 (defclass ie-xmlrefformat (xmlformat)
 387   ()
 388   (:default-initargs :link-ref (make-instance 'ie-xml-link-ref)))
 389
 390
 391 ;;; File Start and Ends
 392
 393 (defgeneric fmt-file-start (fmt s))
 394 (defmethod fmt-file-start ((fmt dataformat) (s stream)))
 395
 396 (defmethod fmt-file-start ((fmt textformat) (s stream))
 397   (aif (file-start-str fmt)
 398       (format s it)))
 399
 400 (defgeneric fmt-file-end (fmt s))
 401 (defmethod fmt-file-end ((fmt textformat) (s stream))
 402   (aif (file-end-str fmt)
 403           (format s it)))
 404
 405 ;;; List Start and Ends
 406
 407 (defgeneric fmt-list-start (obj fmt s &optional indent num-items))
 408 (defmethod fmt-list-start (x (fmt textformat) (s stream) &optional (indent 0) (num-items 1))
 409   (if (list-start-indent fmt)
 410       (indent-spaces indent s))
 411   (aif (list-start-fmtstr fmt)
 412           (apply #'format s it
 413                  (multiple-value-list
 414                   (funcall (list-start-value-func fmt) x num-items)))))
 415
 416 (defgeneric fmt-list-end (obj fmt s &optional indent num-items))
 417 (defmethod fmt-list-end (x (fmt textformat) (s stream) &optional (indent 0) (num-items 1))
 418   (declare (ignore num-items))
 419   (if (list-end-indent fmt)
 420       (indent-spaces indent s))
 421   (aif (list-end-fmtstr fmt)
 422           (apply #'format s it
 423                  (multiple-value-list
 424                   (funcall (list-end-value-func fmt) x)))))
 425
 426 ;;; Object Start and Ends
 427
 428 (defgeneric fmt-obj-start (obj fmt s &optional indent))
 429 (defmethod fmt-obj-start (x (fmt textformat) (s stream) &optional (indent 0))
 430   (if (obj-start-indent fmt)
 431       (indent-spaces indent s))
 432   (aif (obj-start-fmtstr fmt)
 433           (apply #'format s it
 434                  (multiple-value-list
 435                   (funcall (obj-start-value-func fmt) x)))))
 436
 437 (defgeneric fmt-obj-end (obj fmt s &optional indent))
 438 (defmethod fmt-obj-end (x (fmt textformat) (s stream) &optional (indent 0))
 439   (if (obj-end-indent fmt)
 440       (indent-spaces indent s))
 441   (aif (obj-end-fmtstr fmt)
 442           (apply #'format s it
 443                  (multiple-value-list
 444                   (funcall (obj-end-value-func fmt) x)))))
 445
 446 ;;; Object Data
 447
 448 (defgeneric make-link-start (obj ref fieldname fieldfunc fieldvalue refvars))
 449 (defmethod make-link-start (obj (ref link-ref) fieldname fieldfunc fieldvalue refvars)
 450   (declare (ignore obj fieldname))
 451   (format nil "~a\"~a?func=~a~akey=~a~a\""
 452           (href-head ref) (make-url (page-name ref)) fieldfunc
 453           (ampersand ref) fieldvalue
 454           (if refvars
 455               (let ((varstr ""))
 456                 (dolist (var refvars)
 457                   (string-append varstr (format nil "~a~a=~a"
 458                                                 (ampersand ref) (car var) (cadr var))))
 459                 varstr)
 460             "")))
 461
 462 (defgeneric make-link-end (obj ref fieldname))
 463 (defmethod make-link-end (obj (ref link-ref) fieldname)
 464   (declare (ignore obj fieldname))
 465   (format nil "~a" (href-end ref))
 466   )
 467
 468 (defgeneric fmt-obj-data (obj fmt s &optional indent label refvars))
 469 (defmethod fmt-obj-data (x (fmt textformat) s
 470                          &optional (indent 0) (label nil) (refvars nil))
 471   (if (obj-data-indent fmt)
 472       (indent-spaces indent s))
 473   (if (link-ref fmt)
 474       (fmt-obj-data-with-ref x fmt s label refvars)
 475     (fmt-obj-data-plain x fmt s label))
 476   (aif (obj-data-end-fmtstr fmt)
 477        (format s it)))
 478
 479 (defgeneric fmt-obj-data-plain (obj fmt s label))
 480 (defmethod fmt-obj-data-plain (x (fmt textformat) s label)
 481   (if label
 482       (apply #'format s
 483              (funcall (obj-data-fmtstr-labels fmt) x)
 484              (multiple-value-list
 485               (funcall (funcall (obj-data-value-func fmt) x) x)))
 486     (apply #'format s (funcall (obj-data-fmtstr fmt) x)
 487            (multiple-value-list
 488             (funcall (funcall (obj-data-value-func fmt) x) x)))))
 489
 490 (defgeneric fmt-obj-data-with-ref (obj fmt s label refvars))
 491 (defmethod fmt-obj-data-with-ref (x (fmt textformat) s label refvars)
 492   (let ((refvalues '()))
 493     ;; make list of hyperlink link fields for printing to refstr template
 494     (dolist (name (hyperobject-class-print-slots x))
 495       (let-when (hyperlink (find name (hyperobject-class-hyperlinks x) :key #'name))
 496         (push  (make-link-start x (link-ref fmt) name (lookup hyperlink)
 497                                 (slot-value x name)
 498                                 (append (link-parameters hyperlink) refvars))
 499                refvalues)
 500         (push (make-link-end x (link-ref fmt) name) refvalues)))
 501     (setq refvalues (nreverse refvalues))
 502     (apply #'format s (make-ref-data-str x fmt label) refvalues)))
 503
 504 (defgeneric obj-data (obj))
 505 (defmethod obj-data (x)
 506   "Returns the objects data as a string. Used by common-graphics outline function"
 507   (let ((fmt (make-format-instance :text)))
 508     (apply #'format nil (funcall (obj-data-fmtstr fmt) x)
 509            (multiple-value-list
 510             (funcall (funcall (obj-data-value-func fmt) x) x)))))
 511
 512 (defgeneric make-ref-data-str (obj fmt &optional label))
 513 (defmethod make-ref-data-str (x (fmt textformat) &optional (label nil))
 514   "Return fmt string for that contains ~a slots for hyperlink link start and end"
 515   (unless (link-ref fmt)
 516     (error "fmt does not contain a link-ref"))
 517   (let ((refstr
 518          (if label
 519              (apply #'format nil (funcall (fmtstr-labels (link-ref fmt)) x)
 520                     (multiple-value-list
 521                       (funcall (funcall (obj-data-value-func fmt) x) x)))
 522            (apply #'format nil (funcall (fmtstr (link-ref fmt)) x)
 523                   (multiple-value-list (funcall (funcall (obj-data-value-func fmt) x) x))))))
 524     refstr))
 525
 526 ;;; Display method for objects
 527
 528
 529 (defgeneric load-all-subobjects (objs))
 530 (defmethod load-all-subobjects (objs)
 531   "Load all subobjects if they have not already been loaded."
 532   (when objs
 533     (let ((objlist (mklist objs)))
 534       (dolist (obj objlist)
 535         (awhen (hyperobject-class-subobjects obj)  ;; access list of functions
 536           (dolist (child-obj it)   ;; for each child function
 537             (awhen (slot-value obj (name-slot child-obj))
 538               (load-all-subobjects it))))))
 539     objs))
 540
 541 (defgeneric view-hyperobject (objs fmt strm
 542                                   &optional label english-only-function
 543                                   indent subobjects refvars))
 544
 545 (defmethod view-hyperobject (objs (fmt dataformat) (strm stream)
 546                                  &optional (label nil) (indent 0)
 547                                  (english-only-function nil)
 548                                  (subobjects nil) (refvars nil))
 549 "Display a single or list of hyperobject-class instances and their subobjects"
 550   (when objs
 551     (setq objs (mklist objs))
 552     (let ((nobjs (length objs)))
 553       (fmt-list-start (car objs) fmt strm indent nobjs)
 554       (dolist (obj objs)
 555         (unless (and english-only-function
 556                   (multiple-value-bind (eng term) (funcall english-only-function obj)
 557                     (and term (not eng))))
 558           (fmt-obj-start obj fmt strm indent)
 559           (fmt-obj-data obj fmt strm (1+ indent) label refvars)
 560           (if subobjects
 561               (awhen (hyperobject-class-subobjects obj)  ;; access list of functions
 562                         (dolist (child-obj it)   ;; for each child function
 563                           (awhen (slot-value obj (name-slot child-obj)) ;; access set of child objects
 564                                  (view-hyperobject it fmt strm label
 565                                                    (1+ indent) english-only-function
 566                                                    subobjects refvars)))))
 567           (fmt-obj-end obj fmt strm indent)))
 568       (fmt-list-end (car objs) fmt strm indent nobjs))
 569     t))
 570
 571
 572 (defun view (objs &key (os *standard-output*) (format :text)
 573                       (label nil) (english-only-function nil)
 574                       (subobjects nil) (file-wrapper t) (refvars nil))
 575   "EXPORTED Function: prints hyperobject-class objects. Simplies call to view-hyperobject"
 576   (let ((fmt (make-format-instance format)))
 577     (if file-wrapper
 578         (fmt-file-start fmt os))
 579     (when objs
 580       (view-hyperobject objs fmt os label 0 english-only-function subobjects refvars))
 581     (if file-wrapper
 582         (fmt-file-end fmt os)))
 583   objs)
 584
 585
 586 ;;; Misc formatting
 587
 588 (defun fmt-comma-integer (i)
 589   (format nil "~:d" i))
 590