downcase a tag only when it is in the same case (useful for some came…

…l case XML tags).

specials.lisp

@@ -63,8 +63,10 @@ can be defined as <input disabled>")
 
 (defvar *downcase-tokens-p* t
   "If NIL, a keyword symbol representing a tag or attribute name will
-not be automatically converted to lowercase.  This is useful when one
-needs to output case sensitive XML.")
+not be automatically converted to lowercase.  If T, the tag and
+attribute name will be converted to lowercase only if it is in the
+same case. This is useful when one needs to output case sensitive
+XML.")
 
 (defvar *attribute-quote-char* #\'
   "Quote character for attributes.")

util.lisp

@@ -239,3 +239,14 @@ character set."
                    (eql (first form) 'cl:declare))
         do (push form declarations)
         finally (return (values (nreverse declarations) forms))))
+
+(defun same-case-p (string)
+  "Test if all characters of a string are in the same case."
+  (or (every #'(lambda (c) (or (not (alpha-char-p c)) (lower-case-p c))) string)
+      (every #'(lambda (c) (or (not (alpha-char-p c)) (upper-case-p c))) string)))
+
+(defun maybe-downcase (symbol)
+  (let ((string (string symbol)))
+    (if (and *downcase-tokens-p* (same-case-p string))
+        (string-downcase string)
+        string)))

who.lisp

@@ -91,9 +91,7 @@ forms."
   (declare (optimize speed space))
   (loop with =var= = (gensym)
         for (orig-attr . val) in attr-list
-        for attr = (if *downcase-tokens-p*
-                     (string-downcase orig-attr)
-                     (string orig-attr))
+        for attr = (maybe-downcase orig-attr)
         unless (null val) ;; no attribute at all if VAL is NIL
           if (constantp val)
             if (and *empty-attribute-syntax* (eq val t)) ; special case for SGML and HTML5
@@ -144,7 +142,7 @@ a list of strings or Lisp forms."))
   "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-tokens-p* (string-downcase tag) (string tag)))
+  (let ((tag (maybe-downcase tag))
         (body-indent
           ;; increase *INDENT* by 2 for body -- or disable it
           (when (and *indent* (not (member tag *html-no-indent-tags* :test #'string-equal)))