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