hyperobject-mop.lisp

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