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