/[cxml]/cxml/XMLS-SYMBOLS.diff
ViewVC logotype

Contents of /cxml/XMLS-SYMBOLS.diff

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.1 - (show annotations) (vendor branch)
Sun Mar 13 18:02:48 2005 UTC (9 years, 1 month ago) by david
Branch: MAIN, dlichteblau
CVS Tags: patch-361, patch-360, patch-363, patch-362, patch-343, patch-364, patch-341, patch-346, patch-345, patch-349, patch-348, patch-329, patch-344, patch-342, patch-314, patch-315, patch-340, patch-328, patch-358, patch-359, patch-316, patch-317, patch-310, patch-311, patch-338, patch-339, patch-350, patch-351, patch-352, patch-353, patch-354, patch-355, patch-356, patch-357, patch-318, patch-312, patch-313, patch-336, patch-347, patch-319, patch-337, patch-334, patch-335, patch-332, patch-333, rel-2005-06-25, patch-330, patch-326, patch-325, patch-324, patch-327, patch-331, patch-321, patch-320, patch-323, patch-322, HEAD
Changes since 1.1: +0 -0 lines
Revision: cxml--devel--1.0--patch-310
Archive: david@knowledgetools.de--cxml
Creator: David Lichteblau <david@knowledgetools.de>
Date: Fri Sep  3 23:32:04 CEST 2004
Standard-date: 2004-09-03 21:32:04 GMT
New-files: .arch-ids/XMLS-SYMBOLS.diff.id XMLS-SYMBOLS.diff
New-patches: david@knowledgetools.de--cxml/cxml--devel--1.0--patch-310
Summary: patch for interned names in xmls data
Keywords: 

patch for interned names in xmls data
1 * looking for david@knowledgetools.de--cxml/cxml--devel--1.0--patch-309 to compare with
2 * comparing to david@knowledgetools.de--cxml/cxml--devel--1.0--patch-309
3 M xml/xmls-compat.lisp
4
5 * modified files
6
7 --- orig/xml/xmls-compat.lisp
8 +++ mod/xml/xmls-compat.lisp
9 @@ -12,7 +12,8 @@
10 (defpackage cxml-xmls
11 (:use :cl :runes)
12 (:export #:make-node #:node-name #:node-ns #:node-attrs #:node-children
13 - #:make-xmls-builder #:map-node))
14 + #:make-xmls-builder #:map-node
15 + #:*identifier-case*))
16
17 (in-package :cxml-xmls)
18
19 @@ -64,6 +65,10 @@
20
21 ;;;; SAX-Handler (Parser)
22
23 +(defvar *identifier-case* nil
24 + "One of NIL (don't intern names), :PRESERVE, :UPCASE, :DOWNCASE, or :INVERT
25 + (intern name into the keyword package after adjusting case).")
26 +
27 (defclass xmls-builder ()
28 ((element-stack :initform nil :accessor element-stack)
29 (root :initform nil :accessor root)))
30 @@ -74,16 +79,46 @@
31 (defmethod sax:end-document ((handler xmls-builder))
32 (root handler))
33
34 +(defun string-invert-case (str)
35 + (map 'string
36 + (lambda (c)
37 + (cond
38 + ((upper-case-p c) (char-downcase c))
39 + ((lower-case-p c) (char-upcase c))
40 + (t c)))
41 + str))
42 +
43 +(defun maybe-intern (name)
44 + (if *identifier-case*
45 + (let ((str (if (stringp name) name (rod-string name))))
46 + (intern (ecase *identifier-case*
47 + (:preserve str)
48 + (:upcase (string-upcase str))
49 + (:downcase (string-downcase str))
50 + (:invert (string-invert-case str)))
51 + :keyword))
52 + name))
53 +
54 +(defun maybe-stringify (name)
55 + (if (symbolp name)
56 + (let ((str (symbol-name name)))
57 + (ecase *identifier-case*
58 + (:preserve str)
59 + (:upcase (string-downcase str))
60 + (:downcase (string-upcase str))
61 + (:invert (string-invert-case str))))
62 + name))
63 +
64 (defmethod sax:start-element
65 ((handler xmls-builder) namespace-uri local-name qname attributes)
66 (declare (ignore namespace-uri))
67 (setf local-name (or local-name qname))
68 (let* ((attributes
69 (mapcar (lambda (attr)
70 - (list (sax:attribute-qname attr)
71 + (list (maybe-intern (sax:attribute-qname attr))
72 (sax:attribute-value attr)))
73 attributes))
74 - (node (make-node :name local-name
75 + (node (make-node :name (maybe-intern local-name)
76 :ns (let ((lq (length qname))
77 (ll (length local-name)))
78 (if (eql lq ll)
79 @@ -124,7 +159,7 @@
80 (labels ((walk (node)
81 (let* ((attlist
82 (compute-attributes node include-xmlns-attributes))
83 - (lname (rod (node-name node)))
84 + (lname (rod (maybe-stringify (node-name node))))
85 (ns (rod (node-ns node)))
86 (qname (concatenate 'rod ns (rod ":") lname)))
87 ;; fixme: namespaces
88 @@ -141,6 +176,7 @@
89 (remove nil
90 (mapcar (lambda (a)
91 (destructuring-bind (name value) a
92 + (setf name (maybe-stringify name))
93 (if (or xmlnsp (not (cxml::xmlns-attr-p (rod name))))
94 (sax:make-attribute :qname (rod name)
95 :value (rod value)
96
97
98

  ViewVC Help
Powered by ViewVC 1.1.5