From cf40a72efe98c7a0b5cafba7c3c854879fcfeef2 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Sun, 13 Oct 2002 17:43:32 +0000 Subject: [PATCH] r2991: *** empty log message *** --- debian/changelog | 19 ++ kmrcl.asd | 3 +- ml-class.lisp | 65 +++-- ml.lisp | 614 +++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 679 insertions(+), 22 deletions(-) create mode 100644 ml.lisp diff --git a/debian/changelog b/debian/changelog index 1711271..17180a2 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,22 @@ +cl-kmrcl (1.6-1) unstable; urgency=low + + * Use pcl:class-of for ml-class and CMU + + -- Kevin M. Rosenberg Sun, 13 Oct 2002 11:04:04 -0600 + +cl-kmrcl (1.5-1) unstable; urgency=low + + * ml-class.lisp: Change pcl package to sb-pcl for sbcl + * kmrcl.asd: remove sbcl from reader conditional for ml-class + + -- Kevin M. Rosenberg Sun, 13 Oct 2002 10:16:14 -0600 + +cl-kmrcl (1.4-1) unstable; urgency=low + + * Add pcl:validate-superclass for CMUCL/SBCL compatibility + + -- Kevin M. Rosenberg Sun, 13 Oct 2002 10:09:39 -0600 + cl-kmrcl (1.3) unstable; urgency=low * Change .asd to fix problem with ml-class diff --git a/kmrcl.asd b/kmrcl.asd index 258b4c5..f559e29 100644 --- a/kmrcl.asd +++ b/kmrcl.asd @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: kmrcl.asd,v 1.6 2002/10/12 19:04:15 kevin Exp $ +;;;; $Id: kmrcl.asd,v 1.7 2002/10/13 17:39:50 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -37,6 +37,7 @@ (:file "web-utils" :depends-on ("package")) (:file "xml-utils" :depends-on ("package")) #+(or allegro lispworks cmu) (:file "ml-class" :depends-on ("strings" "genutils")) + (:file "ml" :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 567a327..b369055 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.5 2002/10/11 23:51:33 kevin Exp $ +;;;; $Id: ml-class.lisp,v 1.6 2002/10/13 17:39:50 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -24,6 +24,10 @@ (declaim (optimize (speed 3) (safety 1))) +(defun ml-class-of (obj) + #-(or cmu sbcl) (class-of obj) + #+sbcl (sb-pcl:class-of obj) + #+cmu (pcl:class-of obj)) (defclass ml-class (standard-class) ((title :initarg :title :type string :reader ml-std-title @@ -61,6 +65,21 @@ 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 +(defmethod pcl:validate-superclass ((class ml-class) (superclass pcl::standard-class)) + t) + +#+sbcl +(defmethod sb-pcl:validate-superclass ((class ml-class) (superclass sb-pcl::standard-class)) + t) + +#+cmu +(defmethod pcl:validate-superclass ((class pcl::standard-class) (superclass ml-class)) + t) + +#+sbcl +(defmethod sb-pcl:validate-superclass ((class sb-pcl::standard-class) (superclass ml-class)) + t) #+allegro (defmethod mop:finalize-inheritance :after ((cl ml-class)) @@ -74,6 +93,10 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (defmethod pcl:finalize-inheritance :after ((cl ml-class)) (init-ml-class cl)) +#+sbcl +(defmethod sb-pcl:finalize-inheritance :after ((cl ml-class)) + (init-ml-class cl)) + #+lispworks (defmethod clos:process-a-class-option ((class ml-class) (name (eql :title)) @@ -219,56 +242,56 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (defun ml-class-fmtstr-text (obj) - (slot-value (class-of obj) 'fmtstr-text)) + (slot-value (ml-class-of obj) 'fmtstr-text)) (defun ml-class-fmtstr-html (obj) - (slot-value (class-of obj) 'fmtstr-html)) + (slot-value (ml-class-of obj) 'fmtstr-html)) (defun ml-class-fmtstr-xml (obj) - (slot-value (class-of obj) 'fmtstr-xml)) + (slot-value (ml-class-of obj) 'fmtstr-xml)) (defun ml-class-fmtstr-text-labels (obj) - (slot-value (class-of obj) 'fmtstr-text-labels)) + (slot-value (ml-class-of obj) 'fmtstr-text-labels)) (defun ml-class-fmtstr-html-labels (obj) - (slot-value (class-of obj) 'fmtstr-html-labels)) + (slot-value (ml-class-of obj) 'fmtstr-html-labels)) (defun ml-class-fmtstr-xml-labels (obj) - (slot-value (class-of obj) 'fmtstr-xml-labels)) + (slot-value (ml-class-of obj) 'fmtstr-xml-labels)) (defun ml-class-value-func (obj) - (slot-value (class-of obj) 'value-func)) + (slot-value (ml-class-of obj) 'value-func)) (defun ml-class-xmlvalue-func (obj) - (slot-value (class-of obj) 'xmlvalue-func)) + (slot-value (ml-class-of obj) 'xmlvalue-func)) (eval-when (:compile-toplevel :load-toplevel :execute) (defun ml-class-title (obj) - (awhen (slot-value (class-of obj) 'title) + (awhen (slot-value (ml-class-of obj) 'title) (if (consp it) (car it) it)))) (defun ml-class-subobjects-lists (obj) - (slot-value (class-of obj) 'subobjects-lists)) + (slot-value (ml-class-of obj) 'subobjects-lists)) (defun ml-class-ref-fields (obj) - (slot-value (class-of obj) 'ref-fields)) + (slot-value (ml-class-of obj) 'ref-fields)) (defun ml-class-fields (obj) - (slot-value (class-of obj) 'fields)) + (slot-value (ml-class-of obj) 'fields)) (defun ml-class-fmtstr-html-ref (obj) - (slot-value (class-of obj) 'fmtstr-html-ref)) + (slot-value (ml-class-of obj) 'fmtstr-html-ref)) (defun ml-class-fmtstr-xml-ref (obj) - (slot-value (class-of obj) 'fmtstr-xml-ref)) + (slot-value (ml-class-of obj) 'fmtstr-xml-ref)) (defun ml-class-fmtstr-html-ref-labels (obj) - (slot-value (class-of obj) 'fmtstr-html-ref-labels)) + (slot-value (ml-class-of obj) 'fmtstr-html-ref-labels)) (defun ml-class-fmtstr-xml-ref-labels (obj) - (slot-value (class-of obj) 'fmtstr-xml-ref-labels)) + (slot-value (ml-class-of obj) 'fmtstr-xml-ref-labels)) ;;; Class name functions @@ -276,7 +299,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (string-downcase (subseq name :start 1))) (defmethod ml-class-stdname ((cl standard-object)) - (string-downcase (subseq (class-name (class-of cl)) :start 1))) + (string-downcase (subseq (class-name (ml-class-of cl)) :start 1))) ;;;; Generic Print functions @@ -381,13 +404,13 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (defun class-name-of (obj) - (string-downcase (class-name (class-of obj)))) + (string-downcase (class-name (ml-class-of obj)))) (defun xmlformat-list-end-value-func (x) - (format nil "~alist" (string-downcase (class-name (class-of x))))) + (format nil "~alist" (string-downcase (class-name (ml-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)) + (values (format nil "~alist" (string-downcase (class-name (ml-class-of x)))) (ml-class-title x) nitems)) (defclass xmlformat (textformat) () diff --git a/ml.lisp b/ml.lisp new file mode 100644 index 0000000..ebfd76c --- /dev/null +++ b/ml.lisp @@ -0,0 +1,614 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: ml-class.lisp +;;;; Purpose: Markup Language Metaclass +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; This metaclass as functions to classes to allow display +;;;; in Text, HTML, and XML formats. This includes hyperlinking +;;;; capability and sub-objects. +;;;; +;;;; $Id: ml.lisp,v 1.1 2002/10/13 17:39:50 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. +;;;; ************************************************************************* + +(in-package :kmrcl) + +(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. + +(defmacro def-ml-class (name (parent) field-defs &key title types linked-fields subobjects documentaton) + (let ((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 '((:documentation ,documentation)))) + ) + + (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-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 "Metaclass for Markup Language classes.")) + + +;;;; Class initialization function + +(defun init-ml-class-fmt (cl) + (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 (class-name cl)) + (ref-fields (slot-value cl 'ref-fields))) + (declare (ignore classname)) + (dolist (f (slot-value cl '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 ref-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))) + + (setf (slot-value cl 'fmtstr-text) fmtstr-text) + (setf (slot-value cl 'fmtstr-html) fmtstr-html) + (setf (slot-value cl 'fmtstr-xml) fmtstr-xml) + (setf (slot-value cl 'fmtstr-text-labels) fmtstr-text-labels) + (setf (slot-value cl 'fmtstr-html-labels) fmtstr-html-labels) + (setf (slot-value cl 'fmtstr-xml-labels) fmtstr-xml-labels) + (setf (slot-value cl 'fmtstr-html-ref) fmtstr-html-ref) + (setf (slot-value cl 'fmtstr-xml-ref) fmtstr-xml-ref) + (setf (slot-value cl 'fmtstr-html-ref-labels) fmtstr-html-ref-labels) + (setf (slot-value cl 'fmtstr-xml-ref-labels) fmtstr-xml-ref-labels) + (setf (slot-value cl 'value-func) value-func) + (setf (slot-value cl 'xmlvalue-func) xmlvalue-func)) + (values)) + +(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-ref-fields (obj) + (slot-value (%class-of obj) 'ref-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-ref-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