X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=ml-class.lisp;h=5809fb8cc1ec3826f5993aa2598e0067169bcdbd;hb=7df23480148948394d8ded4d4997abace80f100d;hp=bab9ca619497c66de58c58edadb52e9aec4cbfeb;hpb=c555c542d6703f47ed6140955dd9e92471422859;p=kmrcl.git diff --git a/ml-class.lisp b/ml-class.lisp index bab9ca6..5809fb8 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.14 2002/10/16 16:05:18 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)) @@ -194,7 +200,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (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-text "" value-fmt "") (string-append fmtstr-html html-str) (string-append fmtstr-xml xml-str) (string-append fmtstr-text-labels namestr-lower " " 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,11 +221,9 @@ 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) @@ -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*))) @@ -416,13 +424,13 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (defun class-name-of (obj) - (string-downcase (class-name (ml-class-of obj)))) + (string-downcase (ml-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" (string-downcase (ml-class-name (ml-class-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" (string-downcase (ml-class-name (ml-class-of x)))) (ml-class-title x) nitems)) (defclass xmlformat (textformat) () @@ -468,10 +476,17 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (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 +497,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