[cl-who-devel] case sensitive tag

Fri Mar 23 00:59:30 UTC 2007

Here you go. Hopefully I didn't mess up this time :-)
-------------- next part --------------
Index: doc/index.html
===================================================================

--- doc/index.html	(revision 1057)
+++ doc/index.html	(working copy)
@@ -539,6 +539,15 @@
 <pre>"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"</pre>
 </blockquote>
 
+<p><br>[Special variable]
+<br><a class=none name="*downcase-tag*"><b>*downcase-tag*</b></a>
+
+<blockquote><br>
+  If NIL, keyword symbol representing a tagname will not be
+automatically converted to lowercase.  It is useful when one needs to
+output case sensitive xml tags. Default to T.
+</blockquote>
+
 <p><br>[Symbol]
 <br><a class=none name="esc"><b>esc</b></a>
 <br>[Symbol]
Index: packages.lisp
===================================================================
--- packages.lisp	(revision 1057)
+++ packages.lisp	(working copy)
@@ -35,6 +35,7 @@
   (:export #:*attribute-quote-char*
            #:*escape-char-p*
            #:*prologue*
+           #:*downcase-tag*
            #:conc
            #:convert-attributes
            #:convert-tag-to-string-list
@@ -58,6 +59,7 @@
   (:export "*ATTRIBUTE-QUOTE-CHAR*" 
            "*ESCAPE-CHAR-P*"
            "*PROLOGUE*"
+           "*DOWNCASE-TAG*"
            "CONC"
            "ESC"
            "ESCAPE-STRING"
Index: who.lisp
===================================================================
--- who.lisp	(revision 1057)
+++ who.lisp	(working copy)
@@ -47,6 +47,11 @@
 (defvar *html-mode* :xml
   ":SGML for \(SGML-)HTML, :XML \(default) for XHTML.")
 
+(defvar *downcase-tag* T
+  "If NIL, keyword symbol representing a tagname will not be
+automatically converted to lowercase.  It is useful when one needs to
+output case sensitive xml tags.")
+
 (defparameter *attribute-quote-char* #\'
   "Quote character for attributes.")
 
@@ -239,31 +244,32 @@
   "The standard method which is not specialized.  The idea is that you
 can use EQL specializers on the first argument."
   (declare (optimize speed space))
+  (let ((tag (if *downcase-tag* (string-downcase tag) (string tag))))
     (nconc
      (if *indent*
-       ;; indent by *INDENT* spaces
-       (list +newline+ (n-spaces *indent*)))
+         ;; indent by *INDENT* spaces
+         (list +newline+ (n-spaces *indent*)))
      ;; tag name
-     (list "<" (string-downcase tag))
+     (list "<" tag)
      ;; attributes
      (convert-attributes attr-list)
      ;; body
      (if body
-       (append
-        (list ">")
-        ;; now hand over the tag's body to TREE-TO-TEMPLATE, increase
-        ;; *INDENT* by 2 if necessary
-        (if *indent*
-          (let ((*indent* (+ 2 *indent*)))
-            (funcall body-fn body))
-          (funcall body-fn body))
-        (if *indent*
-          ;; indentation
-          (list +newline+ (n-spaces *indent*)))
-        ;; closing tag
-        (list "</" (string-downcase tag) ">"))
-       ;; no body, so no closing tag
-       (list *empty-tag-end*))))
+         (append
+          (list ">")
+          ;; now hand over the tag's body to TREE-TO-TEMPLATE, increase
+          ;; *INDENT* by 2 if necessary
+          (if *indent*
+              (let ((*indent* (+ 2 *indent*)))
+                (funcall body-fn body))
+              (funcall body-fn body))
+          (if *indent*
+              ;; indentation
+              (list +newline+ (n-spaces *indent*)))
+          ;; closing tag
+          (list "</" tag ">"))
+         ;; no body, so no closing tag
+         (list *empty-tag-end*)))))
 
 (defun apply-to-tree (function test tree)
   (declare (optimize speed space))
