X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=ml-class.lisp;fp=ml-class.lisp;h=b720de00351cd7d5dcb936a8c10d47c8529a00a8;hb=4a7372ef4000eaaa86a987bc9668ccecf7d0489f;hp=2376f0abbee6876fa0864d7353cdff44f293954a;hpb=bb23129ae7ddabcbcb09c718545f69a52a8d1eaf;p=kmrcl.git diff --git a/ml-class.lisp b/ml-class.lisp index 2376f0a..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.16 2002/10/16 17:37:18 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 ;;;; @@ -230,7 +230,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)))) @@ -401,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 @@ -420,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 (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) () @@ -471,7 +475,7 @@ 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) ()