old/hyperobject-no-mop.lisp

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