From 8127923e06a01790d883aefd282db6c0419c484a Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Thu, 17 Oct 2002 00:25:05 +0000 Subject: [PATCH] r3079: *** empty log message *** --- debian/changelog | 2 +- kmrcl.asd | 4 +- ml-class.lisp | 26 +- ml.lisp | 637 ----------------------------------------------- 4 files changed, 11 insertions(+), 658 deletions(-) delete mode 100644 ml.lisp diff --git a/debian/changelog b/debian/changelog index efce163..7aee101 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,7 +1,7 @@ cl-kmrcl (1.13-1) unstable; urgency=low * ml-class.lisp: Add ie-xmlrefformat for Internet Explorer's idea of - a link in XML. + a link in XML. Add SCL compatibility. -- Kevin M. Rosenberg Tue, 15 Oct 2002 23:23:57 -0600 diff --git a/kmrcl.asd b/kmrcl.asd index 0170371..a0aa8e3 100644 --- a/kmrcl.asd +++ b/kmrcl.asd @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: kmrcl.asd,v 1.12 2002/10/15 23:10:58 kevin Exp $ +;;;; $Id: kmrcl.asd,v 1.13 2002/10/17 00:25:05 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -38,7 +38,7 @@ #+allegro (:file "attrib-class" :depends-on ("package")) (:file "web-utils" :depends-on ("package")) (:file "xml-utils" :depends-on ("package")) - #+(or allegro lispworks cmu sbcl) (:file "ml-class" :depends-on ("strings" "genutils")) + #+(or allegro lispworks cmu sbcl scl) (:file "ml-class" :depends-on ("strings" "genutils")) #+(or allegro aserve) (:file "web-utils-aserve" :depends-on ("strings" "genutils")) )) diff --git a/ml-class.lisp b/ml-class.lisp index 902c1c1..39878fa 100644 --- a/ml-class.lisp +++ b/ml-class.lisp @@ -11,7 +11,7 @@ ;;;; in Text, HTML, and XML formats. This includes hyperlinking ;;;; capability and sub-objects. ;;;; -;;;; $Id: ml-class.lisp,v 1.19 2002/10/16 23:34:33 kevin Exp $ +;;;; $Id: ml-class.lisp,v 1.20 2002/10/17 00:25:05 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -25,17 +25,17 @@ (declaim (optimize (speed 3) (safety 1))) (defun ml-class-of (obj) - #-(or cmu sbcl) (class-of obj) + #-(or cmu sbcl scl) (class-of obj) #+sbcl (sb-pcl:class-of obj) - #+cmu (pcl:class-of obj)) + #+(or cmu scl) (pcl:class-of obj)) (defun ml-class-name (obj) - #-(or cmu sbcl) (class-name obj) + #-(or cmu sbcl scl) (class-name obj) #+sbcl (sb-pcl:class-name obj) - #+cmu (pcl:class-name obj)) + #+(or cmu scl) (pcl:class-name obj)) (defclass ml-class (#-(or cmu sbcl) standard-class - #+cmu pcl::standard-class + #+(or cmu scl) pcl::standard-class #+sbcl sb-pcl::standard-class) ((title :initarg :title :type string :reader ml-std-title :documentation @@ -72,7 +72,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (:default-initargs :title nil :fields nil :subobjects-lists nil :ref-fields nil) (:documentation "Metaclass for Markup Language classes.")) -#+cmu +#+(or cmu scl) (defmethod pcl:finalize-inheritance :after ((cl ml-class)) (init-ml-class cl)) @@ -82,7 +82,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (init-ml-class cl)) -#+cmu +#+(or cmu slc) (defmethod pcl:validate-superclass ((class ml-class) (superclass pcl::standard-class)) t) @@ -98,16 +98,6 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (defmethod clos:finalize-inheritance :after ((cl ml-class)) (init-ml-class cl)) -;;#+cmu -;;(defmethod pcl::class-finalized-p ((cl ml-class)) -;; (and (not (null (slot-value cl 'pcl::wrapper))) -;; (not (null (slot-value cl 'fmtstr-text))))) - -;;#+sbcl -;;(defmethod sb-pcl::class-finalized-p ((cl ml-class)) -;; (and (not (null (slot-value cl 'sb-pcl::wrapper))) -;; (not (null (slot-value cl 'fmtstr-text))))) - #+lispworks (defmethod clos:process-a-class-option ((class ml-class) (name (eql :title)) diff --git a/ml.lisp b/ml.lisp deleted file mode 100644 index 4d854bd..0000000 --- a/ml.lisp +++ /dev/null @@ -1,637 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: ml.lisp -;;;; Purpose: Markup Language Class -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Sep 2002 -;;;; -;;;; This class defines functions for classes to allow display -;;;; in Text, HTML, and XML formats. This includes hyperlinking -;;;; capability and sub-objects. This is a re-write of ml-class.lisp -;;; which used fairly difficult to port metaclass features. -;;;; -;;;; $Id: ml.lisp,v 1.2 2002/10/13 19:02:35 kevin Exp $ -;;;; -;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; KMRCL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(defpackage :kmrcl.ml - (:use #:kmrcl #:common-lisp)) - - -(in-package :kmrcl.ml) - -(declaim (optimize (speed 3) (safety 1) (debug 3) (compilation-speed 0))) - -;;; Design: -;;; ml-class hold all formatting information for an object -;;; -;;; When a class is definited with the def-ml-class macro, a formatting -;;; object named _-ml-fmt_ is created. Then, when a ml-class object -;;; is to be printed, the formatting object is referenced. - -(defun initargs-def (fields) - (loop for field in fields - collect (intern (concatenate 'string ":" (symbol-name (car field)))) - collect nil)) - -(defun ml-fmt-name (name) - (intern (concatenate 'string "_" (symbol-name name) "-ml-fmt_"))) - -(defun ml-fmt-def (name field-defs title types linked-fields subobjects) - `(progn - (defclass ,(ml-fmt-name name) (ml-fmt-class) - () - (:default-initargs ,@(ml-fmt-initargs name field-defs title types linked-fields subobjects))) - (make-instance ,(ml-fmt-name name)))) - -(defmacro def-ml-class (name (parent) field-defs &key title types linked-fields subobjects documentation) - (let ((ml-fmt-name (ml-fmt-name name)) - (ml-fmt-def (ml-fmt-def name field-defs title types linked-fields subobjects)) - (initargs (initargs-def field-defs))) - `(progn - ,ml-fmt-def - - (defclass ,name (,parent) - ,field-defs - (:default-initargs ,initargs) - ,@(and documentation (list (list :documentation documentation))) - ) - ))) - -#+ignore -(def-ml-class urank (umlsclass) - ((rank :type fixnum :initarg :rank :reader rank) - (sab :type string :initarg :sab :reader sab) - (tty :type string :initarg :tty :reader tty) - (supres :type string :initarg :supres :reader supres)) - :title "Rank" - :types ((rank :fixnum) (sab :string) (tty :string) (supres :string))) - - - -(defclass ml-fmt-class () - ((title :initarg :title :type string :reader title - :documentation -"Print Title for class") - (fields :initarg :fields :reader fields - :documentation -"List of field lists for printing. Format is - ((fieldname type optional-formatter) ... )") - (subobjects-lists - :initarg :subobjects-lists :reader subobjects-lists - :documentation -"List of fields that contain a list of subobjects objects.") - (ref-fields - :initarg :ref-fields :type list :reader ref-field - :documentation - "List of fields that can be referred to by browsers. -Format is ((field-name field-lookup-func other-link-params) ...)") - - ;;; The remainder of these fields are calculated one time - ;;; in finalize-inheritence. - (value-func :initform nil :type function :reader value-func) - (xmlvalue-func :initform nil :type function :reader xmlvalue-func) - (fmtstr-text :initform nil :type string :reader fmtstr-text) - (fmtstr-html :initform nil :type string :reader fmtstr-html) - (fmtstr-xml :initform nil :type string :reader fmtstr-xml) - (fmtstr-text-labels :initform nil :type string :reader fmtstr-text-labels) - (fmtstr-html-labels :initform nil :type string :reader fmtstr-html-labels) - (fmtstr-xml-labels :initform nil :type string :reader fmtstr-xml-labels) - (fmtstr-html-ref :initform nil :type string :reader fmtstr-html-ref) - (fmtstr-xml-ref :initform nil :type string :reader fmtstr-xml-ref) - (fmtstr-html-ref-labels :initform nil :type string :reader fmtstr-html-ref-labels) - (fmtstr-xml-ref-labels :initform nil :type string :reader fmtstr-xml-ref-labels) - ) - (:default-initargs :title nil :fields nil :subobjects-lists nil :ref-fields nil) - (:documentation "Class for Markup Language formatting objects.")) - - -;;;; Class initialization function - -(defun ml-fmt-initargs (name field-defs title types linked-fields subobjects) - (let ((fmtstr-text "") - (fmtstr-html "") - (fmtstr-xml "") - (fmtstr-text-labels "") - (fmtstr-html-labels "") - (fmtstr-xml-labels "") - (fmtstr-html-ref "") - (fmtstr-xml-ref "") - (fmtstr-html-ref-labels "") - (fmtstr-xml-ref-labels "") - (first-field t) - (value-func '()) - (xmlvalue-func '()) - (classname name) - (linked-fields linked-fields)) - (declare (ignore classname)) - (dolist (f fields) - (let ((name (car f)) - (namestr (symbol-name (car f))) - (namestr-lower (string-downcase (symbol-name (car f)))) - (type (cadr f)) - (formatter (caddr f)) - (value-fmt "~a") - (plain-value-func nil) - html-str xml-str html-label-str xml-label-str) - - (when (or (eql type :integer) (eql type :fixnum)) - (setq value-fmt "~d")) - - (when (eql type :commainteger) - (setq value-fmt "~:d")) - - (when (eql type :boolean) - (setq value-fmt "~a")) - - (if first-field - (setq first-field nil) - (progn - (string-append fmtstr-text " ") - (string-append fmtstr-html " ") - (string-append fmtstr-xml " ") - (string-append fmtstr-text-labels " ") - (string-append fmtstr-html-labels " ") - (string-append fmtstr-xml-labels " ") - (string-append fmtstr-html-ref " ") - (string-append fmtstr-xml-ref " ") - (string-append fmtstr-html-ref-labels " ") - (string-append fmtstr-xml-ref-labels " "))) - - (setq html-str value-fmt) - (setq xml-str (concatenate 'string "<" namestr-lower ">" value-fmt "")) - (setq html-label-str (concatenate 'string "" namestr-lower " " value-fmt)) - (setq xml-label-str (concatenate 'string " <" namestr-lower ">" value-fmt "")) - - (string-append fmtstr-text value-fmt) - (string-append fmtstr-html html-str) - (string-append fmtstr-xml xml-str) - (string-append fmtstr-text-labels namestr-lower " " value-fmt) - (string-append fmtstr-html-labels html-label-str) - (string-append fmtstr-xml-labels xml-label-str) - - (if (find name linked-fields :key #'car) - (progn - (string-append fmtstr-html-ref "<~~a>" value-fmt "") - (string-append fmtstr-xml-ref "<~~a>" value-fmt "") - (string-append fmtstr-html-ref-labels "" namestr-lower " <~~a>" value-fmt "") - (string-append fmtstr-xml-ref-labels " <~~a>" value-fmt "")) - (progn - (string-append fmtstr-html-ref html-str) - (string-append fmtstr-xml-ref xml-str) - (string-append fmtstr-html-ref-labels html-label-str) - (string-append fmtstr-xml-ref-labels xml-label-str))) - - (if formatter - (setq plain-value-func - (list `(,formatter (,(concat-symbol-pkg - :umlisp namestr) x)))) - (setq plain-value-func - (list `(,(concat-symbol-pkg - :umlisp namestr) x)))) - (setq value-func (append value-func plain-value-func)) - - (if (eql type :cdata) - (setq xmlvalue-func (append xmlvalue-func (list `(xml-cdata ,@plain-value-func)))) - (setq xmlvalue-func (append xmlvalue-func plain-value-func))) - )) - - (setq value-func `(lambda (x) (values ,@value-func))) - (setq value-func (compile nil (eval value-func))) - (setq xmlvalue-func `(lambda (x) (values ,@xmlvalue-func))) - (setq xmlvalue-func (compile nil (eval xmlvalue-func))) - - `(:title ,title - :fmtstr-text ,fmtstr-text :fmtstr-html ,fmtstr-html - :fmtstr-xml ,fmtstr-xml :fmtstr-text-labels ,fmtstr-text-labels - :fmtstr-html-labels ,fmtstr-html-labels - :fmtstr-xml-labels ,fmtstr-xml-labels - :fmtstr-html-ref ,fmtstr-html-ref - :fmtstr-xml-ref ,fmtstr-xml-ref - :fmtstr-html-ref-labels ,fmtstr-html-ref-labels - :fmtstr-xml-ref-labels ,fmtstr-xml-ref-labels - :value-func ,value-func - :xmlvalue-func ,xmlvalue-func))) - - -(defun %class-of (obj) - #-(or cmu sbcl) (class-of obj) - #+sbcl (sb-pcl:class-of obj) - #+cmu (pcl:class-of obj)) - - -(defun ml-class-fmtstr-text (obj) - (slot-value (%class-of obj) 'fmtstr-text)) - -(defun ml-class-fmtstr-html (obj) - (slot-value (%class-of obj) 'fmtstr-html)) - -(defun ml-class-fmtstr-xml (obj) - (slot-value (%class-of obj) 'fmtstr-xml)) - -(defun ml-class-fmtstr-text-labels (obj) - (slot-value (%class-of obj) 'fmtstr-text-labels)) - -(defun ml-class-fmtstr-html-labels (obj) - (slot-value (%class-of obj) 'fmtstr-html-labels)) - -(defun ml-class-fmtstr-xml-labels (obj) - (slot-value (%class-of obj) 'fmtstr-xml-labels)) - -(defun ml-class-value-func (obj) - (slot-value (%class-of obj) 'value-func)) - -(defun ml-class-xmlvalue-func (obj) - (slot-value (%class-of obj) 'xmlvalue-func)) - -(eval-when (:compile-toplevel :load-toplevel :execute) -(defun ml-class-title (obj) - (awhen (slot-value (%class-of obj) 'title) - (if (consp it) - (car it) - it)))) - -(defun ml-class-subobjects-lists (obj) - (slot-value (%class-of obj) 'subobjects-lists)) - -(defun ml-class-linked-fields (obj) - (slot-value (%class-of obj) 'linked-fields)) - -(defun ml-class-fields (obj) - (slot-value (%class-of obj) 'fields)) - -(defun ml-class-fmtstr-html-ref (obj) - (slot-value (%class-of obj) 'fmtstr-html-ref)) - -(defun ml-class-fmtstr-xml-ref (obj) - (slot-value (%class-of obj) 'fmtstr-xml-ref)) - -(defun ml-class-fmtstr-html-ref-labels (obj) - (slot-value (%class-of obj) 'fmtstr-html-ref-labels)) - -(defun ml-class-fmtstr-xml-ref-labels (obj) - (slot-value (%class-of obj) 'fmtstr-xml-ref-labels)) - -;;; Class name functions - -(defmethod ml-class-stdname ((name string)) - (string-downcase (subseq name :start 1))) - -(defmethod ml-class-stdname ((cl standard-object)) - (string-downcase (subseq (class-name (%class-of cl)) :start 1))) - -;;;; Generic Print functions - -(defparameter *default-textformat* nil) -(defparameter *default-htmlformat* nil) -(defparameter *default-htmlrefformat* nil) -(defparameter *default-xmlformat* nil) -(defparameter *default-xmlrefformat* nil) -(defparameter *default-nullformat* nil) -(defparameter *default-init-format?* nil) - -(defun make-format-instance (fmt) - (unless *default-init-format?* - (setq *default-textformat* (make-instance 'textformat)) - (setq *default-htmlformat* (make-instance 'htmlformat)) - (setq *default-htmlrefformat* (make-instance 'htmlrefformat)) - (setq *default-xmlformat* (make-instance 'xmlformat)) - (setq *default-xmlrefformat* (make-instance 'xmlrefformat)) - (setq *default-nullformat* (make-instance 'nullformat)) - (setq *default-init-format?* t)) - - (case fmt - (:text *default-textformat*) - (:html *default-htmlformat*) - (:htmlref *default-htmlrefformat*) - (:xml *default-xmlformat*) - (:xmlref *default-xmlrefformat*) - (:null *default-nullformat*) - (otherwise *default-textformat*))) - -;;;; Output format classes for print ml-classes - -(defclass dataformat () - ((file-start-str :type string :initarg :file-start-str :reader file-start-str) - (file-end-str :type string :initarg :file-end-str :reader file-end-str) - (list-start-fmtstr :type string :initarg :list-start-fmtstr :reader list-start-fmtstr) - (list-start-value-func :type function :initarg :list-start-value-func :reader list-start-value-func) - (list-start-indent :initarg :list-start-indent :reader list-start-indent) - (list-end-fmtstr :type string :initarg :list-end-fmtstr :reader list-end-fmtstr) - (list-end-value-func :type function :initarg :list-end-value-func :reader list-end-value-func) - (list-end-indent :initarg :list-end-indent :reader list-end-indent) - (obj-start-fmtstr :type string :initarg :obj-start-fmtstr :reader obj-start-fmtstr) - (obj-start-value-func :initarg :obj-start-value-func :reader obj-start-value-func) - (obj-start-indent :initarg :obj-start-indent :reader obj-start-indent) - (obj-end-fmtstr :type string :initarg :obj-end-fmtstr :reader obj-end-fmtstr) - (obj-end-value-func :initarg :obj-end-value-func :reader obj-end-value-func) - (obj-end-indent :initarg :obj-end-indent :reader obj-end-indent) - (obj-data-indent :initarg :obj-data-indent :reader obj-data-indent) - (obj-data-fmtstr :initarg :obj-data-fmtstr :reader obj-data-fmtstr) - (obj-data-fmtstr-labels :initarg :obj-data-fmtstr-labels :reader obj-data-fmtstr-labels) - (obj-data-end-fmtstr :initarg :obj-data-end-fmtstr :reader obj-data-end-fmtstr) - (obj-data-value-func :initarg :obj-data-value-func :reader obj-data-value-func) - (link-ref :initarg :link-ref :reader link-ref)) - (:default-initargs :file-start-str nil :file-end-str nil :list-start-fmtstr nil :list-start-value-func nil - :list-start-indent nil :list-end-fmtstr nil :list-end-value-func nil :list-end-indent nil - :obj-start-fmtstr nil :obj-start-value-func nil :obj-start-indent nil - :obj-end-fmtstr nil :obj-end-value-func nil :obj-end-indent nil - :obj-data-indent nil :obj-data-fmtstr nil :obj-data-fmtstr-labels nil :obj-data-end-fmtstr nil - :obj-data-value-func nil :link-ref nil) - (:documentation "Parent for all dataformat objects")) - -(defclass binaryformat (dataformat) - ()) - -(defclass nullformat (dataformat) - ()) - -(defun text-list-start-value-func (obj nitems) - (values (ml-class-title obj) nitems)) - -(defclass textformat (dataformat) - () - (:default-initargs :list-start-fmtstr "~a~P:~%" - :list-start-value-func #'text-list-start-value-func - :list-start-indent t - :obj-data-indent t - :obj-data-fmtstr #'ml-class-fmtstr-text - :obj-data-fmtstr-labels #'ml-class-fmtstr-text-labels - :obj-data-end-fmtstr "~%" - :obj-data-value-func #'ml-class-value-func)) - -(defclass htmlformat (textformat) - () - (:default-initargs :file-start-str "~%" - :file-end-str "~%" - :list-start-indent t - :list-start-fmtstr "

~a~P:

    ~%" - :list-start-value-func #'text-list-start-value-func - :list-end-fmtstr "
~%" - :list-end-indent t - :list-end-value-func #'identity - :obj-start-indent t - :obj-start-fmtstr "
  • " - :obj-start-value-func #'identity - :obj-end-indent t - :obj-end-fmtstr "
    • ~%" - :obj-end-value-func #'identity - :obj-data-indent t - :obj-data-fmtstr #'ml-class-fmtstr-html-labels - :obj-data-fmtstr-labels #'ml-class-fmtstr-html-labels - :obj-data-value-func #'ml-class-value-func)) - - -(defun class-name-of (obj) - (string-downcase (class-name (%class-of obj)))) - -(defun xmlformat-list-end-value-func (x) - (format nil "~alist" (string-downcase (class-name (%class-of x))))) - -(defun xmlformat-list-start-value-func (x nitems) - (values (format nil "~alist" (string-downcase (class-name (%class-of x)))) (ml-class-title x) nitems)) - -(defclass xmlformat (textformat) - () - (:default-initargs :file-start-str "" ; (std-xml-header) - :list-start-indent t - :list-start-fmtstr "<~a>~a~p: ~%" - :list-start-value-func #'xmlformat-list-start-value-func - :list-end-indent t - :list-end-fmtstr "~%" - :list-end-value-func #'xmlformat-list-end-value-func - :obj-start-fmtstr "<~a>" - :obj-start-value-func #'class-name-of - :obj-start-indent t - :obj-end-fmtstr "~%" - :obj-end-value-func #'class-name-of - :obj-end-indent nil - :obj-data-indent nil - :obj-data-fmtstr #'ml-class-fmtstr-xml - :obj-data-fmtstr-labels #'ml-class-fmtstr-xml-labels - :obj-data-value-func #'ml-class-xmlvalue-func)) - -(defclass link-ref () - ((fmtstr :type function :initarg :fmtstr :accessor fmtstr) - (fmtstr-labels :type function :initarg :fmtstr-labels :accessor fmtstr-labels) - (page-name :type string :initarg :page-name :accessor page-name) - (href-head :type string :initarg :href-head :accessor href-head) - (href-end :type string :initarg :href-end :accessor href-end) - (ampersand :type string :initarg :ampersand :accessor ampersand)) - (:default-initargs :fmtstr nil - :fmtstr-labels nil - :page-name "disp-func1" - :href-head nil :href-end nil :ampersand nil) - (:documentation "Formatting for a linked reference")) - -(defclass html-link-ref (link-ref) - () - (:default-initargs :fmtstr #'ml-class-fmtstr-html-ref - :fmtstr-labels #'ml-class-fmtstr-html-ref-labels - :href-head "a href=" - :href-end "a" - :ampersand "&")) - -(defclass xml-link-ref (link-ref) - () - (:default-initargs :fmtstr #'ml-class-fmtstr-xml-ref - :fmtstr-labels #'ml-class-fmtstr-xml-ref-labels - :href-head "xmllink xlink:type=\"simple\" xlink:href=" - :href-end "xmllink" - :ampersand "&")) - - -(defclass htmlrefformat (htmlformat) - () - (:default-initargs :link-ref (make-instance 'html-link-ref))) - -(defclass xmlrefformat (xmlformat) - () - (:default-initargs :link-ref (make-instance 'xml-link-ref))) - - -;;; File Start and Ends - -(defmethod fmt-file-start ((fmt dataformat) (s stream))) - -(defmethod fmt-file-start ((fmt textformat) (s stream)) - (aif (file-start-str fmt) - (format s it))) - -(defmethod fmt-file-end ((fmt textformat) (s stream)) - (aif (file-end-str fmt) - (format s it))) - -;;; List Start and Ends - -(defmethod fmt-list-start (x (fmt textformat) (s stream) &optional (indent 0) (num-items 1)) - (if (list-start-indent fmt) - (indent-spaces indent s)) - (aif (list-start-fmtstr fmt) - (apply #'format s it - (multiple-value-list - (funcall (list-start-value-func fmt) x num-items))))) - -(defmethod fmt-list-end (x (fmt textformat) (s stream) &optional (indent 0) (num-items 1)) - (declare (ignore num-items)) - (if (list-end-indent fmt) - (indent-spaces indent s)) - (aif (list-end-fmtstr fmt) - (apply #'format s it - (multiple-value-list - (funcall (list-end-value-func fmt) x))))) - -;;; Object Start and Ends - -(defmethod fmt-obj-start (x (fmt textformat) (s stream) &optional (indent 0)) - (if (obj-start-indent fmt) - (indent-spaces indent s)) - (aif (obj-start-fmtstr fmt) - (apply #'format s it - (multiple-value-list - (funcall (obj-start-value-func fmt) x))))) - -(defmethod fmt-obj-end (x (fmt textformat) (s stream) &optional (indent 0)) - (if (obj-end-indent fmt) - (indent-spaces indent s)) - (aif (obj-end-fmtstr fmt) - (apply #'format s it - (multiple-value-list - (funcall (obj-end-value-func fmt) x))))) - -;;; Object Data - -(defmethod make-link-start (obj (ref link-ref) fieldname fieldfunc fieldvalue refvars) - (declare (ignore obj fieldname)) - (format nil "~a\"~a?func=~a~akey=~a~a\"" - (href-head ref) (make-url (page-name ref)) fieldfunc - (ampersand ref) fieldvalue - (if refvars - (let ((varstr "")) - (dolist (var refvars) - (string-append varstr (format nil "~a~a=~a" - (ampersand ref) (car var) (cadr var)))) - varstr) - ""))) - -(defmethod make-link-end (obj (ref link-ref) fieldname) - (declare (ignore obj fieldname)) - (format nil "~a" (href-end ref)) - ) - -(defmethod fmt-obj-data (x (fmt textformat) s - &optional (indent 0) (label nil) (refvars nil)) - (if (obj-data-indent fmt) - (indent-spaces indent s)) - (if (link-ref fmt) - (fmt-obj-data-with-ref x fmt s label refvars) - (fmt-obj-data-plain x fmt s label)) - (aif (obj-data-end-fmtstr fmt) - (format s it))) - -(defmethod fmt-obj-data-plain (x (fmt textformat) s label) - (if label - (apply #'format s - (funcall (obj-data-fmtstr-labels fmt) x) - (multiple-value-list - (funcall (funcall (obj-data-value-func fmt) x) x))) - (apply #'format s (funcall (obj-data-fmtstr fmt) x) - (multiple-value-list - (funcall (funcall (obj-data-value-func fmt) x) x))))) - -(defmethod fmt-obj-data-with-ref (x (fmt textformat) s label refvars) - (let ((refstr (make-ref-data-str x fmt label)) - (refvalues nil) - (field-values - (multiple-value-list - (funcall (funcall (obj-data-value-func fmt) x) x)))) - - ;; make list of reference link fields for printing to refstr template - (dolist (field (ml-class-linked-fields x)) - (let ((link-start - (make-link-start x (link-ref fmt) (car field) (cadr field) - (nth (position (car field) (ml-class-fields x) :key #'car) field-values) - (append (caddr field) refvars))) - (link-end (make-link-end x (link-ref fmt) (car field)))) - (push link-start refvalues) - (push link-end refvalues))) - (setq refvalues (nreverse refvalues)) - - (apply #'format s refstr refvalues))) - -(defmethod obj-data (x) - "Returns the objects data as a string. Used by common-graphics outline function" - (let ((fmt (make-format-instance :text))) - (apply #'format nil (funcall (obj-data-fmtstr fmt) x) - (multiple-value-list - (funcall (funcall (obj-data-value-func fmt) x) x))))) - -(defmethod make-ref-data-str (x (fmt textformat) &optional (label nil)) - "Return fmt string for that contains ~a slots for reference link start and end" - (unless (link-ref fmt) - (error "fmt does not contain a link-ref")) - (let ((refstr - (if label - (apply #'format nil (funcall (fmtstr-labels (link-ref fmt)) x) - (multiple-value-list - (funcall (funcall (obj-data-value-func fmt) x) x))) - (apply #'format nil (funcall (fmtstr (link-ref fmt)) x) - (multiple-value-list (funcall (funcall (obj-data-value-func fmt) x) x)))))) - refstr)) - -;;; Display method for objects - - -(defmethod load-all-subobjects (objs) - "Load all subobjects if they have not already been loaded." - (when objs - (let ((objlist (mklist objs))) - (dolist (obj objlist) - (awhen (ml-class-subobjects-lists obj) ;; access list of functions - (dolist (child-obj it) ;; for each child function - (awhen (funcall (car child-obj) obj) - (load-all-subobjects it)))))) - objs)) - -(defmethod output-ml-class (objs (fmt dataformat) (strm stream) - &optional (label nil) (english-only-function nil) - (indent 0) (subobjects nil) (refvars nil)) - "Display a single or list of ml-class instances and their subobjects" - (when objs - (setq objs (mklist objs)) - (let ((nobjs (length objs))) - (fmt-list-start (car objs) fmt strm indent nobjs) - (dolist (obj objs) - (unless (and english-only-function (not (funcall english-only-function obj))) - (fmt-obj-start obj fmt strm indent) - (fmt-obj-data obj fmt strm (1+ indent) label refvars) - (if subobjects - (awhen (ml-class-subobjects-lists obj) ;; access list of functions - (dolist (child-obj it) ;; for each child function - (awhen (funcall (car child-obj) obj) ;; access set of child objects - (output-ml-class it fmt strm label - english-only-function - (1+ indent) subobjects refvars))))) - (fmt-obj-end obj fmt strm indent))) - (fmt-list-end (car objs) fmt strm indent nobjs)) - t)) - -(defun display-ml-class (objs &key (os *standard-output*) (format :text) - (label nil) (english-only-function nil) (subobjects nil) - (file-wrapper t) (refvars nil)) - "EXPORTED Function: displays a ml-class. Simplies call to output-ml-class" - (let ((fmt (make-format-instance format))) - (if file-wrapper - (fmt-file-start fmt os)) - (when objs - (output-ml-class objs fmt os label english-only-function 0 subobjects refvars)) - (if file-wrapper - (fmt-file-end fmt os))) - objs) -- 2.34.1