hyperobject-no-mop.lisp

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