X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=ml-class.lisp;h=b720de00351cd7d5dcb936a8c10d47c8529a00a8;hb=4a7372ef4000eaaa86a987bc9668ccecf7d0489f;hp=bab9ca619497c66de58c58edadb52e9aec4cbfeb;hpb=c555c542d6703f47ed6140955dd9e92471422859;p=kmrcl.git diff --git a/ml-class.lisp b/ml-class.lisp index bab9ca6..b720de0 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.10 2002/10/14 15:25:11 kevin Exp $ +;;;; $Id: ml-class.lisp,v 1.17 2002/10/16 21:58:49 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -29,6 +29,11 @@ #+sbcl (sb-pcl:class-of obj) #+cmu (pcl:class-of obj)) +(defun ml-class-name (obj) + #-(or cmu sbcl) (class-name obj) + #+sbcl (sb-pcl:class-name obj) + #+cmu (pcl:class-name obj)) + (defclass ml-class (#-(or cmu sbcl) standard-class #+cmu pcl::standard-class #+sbcl sb-pcl::standard-class) @@ -154,6 +159,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (value-func '()) (xmlvalue-func '()) (classname (class-name cl)) + (package (symbol-package (ml-class-name cl))) (ref-fields (slot-value cl 'ref-fields))) (declare (ignore classname)) (dolist (f (slot-value cl 'fields)) @@ -189,9 +195,9 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (string-append fmtstr-html-ref-labels " ") (string-append fmtstr-xml-ref-labels " "))) - (setq html-str value-fmt) + (setq html-str (concatenate 'string "" value-fmt "")) (setq xml-str (concatenate 'string "<" namestr-lower ">" value-fmt "")) - (setq html-label-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) @@ -205,7 +211,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (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-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) @@ -215,18 +221,16 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (if formatter (setq plain-value-func - (list `(,formatter (,(concat-symbol-pkg - :umlisp namestr) x)))) + (list `(,formatter (,(intern namestr package) x)))) (setq plain-value-func - (list `(,(concat-symbol-pkg - :umlisp namestr) x)))) + (list `(,(intern namestr package) 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))) )) - + (if value-func (setq value-func `(lambda (x) (values ,@value-func))) (setq value-func `(lambda () (values)))) @@ -311,7 +315,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (string-downcase (subseq name 1))) (defmethod ml-class-stdname ((cl standard-object)) - (string-downcase (subseq (class-name (ml-class-of cl)) 1))) + (string-downcase (subseq (ml-class-name (ml-class-of cl)) 1))) ;;;; Generic Print functions @@ -320,6 +324,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (defparameter *default-htmlrefformat* nil) (defparameter *default-xmlformat* nil) (defparameter *default-xmlrefformat* nil) +(defparameter *default-ie-xmlrefformat* nil) (defparameter *default-nullformat* nil) (defparameter *default-init-format?* nil) @@ -330,6 +335,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (setq *default-htmlrefformat* (make-instance 'htmlrefformat)) (setq *default-xmlformat* (make-instance 'xmlformat)) (setq *default-xmlrefformat* (make-instance 'xmlrefformat)) + (setq *default-ie-xmlrefformat* (make-instance 'ie-xmlrefformat)) (setq *default-nullformat* (make-instance 'nullformat)) (setq *default-init-format?* t)) @@ -338,7 +344,9 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (:html *default-htmlformat*) (:htmlref *default-htmlrefformat*) (:xml *default-xmlformat*) + (:xml *default-xmlformat*) (:xmlref *default-xmlrefformat*) + (:ie-xmlref *default-ie-xmlrefformat*) (:null *default-nullformat*) (otherwise *default-textformat*))) @@ -393,14 +401,21 @@ Format is ((field-name field-lookup-func other-link-params) ...)") :obj-data-end-fmtstr "~%" :obj-data-value-func #'ml-class-value-func)) + +(defun class-name-of (obj) + (string-downcase (ml-class-name (ml-class-of obj)))) + +(defun htmlformat-list-start-value-func (x nitems) + (values (ml-class-title x) nitems (class-name-of x))) + (defclass htmlformat (textformat) () (:default-initargs :file-start-str "~%" :file-end-str "~%" :list-start-indent t - :list-start-fmtstr "

~a~P:

~%" + :list-start-fmtstr "

~a~p:

~%" :list-end-indent t :list-end-value-func #'identity :obj-start-indent t @@ -412,17 +427,14 @@ Format is ((field-name field-lookup-func other-link-params) ...)") :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)) - + :obj-data-value-func #'ml-class-xmlvalue-func)) -(defun class-name-of (obj) - (string-downcase (class-name (ml-class-of obj)))) (defun xmlformat-list-end-value-func (x) - (format nil "~alist" (string-downcase (class-name (ml-class-of x))))) + (format nil "~alist" (class-name-of x))) (defun xmlformat-list-start-value-func (x nitems) - (values (format nil "~alist" (string-downcase (class-name (ml-class-of x)))) (ml-class-title x) nitems)) + (values (format nil "~alist" (class-name-of x)) (ml-class-title x) nitems)) (defclass xmlformat (textformat) () @@ -463,15 +475,22 @@ Format is ((field-name field-lookup-func other-link-params) ...)") :fmtstr-labels #'ml-class-fmtstr-html-ref-labels :href-head "a href=" :href-end "a" - :ampersand "&")) + :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 "&")) + :fmtstr-labels #'ml-class-fmtstr-xml-ref-labels + :href-head "xmllink xlink:type=\"simple\" xlink:href=" + :href-end "xmllink" + :ampersand "&") + (:documentation "Mozilla's and W3's idea of a link with XML")) + +(defclass ie-xml-link-ref (xml-link-ref) + () + (:default-initargs :href-head "html:a href=" + :href-end "html:a" ) + (:documentation "Internet Explorer's idea of a link with XML")) (defclass htmlrefformat (htmlformat) @@ -482,6 +501,10 @@ Format is ((field-name field-lookup-func other-link-params) ...)") () (:default-initargs :link-ref (make-instance 'xml-link-ref))) +(defclass ie-xmlrefformat (xmlformat) + () + (:default-initargs :link-ref (make-instance 'ie-xml-link-ref))) + ;;; File Start and Ends @@ -650,7 +673,9 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (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))) + (unless (and english-only-function + (multiple-value-bind (eng term) (funcall english-only-function obj) + (and term (not eng)))) (fmt-obj-start obj fmt strm indent) (fmt-obj-data obj fmt strm (1+ indent) label refvars) (if subobjects