hyperobject.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          hyperobject.lisp
   6 ;;;; Purpose:       Hyper Object Metaclass
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Apr 2000
   9 ;;;;
  10 ;;;; This metaclass as functions to classes to allow display
  11 ;;;; in Text, HTML, and XML formats. This includes hyperlinking
  12 ;;;; capability and sub-objects.
  13 ;;;;
  14 ;;;; $Id: hyperobject.lisp,v 1.3 2002/11/04 18:02:13 kevin Exp $
  15 ;;;;
  16 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
  17 ;;;;
  18 ;;;; *************************************************************************
  19
  20 (in-package :hyperobject)
  21
  22
  23 (eval-when (:compile-toplevel :execute)
  24   (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3))))
  25
  26
  27 ;; Utilities
  28
  29 (defun kmr-class-of (obj)
  30   #-(or cmu sbcl) (class-of obj)
  31   #+sbcl (sb-pcl:class-of obj)
  32   #+cmu (pcl:class-of obj))
  33
  34 (defun kmr-class-name (obj)
  35   #-(or cmu sbcl) (class-name obj)
  36   #+sbcl (sb-pcl:class-name obj)
  37   #+cmu (pcl:class-name obj))
  38
  39 ;; Main class
  40
  41 (defclass hyperobject-class (#-(or cmu sbcl) standard-class
  42                       #+cmu pcl::standard-class
  43                       #+sbcl sb-pcl::standard-class)
  44   ((title :initarg :title :type string :reader ml-std-title
  45           :documentation
  46 "Print Title for class")
  47    (fields :initarg :fields :reader ml-std-fields
  48            :documentation
  49 "List of field lists for printing. Format is
  50    ((fieldname type optional-formatter) ... )")
  51    (subobjects-lists
  52     :initarg :subobjects-lists :reader ml-std-subobjects-lists
  53     :documentation
  54 "List of fields that contain a list of subobjects objects.")
  55    (ref-fields
  56     :initarg :ref-fields :type list :reader ml-std-ref-field
  57     :documentation
  58     "List of fields that can be referred to by browsers.
  59 Format is ((field-name field-lookup-func other-link-params) ...)")
  60
  61    ;;; The remainder of these fields are calculated one time
  62    ;;; in finalize-inheritence.
  63    (value-func :initform nil :type function :reader ml-std-value-func)
  64    (xmlvalue-func :initform nil :type function :reader ml-std-xmlvalue-func)
  65    (fmtstr-text :initform nil :type string :reader ml-std-fmtstr-text)
  66    (fmtstr-html :initform nil :type string :reader ml-std-fmtstr-html)
  67    (fmtstr-xml :initform nil :type string :reader ml-std-fmtstr-xml)
  68    (fmtstr-text-labels :initform nil :type string :reader ml-std-fmtstr-text-labels)
  69    (fmtstr-html-labels :initform nil :type string :reader ml-std-fmtstr-html-labels)
  70    (fmtstr-xml-labels :initform nil :type string :reader ml-std-fmtstr-xml-labels)
  71    (fmtstr-html-ref :initform nil :type string :reader ml-std-fmtstr-html-ref)
  72    (fmtstr-xml-ref :initform nil :type string :reader ml-std-fmtstr-xml-ref)
  73    (fmtstr-html-ref-labels :initform nil :type string :reader ml-std-fmtstr-html-ref-labels)
  74    (fmtstr-xml-ref-labels :initform nil :type string :reader ml-std-fmtstr-xml-ref-labels)
  75    )
  76   (:default-initargs :title nil :fields nil :subobjects-lists nil :ref-fields nil)
  77   (:documentation "Metaclass for Markup Language classes."))
  78
  79 #+cmu
  80 (defmethod pcl:finalize-inheritance :after ((cl hyperobject-class))
  81   (init-hyperobject-class cl))
  82
  83 #+scl
  84 (defmethod clos:finalize-inheritance :after ((cl hyperobject-class))
  85   (init-hyperobject-class cl))
  86
  87
  88 #+sbcl
  89 (defmethod sb-pcl:finalize-inheritance :after ((cl hyperobject-class))
  90   (init-hyperobject-class cl))
  91
  92
  93 #+cmu
  94 (defmethod pcl:validate-superclass ((class hyperobject-class) (superclass pcl::standard-class))
  95   t)
  96
  97 #+scl
  98 (defmethod clos:validate-superclass ((class hyperobject-class) (superclass standard-class))
  99   t)
 100
 101 #+sbcl
 102 (defmethod sb-pcl:validate-superclass ((class hyperobject-class) (superclass sb-pcl::standard-class))
 103   t)
 104
 105 #+allegro
 106 (defmethod mop:finalize-inheritance :after ((cl hyperobject-class))
 107   (init-hyperobject-class cl))
 108
 109 #+lispworks
 110 (defmethod clos:finalize-inheritance :after ((cl hyperobject-class))
 111   (init-hyperobject-class cl))
 112
 113 #+lispworks
 114 (defmethod clos:process-a-class-option ((class hyperobject-class)
 115                                         (name (eql :title))
 116                                         value)
 117   (unless value
 118     (error "hyperobject-class title must have a value"))
 119   (if (null (cdr value))
 120       (list name (car value))
 121     (list name `',value)))
 122
 123 #+lispworks
 124 (defmethod clos:process-a-class-option ((class hyperobject-class)
 125                                         (name (eql :fields))
 126                                         value)
 127   (unless value
 128     (error "hyperobject-class fields must have a value"))
 129   (list name `',value))
 130
 131 #+lispworks
 132 (defmethod clos:process-a-class-option ((class hyperobject-class)
 133                                         (name (eql :ref-fields))
 134                                         value)
 135   (unless value
 136     (error "hyperobject-class ref-fields must have a value"))
 137   (list name `',value))
 138
 139 #+lispworks
 140 (defmethod clos:process-a-class-option ((class hyperobject-class)
 141                                         (name (eql :subobjects-lists))
 142                                         value)
 143   (unless value
 144     (error "hyperobject-class subobjects-lists must have a value"))
 145   (list name `',value))
 146
 147 ;;;; Class initialization function
 148
 149 (defun init-hyperobject-class (cl)
 150     (let ((fmtstr-text "")
 151           (fmtstr-html "")
 152           (fmtstr-xml "")
 153           (fmtstr-text-labels "")
 154           (fmtstr-html-labels "")
 155           (fmtstr-xml-labels "")
 156           (fmtstr-html-ref "")
 157           (fmtstr-xml-ref "")
 158           (fmtstr-html-ref-labels "")
 159           (fmtstr-xml-ref-labels "")
 160           (first-field t)
 161           (value-func '())
 162           (xmlvalue-func '())
 163           (classname (class-name cl))
 164           (package (symbol-package (kmr-class-name cl)))
 165           (ref-fields (slot-value cl 'ref-fields)))
 166       (declare (ignore classname))
 167       (dolist (f (slot-value cl 'fields))
 168         (let ((name (car f))
 169               (namestr (symbol-name (car f)))
 170               (namestr-lower (string-downcase (symbol-name (car f))))
 171               (type (cadr f))
 172               (formatter (caddr f))
 173               (value-fmt "~a")
 174               (plain-value-func nil)
 175               html-str xml-str html-label-str xml-label-str)
 176
 177           (when (or (eql type :integer) (eql type :fixnum))
 178             (setq value-fmt "~d"))
 179
 180           (when (eql type :commainteger)
 181             (setq value-fmt "~:d"))
 182
 183           (when (eql type :boolean)
 184             (setq value-fmt "~a"))
 185
 186           (if first-field
 187               (setq first-field nil)
 188             (progn
 189               (string-append fmtstr-text " ")
 190               (string-append fmtstr-html " ")
 191               (string-append fmtstr-xml " ")
 192               (string-append fmtstr-text-labels " ")
 193               (string-append fmtstr-html-labels " ")
 194               (string-append fmtstr-xml-labels " ")
 195               (string-append fmtstr-html-ref " ")
 196               (string-append fmtstr-xml-ref " ")
 197               (string-append fmtstr-html-ref-labels " ")
 198               (string-append fmtstr-xml-ref-labels " ")))
 199
 200           (setq html-str (concatenate 'string "<span class=\"" namestr-lower "\">" value-fmt "</span>"))
 201           (setq xml-str (concatenate 'string "<" namestr-lower ">" value-fmt "</" namestr-lower ">"))
 202           (setq html-label-str (concatenate 'string "<span class=\"label\">" namestr-lower "</span> <span class=\"" namestr-lower "\">" value-fmt "</span>"))
 203           (setq xml-label-str (concatenate 'string "<label>" namestr-lower "</label> <" namestr-lower ">" value-fmt "</" namestr-lower ">"))
 204
 205           (string-append fmtstr-text value-fmt)
 206           (string-append fmtstr-html html-str)
 207           (string-append fmtstr-xml xml-str)
 208           (string-append fmtstr-text-labels namestr-lower " " value-fmt)
 209           (string-append fmtstr-html-labels html-label-str)
 210           (string-append fmtstr-xml-labels xml-label-str)
 211
 212           (if (find name ref-fields :key #'car)
 213             (progn
 214               (string-append fmtstr-html-ref "<~~a>" value-fmt "</~~a>")
 215               (string-append fmtstr-xml-ref "<~~a>" value-fmt "</~~a>")
 216               (string-append fmtstr-html-ref-labels "<span class=\"label\">" namestr-lower "</span> <~~a>" value-fmt "</~~a>")
 217               (string-append fmtstr-xml-ref-labels "<label>" namestr-lower "</label> <~~a>" value-fmt "</~~a>"))
 218             (progn
 219               (string-append fmtstr-html-ref html-str)
 220               (string-append fmtstr-xml-ref xml-str)
 221               (string-append fmtstr-html-ref-labels html-label-str)
 222               (string-append fmtstr-xml-ref-labels xml-label-str)))
 223
 224           (if formatter
 225               (setq plain-value-func
 226                 (list `(,formatter (,(intern namestr package) x))))
 227             (setq plain-value-func
 228               (list `(,(intern namestr package) x))))
 229           (setq value-func (append value-func plain-value-func))
 230
 231           (if (eql type :cdata)
 232               (setq xmlvalue-func (append xmlvalue-func (list `(xml-cdata ,@plain-value-func))))
 233             (setq xmlvalue-func (append xmlvalue-func plain-value-func)))
 234           ))
 235
 236       (if value-func
 237           (setq value-func `(lambda (x) (values ,@value-func)))
 238         (setq value-func `(lambda () (values))))
 239       (setq value-func (compile nil (eval value-func)))
 240
 241       (if xmlvalue-func
 242           (setq xmlvalue-func `(lambda (x) (values ,@xmlvalue-func)))
 243         (setq xmlvalue-func `(lambda () (values))))
 244       (setq xmlvalue-func (compile nil (eval xmlvalue-func)))
 245
 246       (setf (slot-value cl 'fmtstr-text) fmtstr-text)
 247       (setf (slot-value cl 'fmtstr-html) fmtstr-html)
 248       (setf (slot-value cl 'fmtstr-xml) fmtstr-xml)
 249       (setf (slot-value cl 'fmtstr-text-labels) fmtstr-text-labels)
 250       (setf (slot-value cl 'fmtstr-html-labels) fmtstr-html-labels)
 251       (setf (slot-value cl 'fmtstr-xml-labels) fmtstr-xml-labels)
 252       (setf (slot-value cl 'fmtstr-html-ref) fmtstr-html-ref)
 253       (setf (slot-value cl 'fmtstr-xml-ref) fmtstr-xml-ref)
 254       (setf (slot-value cl 'fmtstr-html-ref-labels) fmtstr-html-ref-labels)
 255       (setf (slot-value cl 'fmtstr-xml-ref-labels) fmtstr-xml-ref-labels)
 256       (setf (slot-value cl 'value-func) value-func)
 257       (setf (slot-value cl 'xmlvalue-func) xmlvalue-func))
 258     (values))
 259
 260
 261 (defun hyperobject-class-fmtstr-text (obj)
 262   (slot-value (kmr-class-of obj) 'fmtstr-text))
 263
 264 (defun hyperobject-class-fmtstr-html (obj)
 265   (slot-value (kmr-class-of obj) 'fmtstr-html))
 266
 267 (defun hyperobject-class-fmtstr-xml (obj)
 268   (slot-value (kmr-class-of obj) 'fmtstr-xml))
 269
 270 (defun hyperobject-class-fmtstr-text-labels (obj)
 271   (slot-value (kmr-class-of obj) 'fmtstr-text-labels))
 272
 273 (defun hyperobject-class-fmtstr-html-labels (obj)
 274   (slot-value (kmr-class-of obj) 'fmtstr-html-labels))
 275
 276 (defun hyperobject-class-fmtstr-xml-labels (obj)
 277   (slot-value (kmr-class-of obj) 'fmtstr-xml-labels))
 278
 279 (defun hyperobject-class-value-func (obj)
 280   (slot-value (kmr-class-of obj) 'value-func))
 281
 282 (defun hyperobject-class-xmlvalue-func (obj)
 283   (slot-value (kmr-class-of obj) 'xmlvalue-func))
 284
 285 (eval-when (:compile-toplevel :load-toplevel :execute)
 286 (defun hyperobject-class-title (obj)
 287   (awhen (slot-value (kmr-class-of obj) 'title)
 288             (if (consp it)
 289                 (car it)
 290               it))))
 291
 292 (defun hyperobject-class-subobjects-lists (obj)
 293   (slot-value (kmr-class-of obj) 'subobjects-lists))
 294
 295 (defun hyperobject-class-ref-fields (obj)
 296   (slot-value (kmr-class-of obj) 'ref-fields))
 297
 298 (defun hyperobject-class-fields (obj)
 299   (slot-value (kmr-class-of obj) 'fields))
 300
 301 (defun hyperobject-class-fmtstr-html-ref (obj)
 302   (slot-value (kmr-class-of obj) 'fmtstr-html-ref))
 303
 304 (defun hyperobject-class-fmtstr-xml-ref (obj)
 305   (slot-value (kmr-class-of obj) 'fmtstr-xml-ref))
 306
 307 (defun hyperobject-class-fmtstr-html-ref-labels (obj)
 308   (slot-value (kmr-class-of obj) 'fmtstr-html-ref-labels))
 309
 310 (defun hyperobject-class-fmtstr-xml-ref-labels (obj)
 311   (slot-value (kmr-class-of obj) 'fmtstr-xml-ref-labels))
 312
 313 ;;; Class name functions
 314
 315 (defgeneric hyperobject-class-stdname (x))
 316 (defmethod hyperobject-class-stdname ((name string))
 317   (string-downcase (subseq name 1)))
 318
 319 (defmethod hyperobject-class-stdname ((cl standard-object))
 320   (string-downcase (subseq (kmr-class-name (kmr-class-of cl)) 1)))
 321
 322 ;;;; Generic Print functions
 323
 324 (defparameter *default-textformat* nil)
 325 (defparameter *default-htmlformat* nil)
 326 (defparameter *default-htmlrefformat* nil)
 327 (defparameter *default-xhtmlformat* nil)
 328 (defparameter *default-xhtmlrefformat* nil)
 329 (defparameter *default-xmlformat* nil)
 330 (defparameter *default-xmlrefformat* nil)
 331 (defparameter *default-ie-xmlrefformat* nil)
 332 (defparameter *default-nullformat* nil)
 333 (defparameter *default-init-format?* nil)
 334
 335 (defun make-format-instance (fmt)
 336   (unless *default-init-format?*
 337     (setq *default-textformat* (make-instance 'textformat))
 338     (setq *default-htmlformat* (make-instance 'htmlformat))
 339     (setq *default-htmlrefformat* (make-instance 'htmlrefformat))
 340     (setq *default-xhtmlformat* (make-instance 'xhtmlformat))
 341     (setq *default-xhtmlrefformat* (make-instance 'xhtmlrefformat))
 342     (setq *default-xmlformat* (make-instance 'xmlformat))
 343     (setq *default-xmlrefformat* (make-instance 'xmlrefformat))
 344     (setq *default-ie-xmlrefformat* (make-instance 'ie-xmlrefformat))
 345     (setq *default-nullformat* (make-instance 'nullformat))
 346     (setq *default-init-format?* t))
 347
 348   (case fmt
 349       (:text *default-textformat*)
 350       (:html *default-htmlformat*)
 351       (:htmlref *default-htmlrefformat*)
 352       (:xhtml  *default-xhtmlformat*)
 353       (:xhtmlref *default-xhtmlrefformat*)
 354       (:xml  *default-xmlformat*)
 355       (:xmlref *default-xmlrefformat*)
 356       (:ie-xmlref *default-ie-xmlrefformat*)
 357       (:null *default-nullformat*)
 358       (otherwise *default-textformat*)))
 359
 360 ;;;; Output format classes for print hyperobject-classes
 361
 362 (defclass dataformat ()
 363   ((file-start-str :type string :initarg :file-start-str :reader file-start-str)
 364    (file-end-str :type string :initarg :file-end-str :reader file-end-str)
 365    (list-start-fmtstr :type string :initarg :list-start-fmtstr :reader list-start-fmtstr)
 366    (list-start-value-func :type function :initarg :list-start-value-func :reader list-start-value-func)
 367    (list-start-indent :initarg :list-start-indent :reader list-start-indent)
 368    (list-end-fmtstr :type string :initarg :list-end-fmtstr :reader list-end-fmtstr)
 369    (list-end-value-func :type function :initarg :list-end-value-func :reader list-end-value-func)
 370    (list-end-indent :initarg :list-end-indent :reader list-end-indent)
 371    (obj-start-fmtstr :type string :initarg :obj-start-fmtstr :reader obj-start-fmtstr)
 372    (obj-start-value-func :initarg :obj-start-value-func :reader obj-start-value-func)
 373    (obj-start-indent :initarg :obj-start-indent :reader obj-start-indent)
 374    (obj-end-fmtstr :type string :initarg :obj-end-fmtstr :reader obj-end-fmtstr)
 375    (obj-end-value-func :initarg :obj-end-value-func :reader obj-end-value-func)
 376    (obj-end-indent :initarg :obj-end-indent :reader obj-end-indent)
 377    (obj-data-indent :initarg :obj-data-indent :reader obj-data-indent)
 378    (obj-data-fmtstr :initarg :obj-data-fmtstr :reader  obj-data-fmtstr)
 379    (obj-data-fmtstr-labels :initarg :obj-data-fmtstr-labels :reader  obj-data-fmtstr-labels)
 380    (obj-data-end-fmtstr :initarg :obj-data-end-fmtstr :reader obj-data-end-fmtstr)
 381    (obj-data-value-func :initarg :obj-data-value-func :reader obj-data-value-func)
 382    (link-ref :initarg :link-ref :reader link-ref))
 383   (:default-initargs :file-start-str nil :file-end-str nil :list-start-fmtstr nil :list-start-value-func nil
 384                      :list-start-indent nil :list-end-fmtstr nil :list-end-value-func nil :list-end-indent nil
 385                      :obj-start-fmtstr nil :obj-start-value-func nil :obj-start-indent nil
 386                      :obj-end-fmtstr nil :obj-end-value-func nil :obj-end-indent nil
 387                      :obj-data-indent nil :obj-data-fmtstr nil :obj-data-fmtstr-labels nil :obj-data-end-fmtstr nil
 388                      :obj-data-value-func nil :link-ref nil)
 389   (:documentation "Parent for all dataformat objects"))
 390
 391 (defclass binaryformat (dataformat)
 392   ())
 393
 394 (defclass nullformat (dataformat)
 395   ())
 396
 397 (defun text-list-start-value-func (obj nitems)
 398   (values (hyperobject-class-title obj) nitems))
 399
 400 (defclass textformat (dataformat)
 401   ()
 402   (:default-initargs :list-start-fmtstr "~a~P:~%"
 403     :list-start-value-func #'text-list-start-value-func
 404     :list-start-indent t
 405     :obj-data-indent t
 406     :obj-data-fmtstr #'hyperobject-class-fmtstr-text
 407     :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-text-labels
 408     :obj-data-end-fmtstr "~%"
 409     :obj-data-value-func #'hyperobject-class-value-func))
 410
 411
 412 (defun class-name-of (obj)
 413   (string-downcase (kmr-class-name (kmr-class-of obj))))
 414
 415 (defun htmlformat-list-start-value-func (x nitems)
 416   (values (hyperobject-class-title x) nitems (class-name-of x)))
 417
 418 (defclass htmlformat (textformat)
 419   ()
 420   (:default-initargs :file-start-str "<html><body>~%"
 421     :file-end-str "</body><html>~%"
 422     :list-start-indent t
 423     :list-start-fmtstr "<p><b>~a~p:</b></p><div class=\"~A\"><ul>~%"
 424     :list-start-value-func #'htmlformat-list-start-value-func
 425     :list-end-fmtstr "</ul></div>~%"
 426     :list-end-indent t
 427     :list-end-value-func #'identity
 428     :obj-start-indent t
 429     :obj-start-fmtstr "<li>"
 430     :obj-start-value-func #'identity
 431     :obj-end-indent  t
 432     :obj-end-fmtstr  "</li>~%"
 433     :obj-end-value-func #'identity
 434     :obj-data-indent t
 435     :obj-data-fmtstr #'hyperobject-class-fmtstr-html-labels
 436     :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-html-labels
 437     :obj-data-value-func #'hyperobject-class-value-func))
 438
 439 (defclass xhtmlformat (textformat)
 440   ()
 441   (:default-initargs :file-start-str "<html><body>~%"
 442     :file-end-str "</body><html>~%"
 443     :list-start-indent t
 444     :list-start-fmtstr "<p><b>~a~p:</b></p><div class=\"~A\"><ul>~%"
 445     :list-start-value-func #'htmlformat-list-start-value-func
 446     :list-end-fmtstr "</ul></div>~%"
 447     :list-end-indent t
 448     :list-end-value-func #'identity
 449     :obj-start-indent t
 450     :obj-start-fmtstr "<li>"
 451     :obj-start-value-func #'identity
 452     :obj-end-indent  t
 453     :obj-end-fmtstr  "</li>~%"
 454     :obj-end-value-func #'identity
 455     :obj-data-indent t
 456     :obj-data-fmtstr #'hyperobject-class-fmtstr-html-labels
 457     :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-html-labels
 458     :obj-data-value-func #'hyperobject-class-xmlvalue-func))
 459
 460
 461 (defun xmlformat-list-end-value-func (x)
 462   (format nil "~alist" (class-name-of x)))
 463
 464 (defun xmlformat-list-start-value-func (x nitems)
 465   (values (format nil "~alist" (class-name-of x)) (hyperobject-class-title x) nitems))
 466
 467 (defclass xmlformat (textformat)
 468   ()
 469   (:default-initargs :file-start-str "" ; (std-xml-header)
 470     :list-start-indent  t
 471     :list-start-fmtstr "<~a><title>~a~p:</title> ~%"
 472     :list-start-value-func #'xmlformat-list-start-value-func
 473     :list-end-indent  t
 474     :list-end-fmtstr "</~a>~%"
 475     :list-end-value-func #'xmlformat-list-end-value-func
 476     :obj-start-fmtstr "<~a>"
 477     :obj-start-value-func #'class-name-of
 478     :obj-start-indent t
 479     :obj-end-fmtstr "</~a>~%"
 480     :obj-end-value-func #'class-name-of
 481     :obj-end-indent nil
 482     :obj-data-indent nil
 483     :obj-data-fmtstr #'hyperobject-class-fmtstr-xml
 484     :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-xml-labels
 485     :obj-data-value-func #'hyperobject-class-xmlvalue-func))
 486
 487 (defclass link-ref ()
 488   ((fmtstr :type function :initarg :fmtstr :accessor fmtstr)
 489    (fmtstr-labels :type function :initarg :fmtstr-labels :accessor fmtstr-labels)
 490    (page-name :type string :initarg :page-name :accessor page-name)
 491    (href-head :type string :initarg :href-head :accessor href-head)
 492    (href-end :type string :initarg :href-end :accessor href-end)
 493    (ampersand :type string :initarg :ampersand :accessor ampersand))
 494   (:default-initargs :fmtstr nil
 495     :fmtstr-labels nil
 496     :page-name "disp-func1"
 497     :href-head nil :href-end nil :ampersand nil)
 498   (:documentation "Formatting for a linked reference"))
 499
 500 (defclass html-link-ref (link-ref)
 501   ()
 502   (:default-initargs :fmtstr #'hyperobject-class-fmtstr-html-ref
 503     :fmtstr-labels #'hyperobject-class-fmtstr-html-ref-labels
 504     :href-head "a href="
 505     :href-end "a"
 506     :ampersand "&"))
 507
 508 (defclass xhtml-link-ref (link-ref)
 509   ()
 510   (:default-initargs :fmtstr #'hyperobject-class-fmtstr-html-ref
 511     :fmtstr-labels #'hyperobject-class-fmtstr-html-ref-labels
 512     :href-head "a href="
 513     :href-end "a"
 514     :ampersand "&amp;"))
 515
 516 (defclass xml-link-ref (link-ref)
 517   ()
 518   (:default-initargs :fmtstr #'hyperobject-class-fmtstr-xml-ref
 519                      :fmtstr-labels #'hyperobject-class-fmtstr-xml-ref-labels
 520                      :href-head "xmllink xlink:type=\"simple\" xlink:href="
 521                      :href-end "xmllink"
 522                      :ampersand "&amp;")
 523   (:documentation "Mozilla's and W3's idea of a link with XML"))
 524
 525 (defclass ie-xml-link-ref (xml-link-ref)
 526   ()
 527   (:default-initargs :href-head "html:a href="
 528                      :href-end "html:a" )
 529   (:documentation "Internet Explorer's idea of a link with XML"))
 530
 531
 532 (defclass htmlrefformat (htmlformat)
 533   ()
 534   (:default-initargs :link-ref (make-instance 'html-link-ref)))
 535
 536 (defclass xhtmlrefformat (xhtmlformat)
 537   ()
 538   (:default-initargs :link-ref (make-instance 'xhtml-link-ref)))
 539
 540 (defclass xmlrefformat (xmlformat)
 541   ()
 542   (:default-initargs :link-ref (make-instance 'xml-link-ref)))
 543
 544 (defclass ie-xmlrefformat (xmlformat)
 545   ()
 546   (:default-initargs :link-ref (make-instance 'ie-xml-link-ref)))
 547
 548
 549 ;;; File Start and Ends
 550
 551 (defgeneric fmt-file-start (fmt s))
 552 (defmethod fmt-file-start ((fmt dataformat) (s stream)))
 553
 554 (defmethod fmt-file-start ((fmt textformat) (s stream))
 555   (aif (file-start-str fmt)
 556       (format s it)))
 557
 558 (defgeneric fmt-file-end (fmt s))
 559 (defmethod fmt-file-end ((fmt textformat) (s stream))
 560   (aif (file-end-str fmt)
 561           (format s it)))
 562
 563 ;;; List Start and Ends
 564
 565 (defgeneric fmt-list-start (obj fmt s &optional indent num-items))
 566 (defmethod fmt-list-start (x (fmt textformat) (s stream) &optional (indent 0) (num-items 1))
 567   (if (list-start-indent fmt)
 568       (indent-spaces indent s))
 569   (aif (list-start-fmtstr fmt)
 570           (apply #'format s it
 571                  (multiple-value-list
 572                   (funcall (list-start-value-func fmt) x num-items)))))
 573
 574 (defgeneric fmt-list-end (obj fmt s &optional indent num-items))
 575 (defmethod fmt-list-end (x (fmt textformat) (s stream) &optional (indent 0) (num-items 1))
 576   (declare (ignore num-items))
 577   (if (list-end-indent fmt)
 578       (indent-spaces indent s))
 579   (aif (list-end-fmtstr fmt)
 580           (apply #'format s it
 581                  (multiple-value-list
 582                   (funcall (list-end-value-func fmt) x)))))
 583
 584 ;;; Object Start and Ends
 585
 586 (defgeneric fmt-obj-start (obj fmt s &optional indent))
 587 (defmethod fmt-obj-start (x (fmt textformat) (s stream) &optional (indent 0))
 588   (if (obj-start-indent fmt)
 589       (indent-spaces indent s))
 590   (aif (obj-start-fmtstr fmt)
 591           (apply #'format s it
 592                  (multiple-value-list
 593                   (funcall (obj-start-value-func fmt) x)))))
 594
 595 (defgeneric fmt-obj-end (obj fmt s &optional indent))
 596 (defmethod fmt-obj-end (x (fmt textformat) (s stream) &optional (indent 0))
 597   (if (obj-end-indent fmt)
 598       (indent-spaces indent s))
 599   (aif (obj-end-fmtstr fmt)
 600           (apply #'format s it
 601                  (multiple-value-list
 602                   (funcall (obj-end-value-func fmt) x)))))
 603
 604 ;;; Object Data
 605
 606 (defgeneric make-link-start (obj ref fieldname fieldfunc fieldvalue refvars))
 607 (defmethod make-link-start (obj (ref link-ref) fieldname fieldfunc fieldvalue refvars)
 608   (declare (ignore obj fieldname))
 609   (format nil "~a\"~a?func=~a~akey=~a~a\""
 610           (href-head ref) (make-url (page-name ref)) fieldfunc
 611           (ampersand ref) fieldvalue
 612           (if refvars
 613               (let ((varstr ""))
 614                 (dolist (var refvars)
 615                   (string-append varstr (format nil "~a~a=~a"
 616                                                 (ampersand ref) (car var) (cadr var))))
 617                 varstr)
 618             "")))
 619
 620 (defgeneric make-link-end (obj ref fieldname))
 621 (defmethod make-link-end (obj (ref link-ref) fieldname)
 622   (declare (ignore obj fieldname))
 623   (format nil "~a" (href-end ref))
 624   )
 625
 626 (defgeneric fmt-obj-data (obj fmt s &optional indent label refvars))
 627 (defmethod fmt-obj-data (x (fmt textformat) s
 628                          &optional (indent 0) (label nil) (refvars nil))
 629   (if (obj-data-indent fmt)
 630       (indent-spaces indent s))
 631   (if (link-ref fmt)
 632       (fmt-obj-data-with-ref x fmt s label refvars)
 633     (fmt-obj-data-plain x fmt s label))
 634   (aif (obj-data-end-fmtstr fmt)
 635        (format s it)))
 636
 637 (defgeneric fmt-obj-data-plain (obj fmt s label))
 638 (defmethod fmt-obj-data-plain (x (fmt textformat) s label)
 639   (if label
 640       (apply #'format s
 641              (funcall (obj-data-fmtstr-labels fmt) x)
 642              (multiple-value-list
 643               (funcall (funcall (obj-data-value-func fmt) x) x)))
 644     (apply #'format s (funcall (obj-data-fmtstr fmt) x)
 645            (multiple-value-list
 646             (funcall (funcall (obj-data-value-func fmt) x) x)))))
 647
 648 (defgeneric fmt-obj-data-with-ref (obj fmt s label refvars))
 649 (defmethod fmt-obj-data-with-ref (x (fmt textformat) s label refvars)
 650   (let ((refstr (make-ref-data-str x fmt label))
 651         (refvalues nil)
 652         (field-values
 653          (multiple-value-list
 654           (funcall (funcall (obj-data-value-func fmt) x) x))))
 655
 656     ;; make list of reference link fields for printing to refstr template
 657     (dolist (field (hyperobject-class-ref-fields x))
 658       (let ((link-start
 659              (make-link-start x (link-ref fmt) (car field) (cadr field)
 660                               (nth (position (car field) (hyperobject-class-fields x) :key #'car) field-values)
 661                               (append (caddr field) refvars)))
 662             (link-end (make-link-end x (link-ref fmt) (car field))))
 663         (push link-start refvalues)
 664         (push link-end refvalues)))
 665     (setq refvalues (nreverse refvalues))
 666
 667     (apply #'format s refstr refvalues)))
 668
 669 (defgeneric obj-data (obj))
 670 (defmethod obj-data (x)
 671   "Returns the objects data as a string. Used by common-graphics outline function"
 672   (let ((fmt (make-format-instance :text)))
 673     (apply #'format nil (funcall (obj-data-fmtstr fmt) x)
 674            (multiple-value-list
 675             (funcall (funcall (obj-data-value-func fmt) x) x)))))
 676
 677 (defgeneric make-ref-data-str (obj fmt &optional label))
 678 (defmethod make-ref-data-str (x (fmt textformat) &optional (label nil))
 679   "Return fmt string for that contains ~a slots for reference link start and end"
 680   (unless (link-ref fmt)
 681     (error "fmt does not contain a link-ref"))
 682   (let ((refstr
 683          (if label
 684              (apply #'format nil (funcall (fmtstr-labels (link-ref fmt)) x)
 685                     (multiple-value-list
 686                       (funcall (funcall (obj-data-value-func fmt) x) x)))
 687            (apply #'format nil (funcall (fmtstr (link-ref fmt)) x)
 688                   (multiple-value-list (funcall (funcall (obj-data-value-func fmt) x) x))))))
 689     refstr))
 690
 691 ;;; Display method for objects
 692
 693
 694 (defgeneric load-all-subobjects (objs))
 695 (defmethod load-all-subobjects (objs)
 696   "Load all subobjects if they have not already been loaded."
 697   (when objs
 698     (let ((objlist (mklist objs)))
 699       (dolist (obj objlist)
 700         (awhen (hyperobject-class-subobjects-lists obj)  ;; access list of functions
 701           (dolist (child-obj it)   ;; for each child function
 702             (awhen (funcall (car child-obj) obj)
 703               (load-all-subobjects it))))))
 704     objs))
 705
 706 (defgeneric print-hyperobject-class (objs fmt strm
 707                                   &optional label english-only-function
 708                                   indent subobjects refvars))
 709
 710 (defmethod print-hyperobject-class (objs (fmt dataformat) (strm stream)
 711                                  &optional (label nil) (indent 0)
 712                                  (english-only-function nil)
 713                                  (subobjects nil) (refvars nil))
 714 "Display a single or list of hyperobject-class instances and their subobjects"
 715   (when objs
 716     (setq objs (mklist objs))
 717     (let ((nobjs (length objs)))
 718       (fmt-list-start (car objs) fmt strm indent nobjs)
 719       (dolist (obj objs)
 720         (unless (and english-only-function
 721                   (multiple-value-bind (eng term) (funcall english-only-function obj)
 722                     (and term (not eng))))
 723           (fmt-obj-start obj fmt strm indent)
 724           (fmt-obj-data obj fmt strm (1+ indent) label refvars)
 725           (if subobjects
 726               (awhen (hyperobject-class-subobjects-lists obj)  ;; access list of functions
 727                         (dolist (child-obj it)   ;; for each child function
 728                           (awhen (funcall (car child-obj) obj) ;; access set of child objects
 729                                     (print-hyperobject-class it fmt strm label
 730                                                      english-only-function
 731                                                      (1+ indent) subobjects refvars)))))
 732           (fmt-obj-end obj fmt strm indent)))
 733       (fmt-list-end (car objs) fmt strm indent nobjs))
 734     t))
 735
 736
 737
 738 (defun print-hyperobject (objs &key (os *standard-output*) (format :text)
 739                       (label nil) (english-only-function nil)
 740                       (subobjects nil) (file-wrapper t) (refvars nil))
 741   "EXPORTED Function: prints hyperobject-class objects. Simplies call to print-hyperobject-class"
 742   (let ((fmt (make-format-instance format)))
 743     (if file-wrapper
 744         (fmt-file-start fmt os))
 745     (when objs
 746       (print-hyperobject-class objs fmt os label english-only-function 0 subobjects refvars))
 747     (if file-wrapper
 748         (fmt-file-end fmt os)))
 749   objs)
 750