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