XMLS-SYMBOLS.diff

   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