X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=ml-class.lisp;h=9b5f08520927d14d8edfd91a92b4aa9c29454adc;hb=20d649ec9462eab4b9fc55602308b45a59840e0e;hp=6be17c146cca41866ee0f314f1fb36b13270459b;hpb=fd834629ba860f91bda943a94a363a650079dff8;p=kmrcl.git diff --git a/ml-class.lisp b/ml-class.lisp index 6be17c1..9b5f085 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.15 2002/10/16 16:18:27 kevin Exp $ +;;;; $Id: ml-class.lisp,v 1.21 2002/10/18 07:28:57 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -76,6 +76,10 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (defmethod pcl:finalize-inheritance :after ((cl ml-class)) (init-ml-class cl)) +#+scl +(defmethod clos:finalize-inheritance :after ((cl ml-class)) + (init-ml-class cl)) + #+sbcl (defmethod sb-pcl:finalize-inheritance :after ((cl ml-class)) @@ -86,6 +90,10 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (defmethod pcl:validate-superclass ((class ml-class) (superclass pcl::standard-class)) t) +#+scl +(defmethod clos:validate-superclass ((class ml-class) (superclass standard-class)) + t) + #+sbcl (defmethod sb-pcl:validate-superclass ((class ml-class) (superclass sb-pcl::standard-class)) t) @@ -98,16 +106,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)) @@ -197,7 +195,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (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) @@ -230,7 +228,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (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)))) @@ -322,6 +320,8 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (defparameter *default-textformat* nil) (defparameter *default-htmlformat* nil) (defparameter *default-htmlrefformat* nil) +(defparameter *default-xhtmlformat* nil) +(defparameter *default-xhtmlrefformat* nil) (defparameter *default-xmlformat* nil) (defparameter *default-xmlrefformat* nil) (defparameter *default-ie-xmlrefformat* nil) @@ -333,6 +333,8 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (setq *default-textformat* (make-instance 'textformat)) (setq *default-htmlformat* (make-instance 'htmlformat)) (setq *default-htmlrefformat* (make-instance 'htmlrefformat)) + (setq *default-xhtmlformat* (make-instance 'xhtmlformat)) + (setq *default-xhtmlrefformat* (make-instance 'xhtmlrefformat)) (setq *default-xmlformat* (make-instance 'xmlformat)) (setq *default-xmlrefformat* (make-instance 'xmlrefformat)) (setq *default-ie-xmlrefformat* (make-instance 'ie-xmlrefformat)) @@ -343,7 +345,8 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (:text *default-textformat*) (:html *default-htmlformat*) (:htmlref *default-htmlrefformat*) - (:xml *default-xmlformat*) + (:xhtml *default-xhtmlformat*) + (:xhtmlref *default-xhtmlrefformat*) (:xml *default-xmlformat*) (:xmlref *default-xmlrefformat*) (:ie-xmlref *default-ie-xmlrefformat*) @@ -401,14 +404,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 @@ -422,15 +432,33 @@ Format is ((field-name field-lookup-func other-link-params) ...)") :obj-data-fmtstr-labels #'ml-class-fmtstr-html-labels :obj-data-value-func #'ml-class-value-func)) +(defclass xhtmlformat (textformat) + () + (:default-initargs :file-start-str "~%" + :file-end-str "~%" + :list-start-indent t + :list-start-fmtstr "

~a~p:

~%" + :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-xmlvalue-func)) -(defun class-name-of (obj) - (string-downcase (ml-class-name (ml-class-of obj)))) (defun xmlformat-list-end-value-func (x) - (format nil "~alist" (string-downcase (ml-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 (ml-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) () @@ -473,6 +501,14 @@ Format is ((field-name field-lookup-func other-link-params) ...)") :href-end "a" :ampersand "&")) +(defclass xhtml-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 @@ -493,6 +529,10 @@ Format is ((field-name field-lookup-func other-link-params) ...)") () (:default-initargs :link-ref (make-instance 'html-link-ref))) +(defclass xhtmlrefformat (xhtmlformat) + () + (:default-initargs :link-ref (make-instance 'xhtml-link-ref))) + (defclass xmlrefformat (xmlformat) () (:default-initargs :link-ref (make-instance 'xml-link-ref))) @@ -669,7 +709,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