99 lines
3.4 KiB
Diff
99 lines
3.4 KiB
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)
|
|
|
|
|
|
|