XMLS-SYMBOLS.diff

* looking for david@knowledgetools.de--cxml/cxml--devel--1.0--patch-309 to compare with
* comparing to david@knowledgetools.de--cxml/cxml--devel--1.0--patch-309
M  xml/xmls-compat.lisp

* modified files

--- orig/xml/xmls-compat.lisp
+++ mod/xml/xmls-compat.lisp
@@ -12,7 +12,8 @@
 (defpackage cxml-xmls
   (:use :cl :runes)
   (:export #:make-node #:node-name #:node-ns #:node-attrs #:node-children
-           #:make-xmls-builder #:map-node))
+           #:make-xmls-builder #:map-node
+           #:*identifier-case*))
 
 (in-package :cxml-xmls)
 
@@ -64,6 +65,10 @@
 
 ;;;; SAX-Handler (Parser)
 
+(defvar *identifier-case* nil
+  "One of NIL (don't intern names), :PRESERVE, :UPCASE, :DOWNCASE, or :INVERT
+   (intern name into the keyword package after adjusting case).")
+
 (defclass xmls-builder ()
     ((element-stack :initform nil :accessor element-stack)
      (root :initform nil :accessor root)))
@@ -74,16 +79,46 @@
 (defmethod sax:end-document ((handler xmls-builder))
   (root handler))
 
+(defun string-invert-case (str)
+  (map 'string
+    (lambda (c)
+      (cond
+        ((upper-case-p c) (char-downcase c))
+        ((lower-case-p c) (char-upcase c))
+        (t c)))
+    str))
+
+(defun maybe-intern (name)
+  (if *identifier-case*
+      (let ((str (if (stringp name) name (rod-string name))))
+        (intern (ecase *identifier-case*
+                  (:preserve str)
+                  (:upcase (string-upcase str))
+                  (:downcase (string-downcase str))
+                  (:invert (string-invert-case str)))
+                :keyword))
+      name))
+
+(defun maybe-stringify (name)
+  (if (symbolp name)
+      (let ((str (symbol-name name)))
+        (ecase *identifier-case*
+          (:preserve str)
+          (:upcase (string-downcase str))
+          (:downcase (string-upcase str))
+          (:invert (string-invert-case str))))
+      name))
+
 (defmethod sax:start-element
     ((handler xmls-builder) namespace-uri local-name qname attributes)
   (declare (ignore namespace-uri))
   (setf local-name (or local-name qname))
   (let* ((attributes
           (mapcar (lambda (attr)
-                    (list (sax:attribute-qname attr)
+                    (list (maybe-intern (sax:attribute-qname attr))
                           (sax:attribute-value attr)))
                   attributes))
-         (node (make-node :name local-name
+         (node (make-node :name (maybe-intern local-name)
                           :ns (let ((lq (length qname))
                                     (ll (length local-name)))
                                 (if (eql lq ll)
@@ -124,7 +159,7 @@
   (labels ((walk (node)
              (let* ((attlist
                      (compute-attributes node include-xmlns-attributes))
-                    (lname (rod (node-name node)))
+                    (lname (rod (maybe-stringify (node-name node))))
                     (ns (rod (node-ns node)))
                     (qname (concatenate 'rod ns (rod ":") lname)))
                ;; fixme: namespaces
@@ -141,6 +176,7 @@
   (remove nil
           (mapcar (lambda (a)
                     (destructuring-bind (name value) a
+                      (setf name (maybe-stringify name))
                       (if (or xmlnsp (not (cxml::xmlns-attr-p (rod name))))
                           (sax:make-attribute :qname (rod name)
                                               :value (rod value)