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