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