ml-class.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          ml-class.lisp
   6 ;;;; Purpose:       Markup Language 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: ml-class.lisp,v 1.5 2002/10/11 23:51:33 kevin Exp $
  15 ;;;;
  16 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
  17 ;;;;
  18 ;;;; KMRCL users are granted the rights to distribute and use this software
  19 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  20 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  21 ;;;; *************************************************************************
  22
  23 (in-package :kmrcl)
  24
  25 (declaim (optimize (speed 3) (safety 1)))
  26
  27
  28 (defclass ml-class (standard-class)
  29   ((title :initarg :title :type string :reader ml-std-title
  30           :documentation
  31 "Print Title for class")
  32    (fields :initarg :fields :reader ml-std-fields
  33            :documentation
  34 "List of field lists for printing. Format is
  35    ((fieldname type optional-formatter) ... )")
  36    (subobjects-lists
  37     :initarg :subobjects-lists :reader ml-std-subobjects-lists
  38     :documentation
  39 "List of fields that contain a list of subobjects objects.")
  40    (ref-fields
  41     :initarg :ref-fields :type list :reader ml-std-ref-field
  42     :documentation
  43     "List of fields that can be referred to by browsers.
  44 Format is ((field-name field-lookup-func other-link-params) ...)")
  45
  46    ;;; The remainder of these fields are calculated one time
  47    ;;; in finalize-inheritence.
  48    (value-func :initform nil :type function :reader ml-std-value-func)
  49    (xmlvalue-func :initform nil :type function :reader ml-std-xmlvalue-func)
  50    (fmtstr-text :initform nil :type string :reader ml-std-fmtstr-text)
  51    (fmtstr-html :initform nil :type string :reader ml-std-fmtstr-html)
  52    (fmtstr-xml :initform nil :type string :reader ml-std-fmtstr-xml)
  53    (fmtstr-text-labels :initform nil :type string :reader ml-std-fmtstr-text-labels)
  54    (fmtstr-html-labels :initform nil :type string :reader ml-std-fmtstr-html-labels)
  55    (fmtstr-xml-labels :initform nil :type string :reader ml-std-fmtstr-xml-labels)
  56    (fmtstr-html-ref :initform nil :type string :reader ml-std-fmtstr-html-ref)
  57    (fmtstr-xml-ref :initform nil :type string :reader ml-std-fmtstr-xml-ref)
  58    (fmtstr-html-ref-labels :initform nil :type string :reader ml-std-fmtstr-html-ref-labels)
  59    (fmtstr-xml-ref-labels :initform nil :type string :reader ml-std-fmtstr-xml-ref-labels)
  60    )
  61   (:default-initargs :title nil :fields nil :subobjects-lists nil :ref-fields nil)
  62   (:documentation "Metaclass for Markup Language classes."))
  63
  64
  65 #+allegro
  66 (defmethod mop:finalize-inheritance :after ((cl ml-class))
  67   (init-ml-class cl))
  68
  69 #+lispworks
  70 (defmethod clos:finalize-inheritance :after ((cl ml-class))
  71   (init-ml-class cl))
  72
  73 #+cmu
  74 (defmethod pcl:finalize-inheritance :after ((cl ml-class))
  75   (init-ml-class cl))
  76
  77 #+lispworks
  78 (defmethod clos:process-a-class-option ((class ml-class)
  79                                         (name (eql :title))
  80                                         value)
  81   (unless value
  82     (error "ml-class title must have a value"))
  83   (if (null (cdr value))
  84       (list name (car value))
  85     (list name `',value)))
  86
  87 #+lispworks
  88 (defmethod clos:process-a-class-option ((class ml-class)
  89                                         (name (eql :fields))
  90                                         value)
  91   (unless value
  92     (error "ml-class fields must have a value"))
  93   (list name `',value))
  94
  95 #+lispworks
  96 (defmethod clos:process-a-class-option ((class ml-class)
  97                                         (name (eql :ref-fields))
  98                                         value)
  99   (unless value
 100     (error "ml-class ref-fields must have a value"))
 101   (list name `',value))
 102
 103 #+lispworks
 104 (defmethod clos:process-a-class-option ((class ml-class)
 105                                         (name (eql :subobjects-lists))
 106                                         value)
 107   (unless value
 108     (error "ml-class subobjects-lists must have a value"))
 109   (list name `',value))
 110
 111 ;;;; Class initialization function
 112
 113 (defun init-ml-class (cl)
 114     (let ((fmtstr-text "")
 115           (fmtstr-html "")
 116           (fmtstr-xml "")
 117           (fmtstr-text-labels "")
 118           (fmtstr-html-labels "")
 119           (fmtstr-xml-labels "")
 120           (fmtstr-html-ref "")
 121           (fmtstr-xml-ref "")
 122           (fmtstr-html-ref-labels "")
 123           (fmtstr-xml-ref-labels "")
 124           (first-field t)
 125           (value-func '())
 126           (xmlvalue-func '())
 127           (classname (class-name cl))
 128           (ref-fields (slot-value cl 'ref-fields)))
 129       (declare (ignore classname))
 130       (dolist (f (slot-value cl 'fields))
 131         (let ((name (car f))
 132               (namestr (symbol-name (car f)))
 133               (namestr-lower (string-downcase (symbol-name (car f))))
 134               (type (cadr f))
 135               (formatter (caddr f))
 136               (value-fmt "~a")
 137               (plain-value-func nil)
 138               html-str xml-str html-label-str xml-label-str)
 139
 140           (when (or (eql type :integer) (eql type :fixnum))
 141             (setq value-fmt "~d"))
 142
 143           (when (eql type :commainteger)
 144             (setq value-fmt "~:d"))
 145
 146           (when (eql type :boolean)
 147             (setq value-fmt "~a"))
 148
 149           (if first-field
 150               (setq first-field nil)
 151             (progn
 152               (string-append fmtstr-text " ")
 153               (string-append fmtstr-html " ")
 154               (string-append fmtstr-xml " ")
 155               (string-append fmtstr-text-labels " ")
 156               (string-append fmtstr-html-labels " ")
 157               (string-append fmtstr-xml-labels " ")
 158               (string-append fmtstr-html-ref " ")
 159               (string-append fmtstr-xml-ref " ")
 160               (string-append fmtstr-html-ref-labels " ")
 161               (string-append fmtstr-xml-ref-labels " ")))
 162
 163           (setq html-str value-fmt)
 164           (setq xml-str (concatenate 'string "<" namestr-lower ">" value-fmt "</" namestr-lower ">"))
 165           (setq html-label-str (concatenate 'string "<i>" namestr-lower "</i> " value-fmt))
 166           (setq xml-label-str (concatenate 'string "<label>" namestr-lower "</label> <" namestr-lower ">" value-fmt "</" namestr-lower ">"))
 167
 168           (string-append fmtstr-text value-fmt)
 169           (string-append fmtstr-html html-str)
 170           (string-append fmtstr-xml xml-str)
 171           (string-append fmtstr-text-labels namestr-lower " " value-fmt)
 172           (string-append fmtstr-html-labels html-label-str)
 173           (string-append fmtstr-xml-labels xml-label-str)
 174
 175           (if (find name ref-fields :key #'car)
 176             (progn
 177               (string-append fmtstr-html-ref "<~~a>" value-fmt "</~~a>")
 178               (string-append fmtstr-xml-ref "<~~a>" value-fmt "</~~a>")
 179               (string-append fmtstr-html-ref-labels "<i>" namestr-lower "</i> <~~a>" value-fmt "</~~a>")
 180               (string-append fmtstr-xml-ref-labels "<label>" namestr-lower "</label> <~~a>" value-fmt "</~~a>"))
 181             (progn
 182               (string-append fmtstr-html-ref html-str)
 183               (string-append fmtstr-xml-ref xml-str)
 184               (string-append fmtstr-html-ref-labels html-label-str)
 185               (string-append fmtstr-xml-ref-labels xml-label-str)))
 186
 187           (if formatter
 188               (setq plain-value-func
 189                 (list `(,formatter (,(concat-symbol-pkg
 190                                       :umlisp namestr) x))))
 191             (setq plain-value-func
 192               (list `(,(concat-symbol-pkg
 193                         :umlisp namestr) x))))
 194           (setq value-func (append value-func plain-value-func))
 195
 196           (if (eql type :cdata)
 197               (setq xmlvalue-func (append xmlvalue-func (list `(xml-cdata ,@plain-value-func))))
 198             (setq xmlvalue-func (append xmlvalue-func plain-value-func)))
 199           ))
 200
 201       (setq value-func `(lambda (x) (values ,@value-func)))
 202       (setq value-func (compile nil (eval value-func)))
 203       (setq xmlvalue-func `(lambda (x) (values ,@xmlvalue-func)))
 204       (setq xmlvalue-func (compile nil (eval xmlvalue-func)))
 205
 206       (setf (slot-value cl 'fmtstr-text) fmtstr-text)
 207       (setf (slot-value cl 'fmtstr-html) fmtstr-html)
 208       (setf (slot-value cl 'fmtstr-xml) fmtstr-xml)
 209       (setf (slot-value cl 'fmtstr-text-labels) fmtstr-text-labels)
 210       (setf (slot-value cl 'fmtstr-html-labels) fmtstr-html-labels)
 211       (setf (slot-value cl 'fmtstr-xml-labels) fmtstr-xml-labels)
 212       (setf (slot-value cl 'fmtstr-html-ref) fmtstr-html-ref)
 213       (setf (slot-value cl 'fmtstr-xml-ref) fmtstr-xml-ref)
 214       (setf (slot-value cl 'fmtstr-html-ref-labels) fmtstr-html-ref-labels)
 215       (setf (slot-value cl 'fmtstr-xml-ref-labels) fmtstr-xml-ref-labels)
 216       (setf (slot-value cl 'value-func) value-func)
 217       (setf (slot-value cl 'xmlvalue-func) xmlvalue-func))
 218     (values))
 219
 220
 221 (defun ml-class-fmtstr-text (obj)
 222   (slot-value (class-of obj) 'fmtstr-text))
 223
 224 (defun ml-class-fmtstr-html (obj)
 225   (slot-value (class-of obj) 'fmtstr-html))
 226
 227 (defun ml-class-fmtstr-xml (obj)
 228   (slot-value (class-of obj) 'fmtstr-xml))
 229
 230 (defun ml-class-fmtstr-text-labels (obj)
 231   (slot-value (class-of obj) 'fmtstr-text-labels))
 232
 233 (defun ml-class-fmtstr-html-labels (obj)
 234   (slot-value (class-of obj) 'fmtstr-html-labels))
 235
 236 (defun ml-class-fmtstr-xml-labels (obj)
 237   (slot-value (class-of obj) 'fmtstr-xml-labels))
 238
 239 (defun ml-class-value-func (obj)
 240   (slot-value (class-of obj) 'value-func))
 241
 242 (defun ml-class-xmlvalue-func (obj)
 243   (slot-value (class-of obj) 'xmlvalue-func))
 244
 245 (eval-when (:compile-toplevel :load-toplevel :execute)
 246 (defun ml-class-title (obj)
 247   (awhen (slot-value (class-of obj) 'title)
 248             (if (consp it)
 249                 (car it)
 250               it))))
 251
 252 (defun ml-class-subobjects-lists (obj)
 253   (slot-value (class-of obj) 'subobjects-lists))
 254
 255 (defun ml-class-ref-fields (obj)
 256   (slot-value (class-of obj) 'ref-fields))
 257
 258 (defun ml-class-fields (obj)
 259   (slot-value (class-of obj) 'fields))
 260
 261 (defun ml-class-fmtstr-html-ref (obj)
 262   (slot-value (class-of obj) 'fmtstr-html-ref))
 263
 264 (defun ml-class-fmtstr-xml-ref (obj)
 265   (slot-value (class-of obj) 'fmtstr-xml-ref))
 266
 267 (defun ml-class-fmtstr-html-ref-labels (obj)
 268   (slot-value (class-of obj) 'fmtstr-html-ref-labels))
 269
 270 (defun ml-class-fmtstr-xml-ref-labels (obj)
 271   (slot-value (class-of obj) 'fmtstr-xml-ref-labels))
 272
 273 ;;; Class name functions
 274
 275 (defmethod ml-class-stdname ((name string))
 276   (string-downcase (subseq name :start 1)))
 277
 278 (defmethod ml-class-stdname ((cl standard-object))
 279   (string-downcase (subseq (class-name (class-of cl)) :start 1)))
 280
 281 ;;;; Generic Print functions
 282
 283 (defparameter *default-textformat* nil)
 284 (defparameter *default-htmlformat* nil)
 285 (defparameter *default-htmlrefformat* nil)
 286 (defparameter *default-xmlformat* nil)
 287 (defparameter *default-xmlrefformat* nil)
 288 (defparameter *default-nullformat* nil)
 289 (defparameter *default-init-format?* nil)
 290
 291 (defun make-format-instance (fmt)
 292   (unless *default-init-format?*
 293     (setq *default-textformat* (make-instance 'textformat))
 294     (setq *default-htmlformat* (make-instance 'htmlformat))
 295     (setq *default-htmlrefformat* (make-instance 'htmlrefformat))
 296     (setq *default-xmlformat* (make-instance 'xmlformat))
 297     (setq *default-xmlrefformat* (make-instance 'xmlrefformat))
 298     (setq *default-nullformat* (make-instance 'nullformat))
 299     (setq *default-init-format?* t))
 300
 301   (case fmt
 302       (:text *default-textformat*)
 303       (:html *default-htmlformat*)
 304       (:htmlref *default-htmlrefformat*)
 305       (:xml  *default-xmlformat*)
 306       (:xmlref *default-xmlrefformat*)
 307       (:null *default-nullformat*)
 308       (otherwise *default-textformat*)))
 309
 310 ;;;; Output format classes for print ml-classes
 311
 312 (defclass dataformat ()
 313   ((file-start-str :type string :initarg :file-start-str :reader file-start-str)
 314    (file-end-str :type string :initarg :file-end-str :reader file-end-str)
 315    (list-start-fmtstr :type string :initarg :list-start-fmtstr :reader list-start-fmtstr)
 316    (list-start-value-func :type function :initarg :list-start-value-func :reader list-start-value-func)
 317    (list-start-indent :initarg :list-start-indent :reader list-start-indent)
 318    (list-end-fmtstr :type string :initarg :list-end-fmtstr :reader list-end-fmtstr)
 319    (list-end-value-func :type function :initarg :list-end-value-func :reader list-end-value-func)
 320    (list-end-indent :initarg :list-end-indent :reader list-end-indent)
 321    (obj-start-fmtstr :type string :initarg :obj-start-fmtstr :reader obj-start-fmtstr)
 322    (obj-start-value-func :initarg :obj-start-value-func :reader obj-start-value-func)
 323    (obj-start-indent :initarg :obj-start-indent :reader obj-start-indent)
 324    (obj-end-fmtstr :type string :initarg :obj-end-fmtstr :reader obj-end-fmtstr)
 325    (obj-end-value-func :initarg :obj-end-value-func :reader obj-end-value-func)
 326    (obj-end-indent :initarg :obj-end-indent :reader obj-end-indent)
 327    (obj-data-indent :initarg :obj-data-indent :reader obj-data-indent)
 328    (obj-data-fmtstr :initarg :obj-data-fmtstr :reader  obj-data-fmtstr)
 329    (obj-data-fmtstr-labels :initarg :obj-data-fmtstr-labels :reader  obj-data-fmtstr-labels)
 330    (obj-data-end-fmtstr :initarg :obj-data-end-fmtstr :reader obj-data-end-fmtstr)
 331    (obj-data-value-func :initarg :obj-data-value-func :reader obj-data-value-func)
 332    (link-ref :initarg :link-ref :reader link-ref))
 333   (:default-initargs :file-start-str nil :file-end-str nil :list-start-fmtstr nil :list-start-value-func nil
 334                      :list-start-indent nil :list-end-fmtstr nil :list-end-value-func nil :list-end-indent nil
 335                      :obj-start-fmtstr nil :obj-start-value-func nil :obj-start-indent nil
 336                      :obj-end-fmtstr nil :obj-end-value-func nil :obj-end-indent nil
 337                      :obj-data-indent nil :obj-data-fmtstr nil :obj-data-fmtstr-labels nil :obj-data-end-fmtstr nil
 338                      :obj-data-value-func nil :link-ref nil)
 339   (:documentation "Parent for all dataformat objects"))
 340
 341 (defclass binaryformat (dataformat)
 342   ())
 343
 344 (defclass nullformat (dataformat)
 345   ())
 346
 347 (defun text-list-start-value-func (obj nitems)
 348   (values (ml-class-title obj) nitems))
 349
 350 (defclass textformat (dataformat)
 351   ()
 352   (:default-initargs :list-start-fmtstr "~a~P:~%"
 353     :list-start-value-func #'text-list-start-value-func
 354     :list-start-indent t
 355     :obj-data-indent t
 356     :obj-data-fmtstr #'ml-class-fmtstr-text
 357     :obj-data-fmtstr-labels #'ml-class-fmtstr-text-labels
 358     :obj-data-end-fmtstr "~%"
 359     :obj-data-value-func #'ml-class-value-func))
 360
 361 (defclass htmlformat (textformat)
 362   ()
 363   (:default-initargs :file-start-str "<html><body>~%"
 364     :file-end-str "</body><html>~%"
 365     :list-start-indent t
 366     :list-start-fmtstr "<p><b>~a~P:</b></p><ul>~%"
 367     :list-start-value-func #'text-list-start-value-func
 368     :list-end-fmtstr "</ul>~%"
 369     :list-end-indent t
 370     :list-end-value-func #'identity
 371     :obj-start-indent t
 372     :obj-start-fmtstr "<li>"
 373     :obj-start-value-func #'identity
 374     :obj-end-indent  t
 375     :obj-end-fmtstr  "</li>~%"
 376     :obj-end-value-func #'identity
 377     :obj-data-indent t
 378     :obj-data-fmtstr #'ml-class-fmtstr-html-labels
 379     :obj-data-fmtstr-labels #'ml-class-fmtstr-html-labels
 380     :obj-data-value-func #'ml-class-value-func))
 381
 382
 383 (defun class-name-of (obj)
 384   (string-downcase (class-name (class-of obj))))
 385
 386 (defun xmlformat-list-end-value-func (x)
 387   (format nil "~alist" (string-downcase (class-name (class-of x)))))
 388
 389 (defun xmlformat-list-start-value-func (x nitems)
 390   (values (format nil "~alist" (string-downcase (class-name (class-of x)))) (ml-class-title x) nitems))
 391
 392 (defclass xmlformat (textformat)
 393   ()
 394   (:default-initargs :file-start-str "" ; (std-xml-header)
 395     :list-start-indent  t
 396     :list-start-fmtstr "<~a><title>~a~p:</title> ~%"
 397     :list-start-value-func #'xmlformat-list-start-value-func
 398     :list-end-indent  t
 399     :list-end-fmtstr "</~a>~%"
 400     :list-end-value-func #'xmlformat-list-end-value-func
 401     :obj-start-fmtstr "<~a>"
 402     :obj-start-value-func #'class-name-of
 403     :obj-start-indent t
 404     :obj-end-fmtstr "</~a>~%"
 405     :obj-end-value-func #'class-name-of
 406     :obj-end-indent nil
 407     :obj-data-indent nil
 408     :obj-data-fmtstr #'ml-class-fmtstr-xml
 409     :obj-data-fmtstr-labels #'ml-class-fmtstr-xml-labels
 410     :obj-data-value-func #'ml-class-xmlvalue-func))
 411
 412 (defclass link-ref ()
 413   ((fmtstr :type function :initarg :fmtstr :accessor fmtstr)
 414    (fmtstr-labels :type function :initarg :fmtstr-labels :accessor fmtstr-labels)
 415    (page-name :type string :initarg :page-name :accessor page-name)
 416    (href-head :type string :initarg :href-head :accessor href-head)
 417    (href-end :type string :initarg :href-end :accessor href-end)
 418    (ampersand :type string :initarg :ampersand :accessor ampersand))
 419   (:default-initargs :fmtstr nil
 420     :fmtstr-labels nil
 421     :page-name "disp-func1"
 422     :href-head nil :href-end nil :ampersand nil)
 423   (:documentation "Formatting for a linked reference"))
 424
 425 (defclass html-link-ref (link-ref)
 426   ()
 427   (:default-initargs :fmtstr #'ml-class-fmtstr-html-ref
 428     :fmtstr-labels #'ml-class-fmtstr-html-ref-labels
 429     :href-head "a href="
 430     :href-end "a"
 431     :ampersand "&"))
 432
 433 (defclass xml-link-ref (link-ref)
 434   ()
 435   (:default-initargs :fmtstr #'ml-class-fmtstr-xml-ref
 436     :fmtstr-labels #'ml-class-fmtstr-xml-ref-labels
 437     :href-head "xmllink xlink:type=\"simple\" xlink:href="
 438     :href-end "xmllink"
 439     :ampersand "&amp;"))
 440
 441
 442 (defclass htmlrefformat (htmlformat)
 443   ()
 444   (:default-initargs :link-ref (make-instance 'html-link-ref)))
 445
 446 (defclass xmlrefformat (xmlformat)
 447   ()
 448   (:default-initargs :link-ref (make-instance 'xml-link-ref)))
 449
 450
 451 ;;; File Start and Ends
 452
 453 (defmethod fmt-file-start ((fmt dataformat) (s stream)))
 454
 455 (defmethod fmt-file-start ((fmt textformat) (s stream))
 456   (aif (file-start-str fmt)
 457       (format s it)))
 458
 459 (defmethod fmt-file-end ((fmt textformat) (s stream))
 460   (aif (file-end-str fmt)
 461           (format s it)))
 462
 463 ;;; List Start and Ends
 464
 465 (defmethod fmt-list-start (x (fmt textformat) (s stream) &optional (indent 0) (num-items 1))
 466   (if (list-start-indent fmt)
 467       (indent-spaces indent s))
 468   (aif (list-start-fmtstr fmt)
 469           (apply #'format s it
 470                  (multiple-value-list
 471                   (funcall (list-start-value-func fmt) x num-items)))))
 472
 473 (defmethod fmt-list-end (x (fmt textformat) (s stream) &optional (indent 0) (num-items 1))
 474   (declare (ignore num-items))
 475   (if (list-end-indent fmt)
 476       (indent-spaces indent s))
 477   (aif (list-end-fmtstr fmt)
 478           (apply #'format s it
 479                  (multiple-value-list
 480                   (funcall (list-end-value-func fmt) x)))))
 481
 482 ;;; Object Start and Ends
 483
 484 (defmethod fmt-obj-start (x (fmt textformat) (s stream) &optional (indent 0))
 485   (if (obj-start-indent fmt)
 486       (indent-spaces indent s))
 487   (aif (obj-start-fmtstr fmt)
 488           (apply #'format s it
 489                  (multiple-value-list
 490                   (funcall (obj-start-value-func fmt) x)))))
 491
 492 (defmethod fmt-obj-end (x (fmt textformat) (s stream) &optional (indent 0))
 493   (if (obj-end-indent fmt)
 494       (indent-spaces indent s))
 495   (aif (obj-end-fmtstr fmt)
 496           (apply #'format s it
 497                  (multiple-value-list
 498                   (funcall (obj-end-value-func fmt) x)))))
 499
 500 ;;; Object Data
 501
 502 (defmethod make-link-start (obj (ref link-ref) fieldname fieldfunc fieldvalue refvars)
 503   (declare (ignore obj fieldname))
 504   (format nil "~a\"~a?func=~a~akey=~a~a\""
 505           (href-head ref) (make-url (page-name ref)) fieldfunc
 506           (ampersand ref) fieldvalue
 507           (if refvars
 508               (let ((varstr ""))
 509                 (dolist (var refvars)
 510                   (string-append varstr (format nil "~a~a=~a"
 511                                                 (ampersand ref) (car var) (cadr var))))
 512                 varstr)
 513             "")))
 514
 515 (defmethod make-link-end (obj (ref link-ref) fieldname)
 516   (declare (ignore obj fieldname))
 517   (format nil "~a" (href-end ref))
 518   )
 519
 520 (defmethod fmt-obj-data (x (fmt textformat) s
 521                          &optional (indent 0) (label nil) (refvars nil))
 522   (if (obj-data-indent fmt)
 523       (indent-spaces indent s))
 524   (if (link-ref fmt)
 525       (fmt-obj-data-with-ref x fmt s label refvars)
 526     (fmt-obj-data-plain x fmt s label))
 527   (aif (obj-data-end-fmtstr fmt)
 528        (format s it)))
 529
 530 (defmethod fmt-obj-data-plain (x (fmt textformat) s label)
 531   (if label
 532       (apply #'format s
 533              (funcall (obj-data-fmtstr-labels fmt) x)
 534              (multiple-value-list
 535               (funcall (funcall (obj-data-value-func fmt) x) x)))
 536     (apply #'format s (funcall (obj-data-fmtstr fmt) x)
 537            (multiple-value-list
 538             (funcall (funcall (obj-data-value-func fmt) x) x)))))
 539
 540 (defmethod fmt-obj-data-with-ref (x (fmt textformat) s label refvars)
 541   (let ((refstr (make-ref-data-str x fmt label))
 542         (refvalues nil)
 543         (field-values
 544          (multiple-value-list
 545           (funcall (funcall (obj-data-value-func fmt) x) x))))
 546
 547     ;; make list of reference link fields for printing to refstr template
 548     (dolist (field (ml-class-ref-fields x))
 549       (let ((link-start
 550              (make-link-start x (link-ref fmt) (car field) (cadr field)
 551                               (nth (position (car field) (ml-class-fields x) :key #'car) field-values)
 552                               (append (caddr field) refvars)))
 553             (link-end (make-link-end x (link-ref fmt) (car field))))
 554         (push link-start refvalues)
 555         (push link-end refvalues)))
 556     (setq refvalues (nreverse refvalues))
 557
 558     (apply #'format s refstr refvalues)))
 559
 560 (defmethod obj-data (x)
 561   "Returns the objects data as a string. Used by common-graphics outline function"
 562   (let ((fmt (make-format-instance :text)))
 563     (apply #'format nil (funcall (obj-data-fmtstr fmt) x)
 564            (multiple-value-list
 565             (funcall (funcall (obj-data-value-func fmt) x) x)))))
 566
 567 (defmethod make-ref-data-str (x (fmt textformat) &optional (label nil))
 568   "Return fmt string for that contains ~a slots for reference link start and end"
 569   (unless (link-ref fmt)
 570     (error "fmt does not contain a link-ref"))
 571   (let ((refstr
 572          (if label
 573              (apply #'format nil (funcall (fmtstr-labels (link-ref fmt)) x)
 574                     (multiple-value-list
 575                       (funcall (funcall (obj-data-value-func fmt) x) x)))
 576            (apply #'format nil (funcall (fmtstr (link-ref fmt)) x)
 577                   (multiple-value-list (funcall (funcall (obj-data-value-func fmt) x) x))))))
 578     refstr))
 579
 580 ;;; Display method for objects
 581
 582
 583 (defmethod load-all-subobjects (objs)
 584   "Load all subobjects if they have not already been loaded."
 585   (when objs
 586     (let ((objlist (mklist objs)))
 587       (dolist (obj objlist)
 588         (awhen (ml-class-subobjects-lists obj)  ;; access list of functions
 589           (dolist (child-obj it)   ;; for each child function
 590             (awhen (funcall (car child-obj) obj)
 591               (load-all-subobjects it))))))
 592     objs))
 593
 594 (defmethod output-ml-class (objs (fmt dataformat) (strm stream)
 595                             &optional (label nil) (english-only-function nil)
 596                                       (indent 0) (subobjects nil) (refvars nil))
 597   "Display a single or list of ml-class instances and their subobjects"
 598   (when objs
 599     (setq objs (mklist objs))
 600     (let ((nobjs (length objs)))
 601       (fmt-list-start (car objs) fmt strm indent nobjs)
 602       (dolist (obj objs)
 603         (unless (and english-only-function (not (funcall english-only-function obj)))
 604           (fmt-obj-start obj fmt strm indent)
 605           (fmt-obj-data obj fmt strm (1+ indent) label refvars)
 606           (if subobjects
 607               (awhen (ml-class-subobjects-lists obj)  ;; access list of functions
 608                         (dolist (child-obj it)   ;; for each child function
 609                           (awhen (funcall (car child-obj) obj) ;; access set of child objects
 610                                     (output-ml-class it fmt strm label
 611                                                      english-only-function
 612                                                      (1+ indent) subobjects refvars)))))
 613           (fmt-obj-end obj fmt strm indent)))
 614       (fmt-list-end (car objs) fmt strm indent nobjs))
 615     t))
 616
 617 (defun display-ml-class (objs &key (os *standard-output*) (format :text)
 618                                 (label nil) (english-only-function nil) (subobjects nil)
 619                                 (file-wrapper t) (refvars nil))
 620   "EXPORTED Function: displays a ml-class. Simplies call to output-ml-class"
 621   (let ((fmt (make-format-instance format)))
 622     (if file-wrapper
 623         (fmt-file-start fmt os))
 624     (when objs
 625       (output-ml-class objs fmt os label english-only-function 0 subobjects refvars))
 626     (if file-wrapper
 627         (fmt-file-end fmt os)))
 628   objs)