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