/
XMLS-SYMBOLS.diff
98 lines (88 loc) · 3.36 KB
/
XMLS-SYMBOLS.diff
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
* 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)