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