r3072: *** empty log message ***

[kmrcl.git] / ml-class.lisp
diff --git a/ml-class.lisp b/ml-class.lisp

index 2376f0abbee6876fa0864d7353cdff44f293954a..b720de00351cd7d5dcb936a8c10d47c8529a00a8 100644 (file)
--- 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 "<html><body>~%"
      :file-end-str "</body><html>~%"
      :list-start-indent t
-    :list-start-fmtstr "<p><b>~a~P:</b></p><ul>~%"
-    :list-start-value-func #'text-list-start-value-func
-    :list-end-fmtstr "</ul>~%"
+    :list-start-fmtstr "<p><b>~a~p:</b></p><div class=\"~A\"><ul>~%"
+    :list-start-value-func #'htmlformat-list-start-value-func
+    :list-end-fmtstr "</ul></div>~%"
      :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 "&amp;"))
  
  (defclass xml-link-ref (link-ref)
    ()