261 lines
8.8 KiB
Common Lisp
261 lines
8.8 KiB
Common Lisp
;;;; xml-compat.lisp -- XMLS-compatible data structures
|
|
;;;;
|
|
;;;; This file is part of the CXML parser, released under Lisp-LGPL.
|
|
;;;; See file COPYING for details.
|
|
;;;;
|
|
;;;; Developed 2004 for headcraft - http://headcraft.de/
|
|
;;;; Copyright: David Lichteblau
|
|
|
|
(defpackage cxml-xmls
|
|
(:use :cl :runes)
|
|
(:export #:make-node #:node-name #:node-ns #:node-attrs #:node-children
|
|
#:make-xmls-builder #:map-node #:make-xpath-navigator))
|
|
|
|
(in-package :cxml-xmls)
|
|
|
|
|
|
;;;; Knoten
|
|
|
|
(defun make-node (&key name ns attrs children)
|
|
`(,(if ns (cons name ns) name)
|
|
,attrs
|
|
,@children))
|
|
|
|
(defun node-name (node)
|
|
(let ((car (car node)))
|
|
(if (consp car)
|
|
(car car)
|
|
car)))
|
|
|
|
(defun (setf node-name) (newval node)
|
|
(let ((car (car node)))
|
|
(if (consp car)
|
|
(setf (car car) newval)
|
|
(setf (car node) newval))))
|
|
|
|
(defun node-ns (node)
|
|
(let ((car (car node)))
|
|
(if (consp car)
|
|
(cdr car)
|
|
nil)))
|
|
|
|
(defun (setf node-ns) (newval node)
|
|
(let ((car (car node)))
|
|
(if (consp car)
|
|
(setf (cdr car) newval)
|
|
(setf (car node) (cons car newval)))
|
|
newval))
|
|
|
|
(defun node-attrs (node)
|
|
(cadr node))
|
|
|
|
(defun (setf node-attrs) (newval node)
|
|
(setf (cadr node) newval))
|
|
|
|
(defun node-children (node)
|
|
(cddr node))
|
|
|
|
(defun (setf node-children) (newval node)
|
|
(setf (cddr node) newval))
|
|
|
|
|
|
;;;; SAX-Handler (Parser)
|
|
|
|
(defclass xmls-builder (sax:default-handler)
|
|
((element-stack :initform nil :accessor element-stack)
|
|
(root :initform nil :accessor root)
|
|
(include-default-values :initform t
|
|
:initarg :include-default-values
|
|
:accessor include-default-values)
|
|
(include-namespace-uri :initform t
|
|
:initarg :include-namespace-uri
|
|
:accessor include-namespace-uri)))
|
|
|
|
(defun make-xmls-builder (&key (include-default-values t)
|
|
(include-namespace-uri t))
|
|
"Make a XMLS style builder. When 'include-namespace-uri is true a modified
|
|
XMLS tree is generated that includes the element namespace URI rather than
|
|
the qualified name prefix and also includes the namespace URI for attributes."
|
|
(make-instance 'xmls-builder
|
|
:include-default-values include-default-values
|
|
:include-namespace-uri include-namespace-uri))
|
|
|
|
(defmethod sax:end-document ((handler xmls-builder))
|
|
(root handler))
|
|
|
|
(defmethod sax:start-element
|
|
((handler xmls-builder) namespace-uri local-name qname attributes)
|
|
(let* ((include-default-values (include-default-values handler))
|
|
(include-namespace-uri (include-namespace-uri handler))
|
|
(attributes
|
|
(loop
|
|
for attr in attributes
|
|
for attr-namespace-uri = (sax:attribute-namespace-uri attr)
|
|
for attr-local-name = (sax:attribute-local-name attr)
|
|
when (and (or (sax:attribute-specified-p attr)
|
|
include-default-values)
|
|
#+(or)
|
|
(or (not include-namespace-uri)
|
|
(not attr-namespace-uri)
|
|
attr-local-name))
|
|
collect
|
|
(list (cond (include-namespace-uri
|
|
(cond (attr-namespace-uri
|
|
(cons attr-local-name attr-namespace-uri))
|
|
(t
|
|
(sax:attribute-qname attr))))
|
|
(t
|
|
(sax:attribute-qname attr)))
|
|
(sax:attribute-value attr))))
|
|
(namespace (when include-namespace-uri namespace-uri))
|
|
(node (make-node :name local-name
|
|
:ns namespace
|
|
:attrs attributes))
|
|
(parent (car (element-stack handler))))
|
|
(if parent
|
|
(push node (node-children parent))
|
|
(setf (root handler) node))
|
|
(push node (element-stack handler))))
|
|
|
|
(defmethod sax:end-element
|
|
((handler xmls-builder) namespace-uri local-name qname)
|
|
(declare (ignore namespace-uri local-name qname))
|
|
(let ((node (pop (element-stack handler))))
|
|
(setf (node-children node) (reverse (node-children node)))))
|
|
|
|
(defmethod sax:characters ((handler xmls-builder) data)
|
|
(let* ((parent (car (element-stack handler)))
|
|
(prev (car (node-children parent))))
|
|
;; Be careful to accept both rods and strings here, so that xmls can be
|
|
;; used with strings even if cxml is configured to use octet string rods.
|
|
(if (typep prev '(or rod string))
|
|
;; um entities herum wird SAX:CHARACTERS mehrfach aufgerufen fuer
|
|
;; den gleichen Textknoten. Hier muessen wir den bestehenden Knoten
|
|
;; erweitern, sonst ist das Dokument nicht normalisiert.
|
|
;; (XXX Oder sollte man besser den Parser entsprechend aendern?)
|
|
(setf (car (node-children parent))
|
|
(concatenate `(vector ,(array-element-type prev))
|
|
prev
|
|
data))
|
|
(push data (node-children parent)))))
|
|
|
|
|
|
;;;; SAX-Treiber (fuer Serialisierung)
|
|
|
|
(defun map-node
|
|
(handler node
|
|
&key (include-xmlns-attributes sax:*include-xmlns-attributes*)
|
|
(include-namespace-uri t))
|
|
(if include-namespace-uri
|
|
(map-node/lnames (cxml:make-namespace-normalizer handler)
|
|
node
|
|
include-xmlns-attributes)
|
|
(map-node/qnames handler node include-xmlns-attributes)))
|
|
|
|
(defun map-node/lnames (handler node include-xmlns-attributes)
|
|
(sax:start-document handler)
|
|
(labels ((walk (node)
|
|
(unless (node-ns node)
|
|
(error "serializing with :INCLUDE-NAMESPACE-URI, but node ~
|
|
was created without namespace URI"))
|
|
(let* ((attlist
|
|
(compute-attributes/lnames node include-xmlns-attributes))
|
|
(uri (node-ns node))
|
|
(lname (node-name node))
|
|
(qname lname) ;let the normalizer fix it
|
|
)
|
|
(sax:start-element handler uri lname qname attlist)
|
|
(dolist (child (node-children node))
|
|
(typecase child
|
|
(list (walk child))
|
|
((or string rod)
|
|
(sax:characters handler (string-rod child)))))
|
|
(sax:end-element handler uri lname qname))))
|
|
(walk node))
|
|
(sax:end-document handler))
|
|
|
|
(defun map-node/qnames (handler node include-xmlns-attributes)
|
|
(sax:start-document handler)
|
|
(labels ((walk (node)
|
|
(when (node-ns node)
|
|
(error "serializing without :INCLUDE-NAMESPACE-URI, but node ~
|
|
was created with a namespace URI"))
|
|
(let* ((attlist
|
|
(compute-attributes/qnames node include-xmlns-attributes))
|
|
(qname (string-rod (node-name node)))
|
|
(lname (nth-value 1 (cxml::split-qname qname))))
|
|
(sax:start-element handler nil lname qname attlist)
|
|
(dolist (child (node-children node))
|
|
(typecase child
|
|
(list (walk child))
|
|
((or string rod)
|
|
(sax:characters handler (string-rod child)))))
|
|
(sax:end-element handler nil lname qname))))
|
|
(walk node))
|
|
(sax:end-document handler))
|
|
|
|
(defun compute-attributes/lnames (node xmlnsp)
|
|
(remove nil
|
|
(mapcar (lambda (a)
|
|
(destructuring-bind (name value) a
|
|
(unless (listp name)
|
|
(setf name (cons name nil)))
|
|
(destructuring-bind (lname &rest uri) name
|
|
(cond
|
|
((not (equal uri "http://www.w3.org/2000/xmlns/"))
|
|
(sax:make-attribute
|
|
;; let the normalizer fix the qname
|
|
:qname (if uri
|
|
(string-rod (concatenate 'string
|
|
"dummy:"
|
|
lname))
|
|
(string-rod lname))
|
|
:local-name (string-rod lname)
|
|
:namespace-uri uri
|
|
:value (string-rod value)
|
|
:specified-p t))
|
|
(xmlnsp
|
|
(sax:make-attribute
|
|
:qname (string-rod
|
|
(if lname
|
|
(concatenate 'string "xmlns:" lname)
|
|
"xmlns"))
|
|
:local-name (string-rod lname)
|
|
:namespace-uri uri
|
|
:value (string-rod value)
|
|
:specified-p t))))))
|
|
(node-attrs node))))
|
|
|
|
(defun compute-attributes/qnames (node xmlnsp)
|
|
(remove nil
|
|
(mapcar (lambda (a)
|
|
(destructuring-bind (name value) a
|
|
(when (listp name)
|
|
(error "serializing without :INCLUDE-NAMESPACE-URI, ~
|
|
but attribute was created with a namespace ~
|
|
URI"))
|
|
(if (or xmlnsp
|
|
(not (cxml::xmlns-attr-p (string-rod name))))
|
|
(sax:make-attribute :qname (string-rod name)
|
|
:value (string-rod value)
|
|
:specified-p t)
|
|
nil)))
|
|
(node-attrs node))))
|
|
|
|
;;;; XPath
|
|
|
|
(defun make-xpath-navigator ()
|
|
(make-instance 'xpath-navigator))
|
|
|
|
(defclass xpath-navigator ()
|
|
((parents :initform (make-hash-table))
|
|
(prefixes :initform (make-hash-table))
|
|
(children :initform (make-hash-table))
|
|
(attributes :initform (make-hash-table))
|
|
(namespaces :initform (make-hash-table))))
|
|
|
|
(defmethod initialize-instance :after ((instance xpath-navigator) &key)
|
|
(with-slots (prefixes) instance
|
|
(setf (gethash "http://www.w3.org/XML/1998/namespace" prefixes)
|
|
"xml")))
|