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.4 2002/10/10 16:23:48 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 (defclass htmlrefformat (htmlformat)
 383   ()
 384   (:default-initargs :link-ref (make-instance 'html-link-ref)))
 385
 386 (defun class-name-of (obj)
 387   (string-downcase (class-name (class-of obj))))
 388
 389 (defun xmlformat-list-end-value-func (x)
 390   (format nil "~alist" (string-downcase (class-name (class-of x)))))
 391
 392 (defun xmlformat-list-start-value-func (x nitems)
 393   (values (format nil "~alist" (string-downcase (class-name (class-of x)))) (ml-class-title x) nitems))
 394
 395 (defclass xmlformat (textformat)
 396   ()
 397   (:default-initargs :file-start-str "" ; (std-xml-header)
 398     :list-start-indent  t
 399     :list-start-fmtstr "<~a><title>~a~p:</title> ~%"
 400     :list-start-value-func #'xmlformat-list-start-value-func
 401     :list-end-indent  t
 402     :list-end-fmtstr "</~a>~%"
 403     :list-end-value-func #'xmlformat-list-end-value-func
 404     :obj-start-fmtstr "<~a>"
 405     :obj-start-value-func #'class-name-of
 406     :obj-start-indent t
 407     :obj-end-fmtstr "</~a>~%"
 408     :obj-end-value-func #'class-name-of
 409     :obj-end-indent nil
 410     :obj-data-indent nil
 411     :obj-data-fmtstr #'ml-class-fmtstr-xml
 412     :obj-data-fmtstr-labels #'ml-class-fmtstr-xml-labels
 413     :obj-data-value-func #'ml-class-xmlvalue-func))
 414
 415 (defclass xmlrefformat (xmlformat)
 416   ()
 417   (:default-initargs :link-ref (make-instance 'xml-link-ref)))
 418
 419 (defclass link-ref ()
 420   ((fmtstr :type function :initarg :fmtstr :accessor fmtstr)
 421    (fmtstr-labels :type function :initarg :fmtstr-labels :accessor fmtstr-labels)
 422    (page-name :type string :initarg :page-name :accessor page-name)
 423    (href-head :type string :initarg :href-head :accessor href-head)
 424    (href-end :type string :initarg :href-end :accessor href-end)
 425    (ampersand :type string :initarg :ampersand :accessor ampersand))
 426   (:default-initargs :fmtstr nil
 427     :fmtstr-labels nil
 428     :page-name "disp-func1"
 429     :href-head nil :href-end nil :ampersand nil)
 430   (:documentation "Formatting for a linked reference"))
 431
 432 (defclass html-link-ref (link-ref)
 433   ()
 434   (:default-initargs :fmtstr #'ml-class-fmtstr-html-ref
 435     :fmtstr-labels #'ml-class-fmtstr-html-ref-labels
 436     :href-head "a href="
 437     :href-end "a"
 438     :ampersand "&"))
 439
 440 (defclass xml-link-ref (link-ref)
 441   ()
 442   (:default-initargs :fmtstr #'ml-class-fmtstr-xml-ref
 443     :fmtstr-labels #'ml-class-fmtstr-xml-ref-labels
 444     :href-head "xmllink xlink:type=\"simple\" xlink:href="
 445     :href-end "xmllink"
 446     :ampersand "&amp;"))
 447
 448
 449 ;;; File Start and Ends
 450
 451 (defmethod fmt-file-start ((fmt dataformat) (s stream)))
 452
 453 (defmethod fmt-file-start ((fmt textformat) (s stream))
 454   (aif (file-start-str fmt)
 455       (format s it)))
 456
 457 (defmethod fmt-file-end ((fmt textformat) (s stream))
 458   (aif (file-end-str fmt)
 459           (format s it)))
 460
 461 ;;; List Start and Ends
 462
 463 (defmethod fmt-list-start (x (fmt textformat) (s stream) &optional (indent 0) (num-items 1))
 464   (if (list-start-indent fmt)
 465       (indent-spaces indent s))
 466   (aif (list-start-fmtstr fmt)
 467           (apply #'format s it
 468                  (multiple-value-list
 469                   (funcall (list-start-value-func fmt) x num-items)))))
 470
 471 (defmethod fmt-list-end (x (fmt textformat) (s stream) &optional (indent 0) (num-items 1))
 472   (declare (ignore num-items))
 473   (if (list-end-indent fmt)
 474       (indent-spaces indent s))
 475   (aif (list-end-fmtstr fmt)
 476           (apply #'format s it
 477                  (multiple-value-list
 478                   (funcall (list-end-value-func fmt) x)))))
 479
 480 ;;; Object Start and Ends
 481
 482 (defmethod fmt-obj-start (x (fmt textformat) (s stream) &optional (indent 0))
 483   (if (obj-start-indent fmt)
 484       (indent-spaces indent s))
 485   (aif (obj-start-fmtstr fmt)
 486           (apply #'format s it
 487                  (multiple-value-list
 488                   (funcall (obj-start-value-func fmt) x)))))
 489
 490 (defmethod fmt-obj-end (x (fmt textformat) (s stream) &optional (indent 0))
 491   (if (obj-end-indent fmt)
 492       (indent-spaces indent s))
 493   (aif (obj-end-fmtstr fmt)
 494           (apply #'format s it
 495                  (multiple-value-list
 496                   (funcall (obj-end-value-func fmt) x)))))
 497
 498 ;;; Object Data
 499
 500 (defmethod make-link-start (obj (ref link-ref) fieldname fieldfunc fieldvalue refvars)
 501   (declare (ignore obj fieldname))
 502   (format nil "~a\"~a?func=~a~akey=~a~a\""
 503           (href-head ref) (make-url (page-name ref)) fieldfunc
 504           (ampersand ref) fieldvalue
 505           (if refvars
 506               (let ((varstr ""))
 507                 (dolist (var refvars)
 508                   (string-append varstr (format nil "~a~a=~a"
 509                                                 (ampersand ref) (car var) (cadr var))))
 510                 varstr)
 511             "")))
 512
 513 (defmethod make-link-end (obj (ref link-ref) fieldname)
 514   (declare (ignore obj fieldname))
 515   (format nil "~a" (href-end ref))
 516   )
 517
 518 (defmethod fmt-obj-data (x (fmt textformat) s
 519                          &optional (indent 0) (label nil) (refvars nil))
 520   (if (obj-data-indent fmt)
 521       (indent-spaces indent s))
 522   (if (link-ref fmt)
 523       (fmt-obj-data-with-ref x fmt s label refvars)
 524     (fmt-obj-data-plain x fmt s label))
 525   (aif (obj-data-end-fmtstr fmt)
 526        (format s it)))
 527
 528 (defmethod fmt-obj-data-plain (x (fmt textformat) s label)
 529   (if label
 530       (apply #'format s
 531              (funcall (obj-data-fmtstr-labels fmt) x)
 532              (multiple-value-list
 533               (funcall (funcall (obj-data-value-func fmt) x) x)))
 534     (apply #'format s (funcall (obj-data-fmtstr fmt) x)
 535            (multiple-value-list
 536             (funcall (funcall (obj-data-value-func fmt) x) x)))))
 537
 538 (defmethod fmt-obj-data-with-ref (x (fmt textformat) s label refvars)
 539   (let ((refstr (make-ref-data-str x fmt label))
 540         (refvalues nil)
 541         (field-values
 542          (multiple-value-list
 543           (funcall (funcall (obj-data-value-func fmt) x) x))))
 544
 545     ;; make list of reference link fields for printing to refstr template
 546     (dolist (field (ml-class-ref-fields x))
 547       (let ((link-start
 548              (make-link-start x (link-ref fmt) (car field) (cadr field)
 549                               (nth (position (car field) (ml-class-fields x) :key #'car) field-values)
 550                               (append (caddr field) refvars)))
 551             (link-end (make-link-end x (link-ref fmt) (car field))))
 552         (push link-start refvalues)
 553         (push link-end refvalues)))
 554     (setq refvalues (nreverse refvalues))
 555
 556     (apply #'format s refstr refvalues)))
 557
 558 (defmethod obj-data (x)
 559   "Returns the objects data as a string. Used by common-graphics outline function"
 560   (let ((fmt (make-format-instance :text)))
 561     (apply #'format nil (funcall (obj-data-fmtstr fmt) x)
 562            (multiple-value-list
 563             (funcall (funcall (obj-data-value-func fmt) x) x)))))
 564
 565 (defmethod make-ref-data-str (x (fmt textformat) &optional (label nil))
 566   "Return fmt string for that contains ~a slots for reference link start and end"
 567   (unless (link-ref fmt)
 568     (error "fmt does not contain a link-ref"))
 569   (let ((refstr
 570          (if label
 571              (apply #'format nil (funcall (fmtstr-labels (link-ref fmt)) x)
 572                     (multiple-value-list
 573                       (funcall (funcall (obj-data-value-func fmt) x) x)))
 574            (apply #'format nil (funcall (fmtstr (link-ref fmt)) x)
 575                   (multiple-value-list (funcall (funcall (obj-data-value-func fmt) x) x))))))
 576     refstr))
 577
 578 ;;; Display method for objects
 579
 580
 581 (defmethod load-all-subobjects (objs)
 582   "Load all subobjects if they have not already been loaded."
 583   (when objs
 584     (let ((objlist (mklist objs)))
 585       (dolist (obj objlist)
 586         (awhen (ml-class-subobjects-lists obj)  ;; access list of functions
 587           (dolist (child-obj it)   ;; for each child function
 588             (awhen (funcall (car child-obj) obj)
 589               (load-all-subobjects it))))))
 590     objs))
 591
 592 (defmethod output-ml-class (objs (fmt dataformat) (strm stream)
 593                             &optional (label nil) (english-only-function nil)
 594                                       (indent 0) (subobjects nil) (refvars nil))
 595   "Display a single or list of ml-class instances and their subobjects"
 596   (when objs
 597     (setq objs (mklist objs))
 598     (let ((nobjs (length objs)))
 599       (fmt-list-start (car objs) fmt strm indent nobjs)
 600       (dolist (obj objs)
 601         (unless (and english-only-function (not (funcall english-only-function obj)))
 602           (fmt-obj-start obj fmt strm indent)
 603           (fmt-obj-data obj fmt strm (1+ indent) label refvars)
 604           (if subobjects
 605               (awhen (ml-class-subobjects-lists obj)  ;; access list of functions
 606                         (dolist (child-obj it)   ;; for each child function
 607                           (awhen (funcall (car child-obj) obj) ;; access set of child objects
 608                                     (output-ml-class it fmt strm label
 609                                                      english-only-function
 610                                                      (1+ indent) subobjects refvars)))))
 611           (fmt-obj-end obj fmt strm indent)))
 612       (fmt-list-end (car objs) fmt strm indent nobjs))
 613     t))
 614
 615 (defun display-ml-class (objs &key (os *standard-output*) (format :text)
 616                                 (label nil) (english-only-function nil) (subobjects nil)
 617                                 (file-wrapper t) (refvars nil))
 618   "EXPORTED Function: displays a ml-class. Simplies call to output-ml-class"
 619   (let ((fmt (make-format-instance format)))
 620     (if file-wrapper
 621         (fmt-file-start fmt os))
 622     (when objs
 623       (output-ml-class objs fmt os label english-only-function 0 subobjects refvars))
 624     (if file-wrapper
 625         (fmt-file-end fmt os)))
 626   objs)