DOM 2 Core. Ungetestet, aber die 1er tests laufen wieder, daher rein damit.
This commit is contained in:
dlichteblau
@ -96,6 +96,7 @@
|
||||
reported as instances of <tt>well-formedness-violation</tt>. We
|
||||
also print line number information.
|
||||
</li>
|
||||
<li>Support internal subset serialization.</li>
|
||||
<li>Gilbert Baumann has clarified the license as Lisp-LGPL.</li>
|
||||
</ul>
|
||||
<p class="nomargin"><tt>rel-2005-06-25</tt></p>
|
||||
|
||||
@ -103,7 +103,8 @@ $ cvs co cxml</pre>
|
||||
|
||||
<p>
|
||||
<b>Prerequisites.</b>
|
||||
CXML needs the <a href="http://www.cliki.net/Puri">puri</a> library.
|
||||
CXML needs the <a href="http://www.cliki.net/Puri">puri</a> library
|
||||
as well as <a href="http://www.common-lisp.net/project/cl-plus-ssl/#trivial-gray-streams">trivial-gray-streams</a>.
|
||||
</p>
|
||||
|
||||
<p>
|
||||
@ -125,7 +126,7 @@ $ cvs co cxml</pre>
|
||||
$ cvs login # password is "anonymous"
|
||||
$ cvs co 2001/XML-Test-Suite/xmlconf
|
||||
$ cvs co -D '2005-05-06 23:00' 2001/DOM-Test-Suite
|
||||
$ cd 2001/DOM-Test-Suite && ant dom1-dtd</pre>
|
||||
$ cd 2001/DOM-Test-Suite && ant dom1-dtd dom2-dtd</pre>
|
||||
<p>
|
||||
Omit <tt>-D</tt> to get the latest version, which may not work
|
||||
with cxml yet. The <tt>ant</tt> step is necessary to run the DOM
|
||||
|
||||
@ -613,6 +613,8 @@ NIL</pre>
|
||||
<br/>
|
||||
<div class="def">Function SAX:START-DTD (handler name public-id system-id)</div>
|
||||
<div class="def">Function SAX:END-DTD (handler)</div>
|
||||
<div class="def">Function SAX:START-INTERNAL-SUBSET (handler)</div>
|
||||
<div class="def">Function SAX:END-INTERNAL-SUBSET (handler)</div>
|
||||
<div class="def">Function SAX:UNPARSED-ENTITY-DECLARATION (handler name public-id system-id notation-name)</div>
|
||||
<div class="def">Function SAX:EXTERNAL-ENTITY-DECLARATION (handler kind name public-id system-id)</div>
|
||||
<div class="def">Function SAX:INTERNAL-ENTITY-DECLARATION (handler kind name value)</div>
|
||||
@ -623,9 +625,9 @@ NIL</pre>
|
||||
<div class="def">Accessor SAX:ATTRIBUTE-PREFIX (attribute)</div>
|
||||
<div class="def">Accessor SAX:ATTRIBUTE-NAMESPACE-URI (attribute)</div>
|
||||
<div class="def">Accessor SAX:ATTRIBUTE-LOCAL-NAME (attribute)</div>
|
||||
<div class="def">Accessor SAX:ATTRIBUTE-VALUE (attribute)</div>
|
||||
<div class="def">Accessor SAX:ATTRIBUTE-QNAME (attribute)</div>
|
||||
<div class="def">Accessor SAX:ATTRIBUTE-SPECIFIED-P (attribute)</div>
|
||||
<div class="def">Accessor SAX:ATTRIBUTE-VALUE (attribute)</div>
|
||||
</p>
|
||||
<p>
|
||||
The entity declaration methods are similar to Java SAX
|
||||
|
||||
@ -12,7 +12,8 @@
|
||||
|
||||
(defclass dom-builder ()
|
||||
((document :initform nil :accessor document)
|
||||
(element-stack :initform '() :accessor element-stack)))
|
||||
(element-stack :initform '() :accessor element-stack)
|
||||
(internal-subset :accessor internal-subset)))
|
||||
|
||||
(defun dom:make-dom-builder ()
|
||||
(make-instance 'dom-builder))
|
||||
@ -39,26 +40,48 @@
|
||||
(setf (slot-value (document handler) 'entity-resolver) resolver))
|
||||
|
||||
(defmethod sax:start-dtd ((handler dom-builder) name publicid systemid)
|
||||
(declare (ignore publicid systemid))
|
||||
(let* ((document (document handler))
|
||||
(doctype (make-instance 'dom-impl::document-type
|
||||
:name name
|
||||
:notations (make-instance 'dom-impl::named-node-map
|
||||
:element-type :notation
|
||||
:owner document)
|
||||
:entities (make-instance 'dom-impl::named-node-map
|
||||
:element-type :entity
|
||||
:owner document))))
|
||||
(doctype
|
||||
(dom:create-document-type 'implementation name publicid systemid)))
|
||||
(setf (slot-value doctype 'dom-impl::owner) document
|
||||
(slot-value (dom:notations doctype) 'dom-impl::owner) document
|
||||
(slot-value (dom:entities doctype) 'dom-impl::owner) document
|
||||
(slot-value document 'dom-impl::doc-type) doctype)))
|
||||
|
||||
(defmethod sax:start-internal-subset ((handler dom-builder))
|
||||
(setf (internal-subset handler) nil))
|
||||
|
||||
(defmethod sax:end-internal-subset ((handler dom-builder))
|
||||
(setf (internal-subset (slot-value (document handler) 'dom-impl::doc-type))
|
||||
(nreverse (internal-subset handler)))
|
||||
(slot-makunbound handler 'internal-subset))
|
||||
|
||||
(macrolet ((defhandler (name &rest args)
|
||||
`(defmethod ,name ((handler dom-builder) ,@args)
|
||||
(when (slot-boundp handler 'internal-subset)
|
||||
(push (list ',name ,@args) (internal-subset handler))))))
|
||||
(defhandler sax:unparsed-entity-declaration
|
||||
name public-id system-id notation-name)
|
||||
(defhandler sax:external-entity-declaration
|
||||
kind name public-id system-id)
|
||||
(defhandler sax:internal-entity-declaration
|
||||
kind name value)
|
||||
(defhandler sax:notation-declaration
|
||||
name public-id system-id)
|
||||
(defhandler sax:element-declaration
|
||||
name model)
|
||||
(defhandler sax:attribute-declaration
|
||||
element-name attribute-name type default))
|
||||
|
||||
(defmethod sax:start-element
|
||||
((handler dom-builder) namespace-uri local-name qname attributes)
|
||||
(declare (ignore namespace-uri local-name))
|
||||
(with-slots (document element-stack) handler
|
||||
(let ((element (make-instance 'element
|
||||
:tag-name qname
|
||||
:owner document))
|
||||
:owner document
|
||||
:namespace-uri namespace-uri
|
||||
:local-name local-name
|
||||
:prefix (cxml::split-qname (cxml::rod qname))))
|
||||
(parent (car element-stack))
|
||||
(anodes '()))
|
||||
(dolist (attr attributes)
|
||||
@ -68,6 +91,7 @@
|
||||
(dom:create-text-node document (sax:attribute-value attr))))
|
||||
(setf (slot-value anode 'dom-impl::specified-p)
|
||||
(sax:attribute-specified-p attr))
|
||||
(setf (slot-value anode 'dom-impl::owner-element) element)
|
||||
(dom:append-child anode text)
|
||||
(push anode anodes)))
|
||||
(setf (slot-value element 'dom-impl::parent) parent)
|
||||
|
||||
@ -8,7 +8,8 @@
|
||||
;;;; Author: knowledgeTools Int. GmbH
|
||||
|
||||
(defpackage :dom-impl
|
||||
(:use :cl :runes))
|
||||
(:use :cl :runes)
|
||||
(:export #:create-document))
|
||||
|
||||
(in-package :dom-impl)
|
||||
|
||||
@ -33,6 +34,15 @@
|
||||
(read-only-p :initform nil :reader read-only-p)
|
||||
(map :initform nil)))
|
||||
|
||||
(defmethod dom:prefix ((node node)) nil)
|
||||
(defmethod dom:local-name ((node node)) nil)
|
||||
(defmethod dom:namespace-uri ((node node)) nil)
|
||||
|
||||
(defclass namespace-mixin ()
|
||||
((prefix :initarg :prefix :reader dom:prefix)
|
||||
(local-name :initarg :local-name :reader dom:local-name)
|
||||
(namespace-uri :initarg :namespace-uri :reader dom:namespace-uri)))
|
||||
|
||||
(defclass document (node)
|
||||
((doc-type :initarg :doc-type :reader dom:doctype)
|
||||
(dtd :initform nil :reader dtd)
|
||||
@ -44,8 +54,9 @@
|
||||
(defclass character-data (node)
|
||||
((value :initarg :data :reader dom:data)))
|
||||
|
||||
(defclass attribute (node)
|
||||
(defclass attribute (namespace-mixin node)
|
||||
((name :initarg :name :reader dom:name)
|
||||
(owner-element :initarg :owner-element :reader dom:owner-element)
|
||||
(specified-p :initarg :specified-p :reader dom:specified)))
|
||||
|
||||
(defmethod print-object ((object attribute) stream)
|
||||
@ -54,7 +65,7 @@
|
||||
(rod-string (dom:name object))
|
||||
(rod-string (dom:value object)))))
|
||||
|
||||
(defclass element (node)
|
||||
(defclass element (namespace-mixin node)
|
||||
((tag-name :initarg :tag-name :reader dom:tag-name)
|
||||
(attributes :initarg :attributes :reader dom:attributes)))
|
||||
|
||||
@ -73,8 +84,11 @@
|
||||
|
||||
(defclass document-type (node)
|
||||
((name :initarg :name :reader dom:name)
|
||||
(public-id :initarg :public-id :reader dom:public-id)
|
||||
(system-id :initarg :system-id :reader dom:system-id)
|
||||
(entities :initarg :entities :reader dom:entities)
|
||||
(notations :initarg :notations :reader dom:notations)))
|
||||
(notations :initarg :notations :reader dom:notations)
|
||||
(internal-subset :accessor internal-subset)))
|
||||
|
||||
(defclass notation (node)
|
||||
((name :initarg :name :reader dom:name)
|
||||
@ -176,6 +190,45 @@
|
||||
(:NOT_SUPPORTED_ERR 9)
|
||||
(:INUSE_ATTRIBUTE_ERR 10)))
|
||||
|
||||
;; dom-implementation protocol
|
||||
|
||||
(defmethod dom:has-feature ((factory (eql 'implementation)) feature version)
|
||||
(and (or (string-equal (rod-string feature) "xml")
|
||||
(string-equal (rod-string feature) "core"))
|
||||
(or (string-equal (rod-string version) "1.0")
|
||||
(string-equal (rod-string version) "2.0"))))
|
||||
|
||||
(defmethod dom:create-document-type
|
||||
((factory (eql 'implementation)) name publicid systemid)
|
||||
(make-instance 'dom-impl::document-type
|
||||
:name name
|
||||
:notations (make-instance 'dom-impl::named-node-map
|
||||
:element-type :notation
|
||||
:owner nil)
|
||||
:entities (make-instance 'dom-impl::named-node-map
|
||||
:element-type :entity
|
||||
:owner nil)
|
||||
:public-id publicid
|
||||
:system-id systemid))
|
||||
|
||||
(defmethod dom:create-document
|
||||
((factory (eql 'implementation)) uri qname doctype)
|
||||
(let ((document (make-instance 'dom-impl::document)))
|
||||
(setf (slot-value document 'owner) nil
|
||||
(slot-value document 'doc-type) doctype
|
||||
(slot-value document 'namespace-uri) uri)
|
||||
(setf (values (slot-value document 'prefix)
|
||||
(slot-value document 'local-name))
|
||||
(safe-split-qname qname uri))
|
||||
(when doctype
|
||||
(unless (typep doctype 'document-type)
|
||||
(dom-error :WRONG_DOCUMENT_ERR
|
||||
"doctype was created by a different dom implementation"))
|
||||
(setf (slot-value doctype 'dom-impl::owner) document
|
||||
(slot-value (dom:notations doctype) 'dom-impl::owner) document
|
||||
(slot-value (dom:entities doctype) 'dom-impl::owner) document))
|
||||
document))
|
||||
|
||||
;; document-fragment protocol
|
||||
;; document protocol
|
||||
|
||||
@ -191,8 +244,11 @@
|
||||
(setf tag-name (rod tag-name))
|
||||
(unless (cxml::valid-name-p tag-name)
|
||||
(dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string tag-name)))
|
||||
(let ((result (make-instance 'element
|
||||
(let ((result (make-instance 'element
|
||||
:tag-name tag-name
|
||||
:namespace-uri nil
|
||||
:local-name nil
|
||||
:prefix nil
|
||||
:owner document)))
|
||||
(setf (slot-value result 'attributes)
|
||||
(make-instance 'attribute-node-map
|
||||
@ -202,6 +258,41 @@
|
||||
(add-default-attributes result)
|
||||
result))
|
||||
|
||||
(defun safe-split-qname (qname uri)
|
||||
(unless (cxml::valid-name-p qname)
|
||||
(dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string qname)))
|
||||
(multiple-value-bind (prefix local-name)
|
||||
(handler-case
|
||||
(cxml::split-qname qname)
|
||||
(cxml:well-formedness-violation (c)
|
||||
(dom-error :NAMESPACE_ERR "~A" c)))
|
||||
(when prefix
|
||||
(when (and (rod= prefix "xml")
|
||||
(not (rod= uri "http://www.w3.org/XML/1998/namespace")))
|
||||
(dom-error :NAMESPACE_ERR "invalid uri for prefix `xml'"))
|
||||
(when (and (rod= prefix "xmlns")
|
||||
(not (rod= uri "http://www.w3.org/2000/xmlns/")))
|
||||
(dom-error :NAMESPACE_ERR "invalid uri for prefix `xmlns'")))
|
||||
(values prefix local-name)))
|
||||
|
||||
(defmethod dom:create-element-ns ((document document) uri qname)
|
||||
(setf qname (rod qname))
|
||||
(multiple-value-bind (prefix local-name)
|
||||
(safe-split-qname qname uri)
|
||||
(let ((result (make-instance 'element
|
||||
:tag-name qname
|
||||
:namespace-uri uri
|
||||
:local-name local-name
|
||||
:prefix prefix
|
||||
:owner document)))
|
||||
(setf (slot-value result 'attributes)
|
||||
(make-instance 'attribute-node-map
|
||||
:element-type :attribute
|
||||
:owner document
|
||||
:element result))
|
||||
(add-default-attributes result)
|
||||
result)))
|
||||
|
||||
(defmethod dom:create-document-fragment ((document document))
|
||||
(make-instance 'document-fragment
|
||||
:owner document))
|
||||
@ -240,9 +331,25 @@
|
||||
(dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string name)))
|
||||
(make-instance 'attribute
|
||||
:name name
|
||||
:local-name nil
|
||||
:prefix nil
|
||||
:namespace-uri nil
|
||||
:specified-p t
|
||||
:owner document))
|
||||
|
||||
(defmethod dom:create-attribute-ns ((document document) uri qname)
|
||||
(setf uri (rod uri))
|
||||
(setf qname (rod qname))
|
||||
(multiple-value-bind (prefix local-name)
|
||||
(safe-split-qname qname uri)
|
||||
(make-instance 'attribute
|
||||
:name qname
|
||||
:namespace-uri uri
|
||||
:local-name local-name
|
||||
:prefix prefix
|
||||
:specified-p t
|
||||
:owner document)))
|
||||
|
||||
(defmethod dom:create-entity-reference ((document document) name)
|
||||
(setf name (rod name))
|
||||
(unless (cxml::valid-name-p name)
|
||||
@ -253,23 +360,66 @@
|
||||
|
||||
(defmethod get-elements-by-tag-name-internal (node tag-name)
|
||||
(setf tag-name (rod tag-name))
|
||||
(let ((result (make-node-list)))
|
||||
(setf tag-name (rod tag-name))
|
||||
(let ((wild-p (rod= tag-name '#.(string-rod "*"))))
|
||||
(labels ((walk (n)
|
||||
(dovector (c (dom:child-nodes n))
|
||||
(when (dom:element-p c)
|
||||
(when (or wild-p (rod= tag-name (dom:node-name c)))
|
||||
(vector-push-extend c result (extension result)))
|
||||
(walk c)))))
|
||||
(walk node)))
|
||||
(let ((result (make-node-list))
|
||||
(wild-p (rod= tag-name '#.(string-rod "*"))))
|
||||
(labels ((walk (n)
|
||||
(dovector (c (dom:child-nodes n))
|
||||
(when (dom:element-p c)
|
||||
(when (or wild-p (rod= tag-name (dom:node-name c)))
|
||||
(vector-push-extend c result (extension result)))
|
||||
(walk c)))))
|
||||
(walk node))
|
||||
result))
|
||||
|
||||
(defmethod get-elements-by-tag-name-internal-ns (node uri lname)
|
||||
(setf uri (rod uri))
|
||||
(setf lname (rod lname))
|
||||
(let ((result (make-node-list))
|
||||
(wild-uri-p (rod= uri '#.(string-rod "*")))
|
||||
(wild-lname-p (rod= lname '#.(string-rod "*"))))
|
||||
(labels ((walk (n)
|
||||
(dovector (c (dom:child-nodes n))
|
||||
(when (dom:element-p c)
|
||||
(when (and (or wild-lname-p (rod= lname (dom:local-name c)))
|
||||
(or wild-uri-p (rod= uri (dom:namespace-uri c))))
|
||||
(vector-push-extend c result (extension result)))
|
||||
(walk c)))))
|
||||
(walk node))
|
||||
result))
|
||||
|
||||
(defmethod dom:get-elements-by-tag-name ((document document) tag-name)
|
||||
(get-elements-by-tag-name-internal document tag-name))
|
||||
|
||||
(defmethod dom:get-elements-by-tag-name-ns ((document document) uri lname)
|
||||
(get-elements-by-tag-name-internal-ns document uri lname))
|
||||
|
||||
(defmethod dom:get-element-by-id ((document document) id)
|
||||
(block nil
|
||||
(unless (dtd document)
|
||||
(return nil))
|
||||
(setf id (rod id))
|
||||
(labels ((walk (n)
|
||||
(dovector (c (dom:child-nodes n))
|
||||
(when (dom:element-p c)
|
||||
(let ((e (cxml::find-element
|
||||
(cxml::rod (dom:tag-name c))
|
||||
(dtd document))))
|
||||
(when e
|
||||
(dolist (a (cxml::elmdef-attributes e))
|
||||
(when (eq :ID (cxml::attdef-type a))
|
||||
(let* ((name (rod (cxml::attdef-name a)))
|
||||
(value (dom:get-attribute c name)))
|
||||
(when (and value (rod= value id))
|
||||
(return c)))))))
|
||||
(walk c)))))
|
||||
(walk document))))
|
||||
|
||||
|
||||
;;; Node
|
||||
|
||||
(defmethod dom:is-supported ((node node) feature version)
|
||||
(dom:has-feature 'implementation feature version))
|
||||
|
||||
(defmethod dom:parent-node ((node node))
|
||||
(slot-value node 'parent))
|
||||
|
||||
@ -544,29 +694,50 @@
|
||||
(setf name (rod name))
|
||||
(with-slots (items) self
|
||||
(dolist (k items nil)
|
||||
(cond ((rod= name (dom:node-name k))
|
||||
(return k))))))
|
||||
(when (rod= name (dom:node-name k))
|
||||
(return k)))))
|
||||
|
||||
(defmethod dom:set-named-item ((self named-node-map) arg)
|
||||
(assert-writeable self)
|
||||
(unless (eq (dom:node-type arg) (slot-value self 'element-type))
|
||||
(defmethod dom:get-named-item-ns ((self named-node-map) uri lname)
|
||||
(setf uri (rod uri))
|
||||
(setf lname (rod lname))
|
||||
(with-slots (items) self
|
||||
(dolist (k items nil)
|
||||
(when (and (equal uri (dom:namespace-uri k))
|
||||
(equal lname (dom:local-name k)))
|
||||
(return k)))))
|
||||
|
||||
(defun %set-named-item (map arg test)
|
||||
(assert-writeable map)
|
||||
(unless (eq (dom:node-type arg) (slot-value map 'element-type))
|
||||
(dom-error :HIERARCHY_REQUEST_ERR
|
||||
"~S cannot adopt ~S, since it is not of type ~S."
|
||||
self arg (slot-value self 'element-type)))
|
||||
(unless (eq (dom:owner-document self) (dom:owner-document arg))
|
||||
map arg (slot-value map 'element-type)))
|
||||
(unless (eq (dom:owner-document map) (dom:owner-document arg))
|
||||
(dom-error :WRONG_DOCUMENT_ERR
|
||||
"~S cannot adopt ~S, since it was created by a different document."
|
||||
self arg))
|
||||
map arg))
|
||||
(let ((old-map (slot-value arg 'map)))
|
||||
(when (and old-map (not (eq old-map self)))
|
||||
(when (and old-map (not (eq old-map map)))
|
||||
(dom-error :INUSE_ATTRIBUTE_ERR "Attribute node already mapped" arg)))
|
||||
(setf (slot-value arg 'map) self)
|
||||
(setf (slot-value arg 'map) map)
|
||||
(with-slots (items) map
|
||||
(dolist (k items (progn (setf items (cons arg items)) nil))
|
||||
(when (funcall test k)
|
||||
(setf items (cons arg (delete k items)))
|
||||
(return k)))))
|
||||
|
||||
(defmethod dom:set-named-item ((self named-node-map) arg)
|
||||
(let ((name (dom:node-name arg)))
|
||||
(with-slots (items) self
|
||||
(dolist (k items (progn (setf items (cons arg items))nil))
|
||||
(cond ((rod= name (dom:node-name k))
|
||||
(setf items (cons arg (delete k items)))
|
||||
(return k)))))))
|
||||
(%set-named-item self arg (lambda (k) (rod= name (dom:node-name k))))))
|
||||
|
||||
(defmethod dom:set-named-item-ns ((self named-node-map) arg)
|
||||
(let ((uri (dom:namespace-uri arg))
|
||||
(lname (dom:local-name arg)))
|
||||
(%set-named-item self
|
||||
arg
|
||||
(lambda (k)
|
||||
(and (rod= lname (dom:local-name k))
|
||||
(rod= uri (dom:namespace-uri k)))))))
|
||||
|
||||
(defmethod dom:remove-named-item ((self named-node-map) name)
|
||||
(assert-writeable self)
|
||||
@ -577,6 +748,18 @@
|
||||
(setf items (delete k items))
|
||||
(return k))))))
|
||||
|
||||
(defmethod dom:remove-named-item-ns ((self named-node-map) uri lname)
|
||||
(assert-writeable self)
|
||||
(setf uri (rod uri))
|
||||
(setf lname (rod lname))
|
||||
(with-slots (items) self
|
||||
(dolist (k items
|
||||
(dom-error :NOT_FOUND_ERR "~A not found in ~A" lname self))
|
||||
(when (and (rod= lname (dom:local-name k))
|
||||
(rod= uri (dom:namespace-uri k)))
|
||||
(setf items (delete k items))
|
||||
(return k)))))
|
||||
|
||||
(defmethod dom:length ((self named-node-map))
|
||||
(with-slots (items) self
|
||||
(length items)))
|
||||
@ -743,6 +926,15 @@
|
||||
|
||||
;;; ELEMENT
|
||||
|
||||
(defmethod dom:has-attributes ((element element))
|
||||
(plusp (length (dom:items (dom:attributes element)))))
|
||||
|
||||
(defmethod dom:has-attribute ((element element) name)
|
||||
(and (dom:get-named-item (dom:attributes element) name) t))
|
||||
|
||||
(defmethod dom:has-attribute-ns ((element element) uri lname)
|
||||
(and (dom:get-named-item-ns (dom:attributes element) uri lname) t))
|
||||
|
||||
(defmethod dom:get-attribute-node ((element element) name)
|
||||
(dom:get-named-item (dom:attributes element) name))
|
||||
|
||||
@ -750,24 +942,51 @@
|
||||
(assert-writeable element)
|
||||
(dom:set-named-item (dom:attributes element) new-attr))
|
||||
|
||||
(defmethod dom:get-attribute-node-ns ((element element) uri lname)
|
||||
(dom:get-named-item-ns (dom:attributes element) uri lname))
|
||||
|
||||
(defmethod dom:set-attribute-node-ns ((element element) (new-attr attribute))
|
||||
(assert-writeable element)
|
||||
(dom:set-named-item-ns (dom:attributes element) new-attr))
|
||||
|
||||
(defmethod dom:get-attribute ((element element) name)
|
||||
(let ((a (dom:get-attribute-node element name)))
|
||||
(if a
|
||||
(dom:value a)
|
||||
#.(string-rod ""))))
|
||||
|
||||
(defmethod dom:get-attribute-ns ((element element) uri lname)
|
||||
(let ((a (dom:get-attribute-node-ns element uri lname)))
|
||||
(if a
|
||||
(dom:value a)
|
||||
#.(string-rod ""))))
|
||||
|
||||
(defmethod dom:set-attribute ((element element) name value)
|
||||
(assert-writeable element)
|
||||
(with-slots (owner) element
|
||||
(let ((attr (dom:create-attribute owner name)))
|
||||
(setf (slot-value attr 'owner-element) element)
|
||||
(setf (dom:value attr) value)
|
||||
(dom:set-attribute-node element attr))
|
||||
(values)))
|
||||
|
||||
(defmethod dom:set-attribute-ns ((element element) uri lname value)
|
||||
(assert-writeable element)
|
||||
(with-slots (owner) element
|
||||
(let ((attr (dom:create-attribute-ns owner uri lname)))
|
||||
(setf (slot-value attr 'owner-element) element)
|
||||
(setf (dom:value attr) value)
|
||||
(dom:set-attribute-node-ns element attr))
|
||||
(values)))
|
||||
|
||||
(defmethod dom:remove-attribute ((element element) name)
|
||||
(assert-writeable element)
|
||||
(dom:remove-attribute-node element (dom:get-attribute-node element name)))
|
||||
|
||||
(defmethod dom:remove-attribute-ns ((elt element) uri lname)
|
||||
(assert-writeable elt)
|
||||
(dom:remove-attribute-node elt (dom:get-attribute-node-ns elt uri lname)))
|
||||
|
||||
(defmethod dom:remove-attribute-node ((element element) (old-attr attribute))
|
||||
(assert-writeable element)
|
||||
(with-slots (items) (dom:attributes element)
|
||||
@ -781,14 +1000,18 @@
|
||||
|
||||
(defun maybe-add-default-attribute (element name)
|
||||
(let* ((dtd (dtd (slot-value element 'owner)))
|
||||
(e (when dtd (cxml::find-element (dom:tag-name element) dtd)))
|
||||
(e (when dtd (cxml::find-element
|
||||
(cxml::rod (dom:tag-name element))
|
||||
dtd)))
|
||||
(a (when e (cxml::find-attribute e name))))
|
||||
(when (and a (listp (cxml::attdef-default a)))
|
||||
(add-default-attribute element a))))
|
||||
|
||||
(defun add-default-attributes (element)
|
||||
(let* ((dtd (dtd (slot-value element 'owner)))
|
||||
(e (when dtd (cxml::find-element (dom:tag-name element) dtd))))
|
||||
(e (when dtd (cxml::find-element
|
||||
(cxml::rod (dom:tag-name element))
|
||||
dtd))))
|
||||
(when e
|
||||
(dolist (a (cxml::elmdef-attributes e))
|
||||
(when (and a (listp (cxml::attdef-default a)))
|
||||
@ -799,7 +1022,8 @@
|
||||
(owner (slot-value element 'owner))
|
||||
(anode (dom:create-attribute owner (cxml::attdef-name adef)))
|
||||
(text (dom:create-text-node owner value)))
|
||||
(setf (slot-value anode 'dom-impl::specified-p) nil)
|
||||
(setf (slot-value anode 'specified-p) nil)
|
||||
(setf (slot-value anode 'owner-element) element)
|
||||
(dom:append-child anode text)
|
||||
(push anode (slot-value (dom:attributes element) 'items))))
|
||||
|
||||
@ -810,8 +1034,16 @@
|
||||
(assert-writeable element)
|
||||
(get-elements-by-tag-name-internal element name))
|
||||
|
||||
(defmethod dom:normalize ((element element))
|
||||
(defmethod dom:get-elements-by-tag-name-ns ((element element) uri lname)
|
||||
(assert-writeable element)
|
||||
(get-elements-by-tag-name-internal-ns element uri lname))
|
||||
|
||||
(defmethod dom:set-named-item :after ((self attribute-node-map) arg)
|
||||
(setf (slot-value arg 'owner-element)
|
||||
(slot-value self 'element)))
|
||||
|
||||
(defmethod dom:normalize ((node node))
|
||||
(assert-writeable node)
|
||||
(labels ((walk (n)
|
||||
(when (eq (dom:node-type n) :element)
|
||||
(map nil #'walk (dom:items (dom:attributes n))))
|
||||
@ -837,7 +1069,7 @@
|
||||
(setf previous child)
|
||||
(incf i))))))
|
||||
(map nil #'walk (dom:child-nodes n))))
|
||||
(walk element))
|
||||
(walk node))
|
||||
(values))
|
||||
|
||||
;;; TEXT
|
||||
@ -856,7 +1088,17 @@
|
||||
;;; COMMENT -- nix
|
||||
;;; CDATA-SECTION -- nix
|
||||
|
||||
;;; DOCUMENT-TYPE -- missing
|
||||
;;; DOCUMENT-TYPE
|
||||
|
||||
(defmethod dom:internal-subset ((node document-type))
|
||||
;; FIXME: encoding ist falsch, anderen sink nehmen!
|
||||
(if (slot-boundp node 'internal-subset)
|
||||
(with-output-to-string (stream)
|
||||
(let ((sink (cxml:make-character-stream-sink stream)))
|
||||
(dolist (def (internal-subset node))
|
||||
(apply (car def) sink (cdr def)))))
|
||||
nil))
|
||||
|
||||
;;; NOTATION -- nix
|
||||
;;; ENTITY -- nix
|
||||
|
||||
@ -978,6 +1220,9 @@
|
||||
:owner document))
|
||||
(result (import-node-internal 'element document node deep
|
||||
:attributes attributes
|
||||
:namespace-uri (dom:namespace-uri node)
|
||||
:local-name (dom:local-name node)
|
||||
:prefix (dom:prefix node)
|
||||
:tag-name (dom:tag-name node))))
|
||||
(setf (slot-value attributes 'element) result)
|
||||
(dolist (attribute (dom:items (dom:attributes node)))
|
||||
@ -1034,7 +1279,7 @@
|
||||
|
||||
;;; Erweiterung
|
||||
|
||||
(defun dom:create-document (&optional document-element)
|
||||
(defun dom-impl:create-document (&optional document-element)
|
||||
;; Um ein neues Dokumentenobject zu erzeugen, parsen wir einfach ein
|
||||
;; Dummydokument.
|
||||
(let* ((handler (dom:make-dom-builder))
|
||||
|
||||
@ -11,26 +11,41 @@
|
||||
(defun dom:map-document
|
||||
(handler document
|
||||
&key (include-xmlns-attributes sax:*include-xmlns-attributes*)
|
||||
include-doctype
|
||||
include-default-values)
|
||||
(sax:start-document handler)
|
||||
(let ((doctype (dom:doctype document)))
|
||||
(when doctype
|
||||
(sax:start-dtd handler (dom:name doctype) nil nil)
|
||||
;; need notations for canonical mode 2
|
||||
(let* ((ns (dom:notations doctype))
|
||||
(a (make-array (dom:length ns))))
|
||||
;; get them
|
||||
(dotimes (k (dom:length ns))
|
||||
(setf (elt a k) (dom:item ns k)))
|
||||
;; sort them
|
||||
(setf a (sort a #'rod< :key #'dom:name))
|
||||
(loop for n across a do
|
||||
(sax:notation-declaration handler
|
||||
(dom:name n)
|
||||
(dom:public-id n)
|
||||
(dom:system-id n)))
|
||||
;; fixme: entities!
|
||||
(sax:end-dtd handler))))
|
||||
(when include-doctype
|
||||
(let ((doctype (dom:doctype document)))
|
||||
(when doctype
|
||||
(sax:start-dtd handler
|
||||
(dom:name doctype)
|
||||
(dom:public-id doctype)
|
||||
(dom:system-id doctype))
|
||||
(ecase include-doctype
|
||||
(:full-internal-subset
|
||||
(when (slot-boundp doctype 'internal-subset)
|
||||
(sax:start-internal-subset handler)
|
||||
(dolist (def (internal-subset doctype))
|
||||
(apply (car def) handler (cdr def)))
|
||||
(sax:end-internal-subset handler)))
|
||||
(:canonical-notations
|
||||
;; need notations for canonical mode 2
|
||||
(let* ((ns (dom:notations doctype))
|
||||
(a (make-array (dom:length ns))))
|
||||
(when (plusp (dom:length ns))
|
||||
(sax:start-internal-subset handler)
|
||||
;; get them
|
||||
(dotimes (k (dom:length ns))
|
||||
(setf (elt a k) (dom:item ns k)))
|
||||
;; sort them
|
||||
(setf a (sort a #'rod< :key #'dom:name))
|
||||
(loop for n across a do
|
||||
(sax:notation-declaration handler
|
||||
(dom:name n)
|
||||
(dom:public-id n)
|
||||
(dom:system-id n)))
|
||||
(sax:end-internal-subset handler)))))
|
||||
(sax:end-dtd handler))))
|
||||
(labels ((walk (node)
|
||||
(dom:do-node-list (child (dom:child-nodes node))
|
||||
(ecase (dom:node-type child)
|
||||
|
||||
@ -12,7 +12,33 @@
|
||||
;; lisp-specific extensions
|
||||
#:make-dom-builder
|
||||
|
||||
;; methods
|
||||
;; DOM 2 functions
|
||||
#:owner-element
|
||||
#:import-node
|
||||
#:create-element-ns
|
||||
#:create-attribute-ns
|
||||
#:get-elements-by-tag-name-ns
|
||||
#:get-element-by-id
|
||||
#:get-named-item-ns
|
||||
#:set-named-item-ns
|
||||
#:remove-named-item-ns
|
||||
#:is-supported
|
||||
#:has-attributes
|
||||
#:namespace-uri
|
||||
#:prefix
|
||||
#:local-name
|
||||
#:internal-subset
|
||||
#:create-document-type
|
||||
#:create-document
|
||||
#:get-attribute-ns
|
||||
#:set-attribute-ns
|
||||
#:remove-attribute-ns
|
||||
#:get-attribute-node-ns
|
||||
#:set-attribute-node-ns
|
||||
#:has-attribute
|
||||
#:has-attribute-ns
|
||||
|
||||
;; DOM 1 functions
|
||||
#:has-feature
|
||||
#:doctype
|
||||
#:implementation
|
||||
@ -72,7 +98,6 @@
|
||||
#:system-id
|
||||
#:notation-name
|
||||
#:target
|
||||
#:import-node
|
||||
#:code
|
||||
|
||||
;; protocol classes
|
||||
|
||||
@ -1,46 +0,0 @@
|
||||
(in-package :xml)
|
||||
|
||||
;;; Implementation of a simple but faster DOM.
|
||||
|
||||
(defclass simple-document ()
|
||||
((children :initform nil :accessor simple-document-children)))
|
||||
|
||||
(defstruct node
|
||||
parent)
|
||||
|
||||
(defstruct (processing-instruction (:include node))
|
||||
target
|
||||
data)
|
||||
|
||||
(defstruct (text (:include node)
|
||||
(:constructor make-text-boa (parent data)))
|
||||
data)
|
||||
|
||||
(defstruct (element (:include node))
|
||||
gi
|
||||
attributes
|
||||
children)
|
||||
|
||||
(defmethod dom:create-processing-instruction ((document simple-document) target data)
|
||||
(make-processing-instruction :target target :data data))
|
||||
|
||||
(defmethod dom:append-child ((node element) child)
|
||||
(setf (node-parent child) node)
|
||||
(push child (element-children node)))
|
||||
|
||||
(defmethod dom:append-child ((node simple-document) child)
|
||||
(push child (simple-document-children node))
|
||||
nil)
|
||||
|
||||
(defmethod dom:create-element ((document simple-document) name)
|
||||
(make-element :gi name))
|
||||
|
||||
(defmethod dom:set-attribute ((node element) name value)
|
||||
(push (cons name value)
|
||||
(element-attributes node)))
|
||||
|
||||
(defmethod dom:create-text-node ((document simple-document) data)
|
||||
(make-text-boa nil data))
|
||||
|
||||
(defmethod dom:create-cdata-section ((document simple-document) data)
|
||||
(make-text-boa nil data))
|
||||
@ -1,66 +0,0 @@
|
||||
;;; A wrapper package STRING-DOM around the ordinary DOM presents
|
||||
;;; DOMString as Lisp STRING. This was a workaround until
|
||||
;;; RUNE-IS-CHARACTER was implemented, but might still be useful on
|
||||
;;; Lisps without Unicode support.
|
||||
|
||||
(defpackage :string-dom
|
||||
(:use))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(do-external-symbols (var :dom)
|
||||
(let* ((home-package
|
||||
(if (member var '(dom:data dom:name dom:value dom:tag-name
|
||||
dom:node-name dom:node-value
|
||||
dom:substring-data dom:get-attribute
|
||||
dom:set-attribute dom:public-id dom:system-id
|
||||
dom:notation-name dom:target))
|
||||
:string-dom
|
||||
:dom))
|
||||
(symbol (intern (symbol-name var) home-package)))
|
||||
(import symbol :string-dom)
|
||||
(export (list symbol) :string-dom))))
|
||||
|
||||
(defpackage :string-dom-impl (:use :cl))
|
||||
(in-package :string-dom-impl)
|
||||
|
||||
(defun rod-to-string (frob)
|
||||
(if (null frob)
|
||||
nil
|
||||
(map 'string #'code-char frob)))
|
||||
|
||||
(defun string-dom:data (node) (rod-to-string (dom:data node)))
|
||||
(defun string-dom:name (node) (rod-to-string (dom:name node)))
|
||||
(defun string-dom:value (node) (rod-to-string (dom:value node)))
|
||||
(defun string-dom:tag-name (node) (rod-to-string (dom:tag-name node)))
|
||||
(defun string-dom:node-name (node) (rod-to-string (dom:node-name node)))
|
||||
(defun string-dom:node-value (node) (rod-to-string (dom:node-value node)))
|
||||
|
||||
(defun (setf string-dom:data) (newval node)
|
||||
(setf (dom:data node) newval))
|
||||
|
||||
(defun (setf string-dom:value) (newval node)
|
||||
(setf (dom:value node) newval))
|
||||
|
||||
(defun (setf string-dom:node-value) (newval node)
|
||||
(setf (dom:node-value node) newval))
|
||||
|
||||
(defun string-dom:substring-data (node offset count)
|
||||
(rod-to-string (dom:substring-data node offset count)))
|
||||
|
||||
(defun string-dom:get-attribute (elt name)
|
||||
(rod-to-string (dom:get-attribute elt name)))
|
||||
|
||||
(defun string-dom:set-attribute (elt name value)
|
||||
(dom:set-attribute elt (runes:rod name) (runes:rod value)))
|
||||
|
||||
(defun string-dom:public-id (node)
|
||||
(rod-to-string (dom:public-id node)))
|
||||
|
||||
(defun string-dom:system-id (node)
|
||||
(rod-to-string (dom:system-id node)))
|
||||
|
||||
(defun string-dom:notation-name (node)
|
||||
(rod-to-string (dom:notation-name node)))
|
||||
|
||||
(defun string-dom:target (node)
|
||||
(rod-to-string (dom:target node)))
|
||||
@ -1,9 +1,20 @@
|
||||
(in-package :cxml)
|
||||
|
||||
(defun unparse-document-to-octets (doc &rest initargs)
|
||||
(let ((sink (apply #'make-octet-vector-sink initargs)))
|
||||
(dom:map-document sink doc :include-default-values t)))
|
||||
(defun %unparse-document (sink doc canonical)
|
||||
(dom:map-document sink
|
||||
doc
|
||||
:include-doctype (if (and canonical (>= canonical 2))
|
||||
:canonical-notations
|
||||
nil)
|
||||
:include-default-values t))
|
||||
|
||||
(defun unparse-document (doc character-stream &rest initargs)
|
||||
(let ((sink (apply #'make-character-stream-sink character-stream initargs)))
|
||||
(dom:map-document sink doc :include-default-values t)))
|
||||
(defun unparse-document-to-octets (doc &rest initargs &key canonical)
|
||||
(%unparse-document (apply #'make-octet-vector-sink initargs)
|
||||
doc
|
||||
canonical))
|
||||
|
||||
(defun unparse-document (doc character-stream &rest initargs &key canonical)
|
||||
(%unparse-document
|
||||
(apply #'make-character-stream-sink character-stream initargs)
|
||||
doc
|
||||
canonical))
|
||||
|
||||
@ -142,11 +142,14 @@
|
||||
(c = (elt str i))
|
||||
:until (runes:rune= c #.(runes:char-rune #\")))
|
||||
(if (runes:rune= c #.(runes:char-rune #\\))
|
||||
(ecase (progn
|
||||
(let ((frob
|
||||
(progn
|
||||
(incf i)
|
||||
(elt str i))
|
||||
;; ...
|
||||
(#/n (vector-push-extend #/newline v (length v))))
|
||||
(elt str i))))
|
||||
(ecase frob
|
||||
;; ...
|
||||
(#/n (vector-push-extend #/newline v (length v)))
|
||||
((#/\\ #/\") (vector-push-extend #/\\ v (length v)))))
|
||||
(vector-push-extend c v (length v))))
|
||||
(coerce v 'runes::simple-rod)))
|
||||
(t
|
||||
@ -163,13 +166,14 @@
|
||||
|
||||
;;;; dom1-interfaces.xml auslesen
|
||||
|
||||
(defvar *methods* '())
|
||||
(defvar *fields* '())
|
||||
(defparameter *methods* '())
|
||||
(defparameter *fields* '())
|
||||
|
||||
(declaim (special *directory*))
|
||||
(declaim (special *files-directory*))
|
||||
|
||||
(defun read-members ()
|
||||
(let* ((pathname (merge-pathnames "patches/dom1-interfaces.xml" *directory*))
|
||||
(defun read-members (&optional (directory *directory*))
|
||||
(let* ((pathname (merge-pathnames "build/dom2-interfaces.xml" directory))
|
||||
(builder (dom:make-dom-builder))
|
||||
(library (dom:document-element (cxml:parse-file pathname builder)))
|
||||
(methods '())
|
||||
@ -554,8 +558,15 @@
|
||||
(defun assert-have-implementation-attribute (element)
|
||||
(let ((attribute (runes:rod-string (dom:get-attribute element "name"))))
|
||||
(string-case attribute
|
||||
;; fixme: expandEntityReferences sollten wir auch mal anschalten, wo
|
||||
;; wir uns schon die muehe machen...
|
||||
("validating"
|
||||
(setf cxml::*validate* t))
|
||||
("namespaceAware"
|
||||
;; ??? dom 2 ohne namespace-support gibt's doch gar nicht,
|
||||
;; ausser vielleicht in html-only implementationen, und dann sollen
|
||||
;; sie halt auf hasFeature "XML" testen.
|
||||
)
|
||||
(t
|
||||
(format t "~&implementationAttribute ~A not supported, skipping test~%"
|
||||
attribute)
|
||||
@ -606,12 +617,9 @@
|
||||
(defun load-file (name &optional will-be-modified-p)
|
||||
(declare (ignore will-be-modified-p))
|
||||
(setf name (runes:rod-string name))
|
||||
(let* ((directory (merge-pathnames "tests/level1/core/files/" *directory*))
|
||||
(document
|
||||
(cxml:parse-file
|
||||
(make-pathname :name name :type "xml" :defaults directory)
|
||||
(dom:make-dom-builder))))
|
||||
document))
|
||||
(cxml:parse-file
|
||||
(make-pathname :name name :type "xml" :defaults *files-directory*)
|
||||
(dom:make-dom-builder)))
|
||||
|
||||
(defparameter *bad-tests*
|
||||
'("hc_elementnormalize2.xml"
|
||||
@ -628,39 +636,57 @@
|
||||
|
||||
(defun run-all-tests (*directory* &optional verbose)
|
||||
(let* ((cxml::*redefinition-warning* nil)
|
||||
(test-directory (merge-pathnames "tests/level1/core/" *directory*))
|
||||
(all-tests (merge-pathnames "alltests.xml" test-directory))
|
||||
(builder (dom:make-dom-builder))
|
||||
(suite (dom:document-element (cxml:parse-file all-tests builder)))
|
||||
(n 0)
|
||||
(i 0)
|
||||
(ntried 0)
|
||||
(nfailed 0))
|
||||
(do-child-elements (member suite)
|
||||
(unless
|
||||
(or (equal (dom:tag-name member) "metadata")
|
||||
(member (runes:rod-string (dom:get-attribute member "href"))
|
||||
*bad-tests*
|
||||
:test 'equal))
|
||||
(incf n)))
|
||||
(do-child-elements (member suite)
|
||||
(let ((href (runes:rod-string (dom:get-attribute member "href"))))
|
||||
(unless (or (runes:rod= (dom:tag-name member) #"metadata")
|
||||
(member href *bad-tests* :test 'equal))
|
||||
(format t "~&~D/~D ~A~%" i n href)
|
||||
(let ((lisp (slurp-test (merge-pathnames href test-directory))))
|
||||
(when verbose
|
||||
(print lisp))
|
||||
(when lisp
|
||||
(incf ntried)
|
||||
(with-simple-restart (skip-test "Skip this test")
|
||||
(handler-case
|
||||
(let ((cxml::*validate* nil))
|
||||
(funcall (compile nil lisp)))
|
||||
(serious-condition (c)
|
||||
(incf nfailed)
|
||||
(warn "test failed: ~A" c))))))
|
||||
(incf i))))
|
||||
(flet ((parse (test-directory)
|
||||
(let* ((all-tests (merge-pathnames "alltests.xml" test-directory))
|
||||
(builder (dom:make-dom-builder))
|
||||
(suite (dom:document-element
|
||||
(cxml:parse-file all-tests builder)))
|
||||
(*files-directory*
|
||||
(merge-pathnames "files/" test-directory)))
|
||||
(do-child-elements (member suite)
|
||||
(unless
|
||||
(or (equal (dom:tag-name member) "metadata")
|
||||
(member (runes:rod-string
|
||||
(dom:get-attribute member "href"))
|
||||
*bad-tests*
|
||||
:test 'equal))
|
||||
(incf n)))
|
||||
suite))
|
||||
(run (test-directory suite)
|
||||
(print test-directory)
|
||||
(let ((*files-directory*
|
||||
(merge-pathnames "files/" test-directory)))
|
||||
(do-child-elements (member suite)
|
||||
(let ((href (runes:rod-string
|
||||
(dom:get-attribute member "href"))))
|
||||
(unless (or (runes:rod= (dom:tag-name member) #"metadata")
|
||||
(member href *bad-tests* :test 'equal))
|
||||
(format t "~&~D/~D ~A~%" i n href)
|
||||
(let ((lisp (slurp-test
|
||||
(merge-pathnames href test-directory))))
|
||||
(when verbose
|
||||
(print lisp))
|
||||
(when lisp
|
||||
(incf ntried)
|
||||
(with-simple-restart (skip-test "Skip this test")
|
||||
(handler-case
|
||||
(let ((cxml::*validate* nil))
|
||||
(funcall (compile nil lisp)))
|
||||
(serious-condition (c)
|
||||
(incf nfailed)
|
||||
(warn "test failed: ~A" c))))))
|
||||
(incf i)))))))
|
||||
(let* ((d1 (merge-pathnames "tests/level1/core/" *directory*))
|
||||
(d2 (merge-pathnames "tests/level2/core/" *directory*))
|
||||
(suite1 (parse d1))
|
||||
(suite2 (parse d2)))
|
||||
(run d1 suite1)
|
||||
#+(or)
|
||||
(run d2 suite2)))
|
||||
(format t "~&~D/~D tests failed; ~D test~:P were skipped"
|
||||
nfailed ntried (- n ntried))))
|
||||
|
||||
|
||||
@ -1,11 +1,13 @@
|
||||
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SAX; readtable: glisp; Encoding: utf-8; -*-
|
||||
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SAX; readtable: runes; Encoding: utf-8; -*-
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Title: A SAX2-like API for the xml parser
|
||||
;;; Created: 2003-06-30
|
||||
;;; Author: Henrik Motakef <hmot@henrik-motakef.de>
|
||||
;;; Author: David Lichteblau (DTD-related changes)
|
||||
;;; License: BSD
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; <20> copyright 2003 by Henrik Motakef
|
||||
;;; <20> copyright 2004 knowledgeTools Int. GmbH
|
||||
|
||||
;;; Redistribution and use in source and binary forms, with or without
|
||||
;;; modification, are permitted provided that the following conditions are
|
||||
@ -40,23 +42,22 @@
|
||||
;; * document-locator/(setf document-locator)
|
||||
;; (probably implies a handler class with an appropriate slot)
|
||||
;; * skipped-entity
|
||||
;; * notation-declaration
|
||||
;; * unparsed-entity-declaration
|
||||
;; * The whole ErrorHandler class, this is better handled using
|
||||
;; conditions (but isn't yet)
|
||||
;; * The LexicalHandler (start-cdata etc) would be nice
|
||||
;; * The DeclHandler interface (element-decl, attribute-decl...)
|
||||
;; is useful, but the Java interface sucks.
|
||||
;; o Despite all the namespace-uri etc arguments, namespaces are not
|
||||
;; really supported yet, the xml parser always passes nil. This will
|
||||
;; hopefully change Real Soon Now, and I didn't want to have to
|
||||
;; rewrite the interface then
|
||||
;; * The LexicalHandler (start-cdata etc) would be nice [-- partly done]
|
||||
|
||||
(defpackage :sax
|
||||
(:use :common-lisp)
|
||||
(:export #:*namespace-processing*
|
||||
#:*include-xmlns-attributes*
|
||||
#:*use-xmlns-namespace*
|
||||
|
||||
#:make-attribute
|
||||
#:attribute-namespace-uri
|
||||
#:attribute-local-name
|
||||
#:attribute-qname
|
||||
#:attribute-value
|
||||
#:attribute-specified-p
|
||||
|
||||
#:start-document
|
||||
#:start-prefix-mapping
|
||||
@ -68,7 +69,18 @@
|
||||
#:end-document
|
||||
#:comment
|
||||
#:start-cdata
|
||||
#:end-cdata))
|
||||
#:end-cdata
|
||||
#:start-dtd
|
||||
#:end-dtd
|
||||
#:start-internal-subset
|
||||
#:end-internal-subset
|
||||
#:unparsed-entity-declaration
|
||||
#:external-entity-declaration
|
||||
#:internal-entity-declaration
|
||||
#:notation-declaration
|
||||
#:element-declaration
|
||||
#:attribute-declaration
|
||||
#:entity-resolver))
|
||||
|
||||
(in-package :sax)
|
||||
|
||||
@ -118,6 +130,13 @@ qname: #\"xmlns:ex\"
|
||||
Setting this variable has no effect unless both
|
||||
`*namespace-processing*' and `*include-xmlns-attributes*' are non-nil.")
|
||||
|
||||
(defstruct attribute
|
||||
namespace-uri
|
||||
local-name
|
||||
qname
|
||||
value
|
||||
specified-p)
|
||||
|
||||
(defgeneric start-document (handler)
|
||||
(:documentation "Called at the beginning of the parsing process,
|
||||
before any element, processing instruction or comment is reported.
|
||||
@ -126,9 +145,6 @@ Handlers that need to maintain internal state may use this to perform
|
||||
any neccessary initializations.")
|
||||
(:method ((handler t)) nil))
|
||||
|
||||
;; How should attributes be represented?
|
||||
;; Currently its just a (name . value) alist, but this isn't too
|
||||
;; useful wrt namespaced attributes. Probably a struct.
|
||||
(defgeneric start-element (handler namespace-uri local-name qname attributes)
|
||||
(:documentation "Called to report the beginning of an element.
|
||||
|
||||
@ -147,7 +163,9 @@ local-name properties, the same rules as for the element name
|
||||
apply. Additionally, namespace-declaring attributes (those whose name
|
||||
is \"xmlns\" or starts with \"xmlns:\") are only included if
|
||||
*namespace-prefixes* is non-nil.")
|
||||
(:method ((handler t) namespace-uri local-name qname attributes) nil))
|
||||
(:method ((handler t) namespace-uri local-name qname attributes)
|
||||
(declare (ignore namespace-uri local-name qname attributes))
|
||||
nil))
|
||||
|
||||
(defgeneric start-prefix-mapping (handler prefix uri)
|
||||
(:documentation "Called when the scope of a new prefix -> namespace-uri mapping begins.
|
||||
@ -159,7 +177,7 @@ Clients don't usually have to implement this except under special
|
||||
circumstances, for example when they have to deal with qualified names
|
||||
in textual content. The parser will handle namespaces of elements and
|
||||
attributes on its own.")
|
||||
(:method ((handler t) prefix uri) nil))
|
||||
(:method ((handler t) prefix uri) (declare (ignore prefix uri)) nil))
|
||||
|
||||
(defgeneric characters (handler data)
|
||||
(:documentation "Called for textual element content.
|
||||
@ -167,13 +185,13 @@ attributes on its own.")
|
||||
The data is passed as a rod, with all entity references resolved.
|
||||
It is possible that the character content of an element is reported
|
||||
via multiple subsequent calls to this generic function.")
|
||||
(:method ((handler t) data) nil))
|
||||
(:method ((handler t) data) (declare (ignore data)) nil))
|
||||
|
||||
(defgeneric processing-instruction (handler target data)
|
||||
(:documentation "Called when a processing instruction is read.
|
||||
|
||||
Both target and data are rods.")
|
||||
(:method ((handler t) target data) nil))
|
||||
(:method ((handler t) target data) (declare (ignore target data)) nil))
|
||||
|
||||
(defgeneric end-prefix-mapping (handler prefix)
|
||||
(:documentation "Called when a prefix -> namespace-uri mapping goes out of scope.
|
||||
@ -186,14 +204,16 @@ Clients don't usually have to implement this except under special
|
||||
circumstances, for example when they have to deal with qualified names
|
||||
in textual content. The parser will handle namespaces of elements and
|
||||
attributes on its own.")
|
||||
(:method ((handler t) prefix) nil))
|
||||
(:method ((handler t) prefix) prefix nil))
|
||||
|
||||
(defgeneric end-element (handler namespace-uri local-name qname)
|
||||
(:documentation "Called to report the end of an element.
|
||||
|
||||
See the documentation for `start-element' for a description of the
|
||||
parameters.")
|
||||
(:method ((handler t) namespace-uri local-name qname) nil))
|
||||
(:method ((handler t) namespace-uri local-name qname)
|
||||
(declare (ignore namespace-uri local-name qname))
|
||||
nil))
|
||||
|
||||
(defgeneric end-document (handler)
|
||||
(:documentation "Called at the end of parsing a document.
|
||||
@ -206,7 +226,7 @@ is significant, it will be returned by the parse-file/stream/string function.")
|
||||
;; LexicalHandler
|
||||
|
||||
(defgeneric comment (handler data)
|
||||
(:method ((handler t) data) nil))
|
||||
(:method ((handler t) data) data nil))
|
||||
|
||||
(defgeneric start-cdata (handler)
|
||||
(:documentation "Called at the beginning of parsing a CDATA section.
|
||||
@ -224,4 +244,88 @@ Handlers only have to implement this if they are interested in the
|
||||
lexical structure of the parsed document. The content of the CDATA
|
||||
section is reported via the `characters' generic function like all
|
||||
other textual content.")
|
||||
(:method ((handler t)) nil))
|
||||
(:method ((handler t)) nil))
|
||||
|
||||
(defgeneric start-dtd (handler name public-id system-id)
|
||||
(:documentation "Called at the beginning of parsing a DTD.")
|
||||
(:method ((handler t) name public-id system-id)
|
||||
(declare (ignore name public-id system-id))
|
||||
nil))
|
||||
|
||||
(defgeneric end-dtd (handler)
|
||||
(:documentation "Called at the end of parsing a DTD.")
|
||||
(:method ((handler t)) nil))
|
||||
|
||||
(defgeneric start-internal-subset (handler)
|
||||
(:documentation "Reports that an internal subset is present. Called before
|
||||
any definition from the internal subset is reported.")
|
||||
(:method ((handler t)) nil))
|
||||
|
||||
(defgeneric end-internal-subset (handler)
|
||||
(:documentation "Called after processing of the internal subset has
|
||||
finished, if present.")
|
||||
(:method ((handler t)) nil))
|
||||
|
||||
(defgeneric unparsed-entity-declaration
|
||||
(handler name public-id system-id notation-name)
|
||||
(:documentation
|
||||
"Called when an unparsed entity declaration is seen in a DTD.")
|
||||
(:method ((handler t) name public-id system-id notation-name)
|
||||
(declare (ignore name public-id system-id notation-name))
|
||||
nil))
|
||||
|
||||
(defgeneric external-entity-declaration
|
||||
(handler kind name public-id system-id)
|
||||
(:documentation
|
||||
"Called when a parsed external entity declaration is seen in a DTD.")
|
||||
(:method ((handler t) kind name public-id system-id)
|
||||
(declare (ignore kind name public-id system-id))
|
||||
nil))
|
||||
|
||||
(defgeneric internal-entity-declaration
|
||||
(handler kind name value)
|
||||
(:documentation
|
||||
"Called when an internal entity declaration is seen in a DTD.")
|
||||
(:method ((handler t) kind name value)
|
||||
(declare (ignore kind name value))
|
||||
nil))
|
||||
|
||||
(defgeneric notation-declaration
|
||||
(handler name public-id system-id)
|
||||
(:documentation
|
||||
"Called when a notation declaration is seen while parsing a DTD.")
|
||||
(:method ((handler t) name public-id system-id)
|
||||
(declare (ignore name public-id system-id))
|
||||
nil))
|
||||
|
||||
(defgeneric element-declaration (handler name model)
|
||||
(:documentation
|
||||
"Called when a element declaration is seen in a DTD. Model is not a string,
|
||||
but a nested list, with *, ?, +, OR, and AND being the operators, rods
|
||||
as names, :EMPTY and :PCDATA as special tokens. (AND represents
|
||||
sequences.)")
|
||||
(:method ((handler t) name model)
|
||||
(declare (ignore name model))
|
||||
nil))
|
||||
|
||||
(defgeneric attribute-declaration
|
||||
(handler element-name attribute-name type default)
|
||||
(:documentation
|
||||
"Called when an attribute declaration is seen in a DTD.
|
||||
type one of :CDATA, :ID, :IDREF, :IDREFS,
|
||||
:ENTITY, :ENTITIES, :NMTOKEN, :NMTOKENS,
|
||||
(:NOTATION <name>*), or (:ENUMERATION <name>*)
|
||||
default :REQUIRED, :IMPLIED, (:FIXED content), or (:DEFAULT content)")
|
||||
(:method ((handler t) element-name attribute-name type value)
|
||||
(declare (ignore element-name attribute-name type value))
|
||||
nil))
|
||||
|
||||
(defgeneric entity-resolver
|
||||
(handler resolver)
|
||||
(:documentation
|
||||
"Called between sax:end-dtd and sax:end-document to register an entity
|
||||
resolver, a function of two arguments: An entity name and SAX handler.
|
||||
When called, the resolver function will parse the named entities data.")
|
||||
(:method ((handler t) resolver)
|
||||
(declare (ignore resolver))
|
||||
nil))
|
||||
|
||||
199
xml/unparse.lisp
199
xml/unparse.lisp
@ -7,9 +7,9 @@
|
||||
;;; Author: David Lichteblau <david@lichteblau.com>
|
||||
;;; License: Lisp-LGPL (See file COPYING for details).
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; © copyright 1999 by Gilbert Baumann
|
||||
;;; © copyright 2004 by knowledgeTools Int. GmbH
|
||||
;;; © copyright 2004 by David Lichteblau (for headcraft.de)
|
||||
;;; <EFBFBD><EFBFBD> copyright 1999 by Gilbert Baumann
|
||||
;;; <EFBFBD><EFBFBD> copyright 2004 by knowledgeTools Int. GmbH
|
||||
;;; <EFBFBD><EFBFBD> copyright 2004 by David Lichteblau (for headcraft.de)
|
||||
|
||||
;;; This library is free software; you can redistribute it and/or
|
||||
;;; modify it under the terms of the GNU Library General Public
|
||||
@ -184,42 +184,185 @@
|
||||
(unparse-string public-id sink)
|
||||
(write-rod #"\"" sink)))))
|
||||
|
||||
(defmethod sax:start-internal-subset ((sink sink))
|
||||
(ensure-doctype sink)
|
||||
(write-rod #" [" sink)
|
||||
(write-rune #/U+000A sink))
|
||||
|
||||
(defmethod sax:end-internal-subset ((sink sink))
|
||||
(ensure-doctype sink)
|
||||
(write-rod #"]" sink))
|
||||
|
||||
(defmethod sax:notation-declaration ((sink sink) name public-id system-id)
|
||||
(when (and (canonical sink) (>= (canonical sink) 2))
|
||||
(let ((prev (previous-notation sink)))
|
||||
(cond
|
||||
(prev
|
||||
(unless (rod< prev name)
|
||||
(error "misordered notations; cannot unparse canonically")))
|
||||
(t
|
||||
(ensure-doctype sink)
|
||||
(write-rod #" [" sink)
|
||||
(write-rune #/U+000A sink)))
|
||||
(setf (previous-notation sink) name))
|
||||
(write-rod #"<!NOTATION " sink)
|
||||
(let ((prev (previous-notation sink)))
|
||||
(when (and (and (canonical sink) (>= (canonical sink) 2))
|
||||
prev
|
||||
(not (rod< prev name)))
|
||||
(error "misordered notations; cannot unparse canonically"))
|
||||
(setf (previous-notation sink) name))
|
||||
(write-rod #"<!NOTATION " sink)
|
||||
(write-rod name sink)
|
||||
(cond
|
||||
((zerop (length public-id))
|
||||
(write-rod #" SYSTEM '" sink)
|
||||
(write-rod system-id sink)
|
||||
(write-rune #/' sink))
|
||||
((zerop (length system-id))
|
||||
(write-rod #" PUBLIC '" sink)
|
||||
(write-rod public-id sink)
|
||||
(write-rune #/' sink))
|
||||
(t
|
||||
(write-rod #" PUBLIC '" sink)
|
||||
(write-rod public-id sink)
|
||||
(write-rod #"' '" sink)
|
||||
(write-rod system-id sink)
|
||||
(write-rune #/' sink)))
|
||||
(write-rune #/> sink)
|
||||
(write-rune #/U+000A sink))
|
||||
|
||||
(defmethod sax:unparsed-entity-declaration
|
||||
((sink sink) name public-id system-id notation-name)
|
||||
(unless (and (canonical sink) (< (canonical sink) 3))
|
||||
(write-rod #"<!ENTITY " sink)
|
||||
(write-rod name sink)
|
||||
(cond
|
||||
((zerop (length public-id))
|
||||
(write-rod #" SYSTEM '" sink)
|
||||
(write-rod system-id sink)
|
||||
(write-rune #/' sink))
|
||||
(write-rod #" SYSTEM '" sink)
|
||||
(write-rod system-id sink)
|
||||
(write-rune #/' sink))
|
||||
((zerop (length system-id))
|
||||
(write-rod #" PUBLIC '" sink)
|
||||
(write-rod public-id sink)
|
||||
(write-rune #/' sink))
|
||||
(write-rod #" PUBLIC '" sink)
|
||||
(write-rod public-id sink)
|
||||
(write-rune #/' sink))
|
||||
(t
|
||||
(write-rod #" PUBLIC '" sink)
|
||||
(write-rod public-id sink)
|
||||
(write-rod #"' '" sink)
|
||||
(write-rod system-id sink)
|
||||
(write-rune #/' sink)))
|
||||
(write-rod #" PUBLIC '" sink)
|
||||
(write-rod public-id sink)
|
||||
(write-rod #"' '" sink)
|
||||
(write-rod system-id sink)
|
||||
(write-rune #/' sink)))
|
||||
(write-rod #" NDATA " sink)
|
||||
(write-rod notation-name sink)
|
||||
(write-rune #/> sink)
|
||||
(write-rune #/U+000A sink)))
|
||||
|
||||
(defmethod sax:external-entity-declaration
|
||||
((sink sink) kind name public-id system-id)
|
||||
(when (canonical sink)
|
||||
(error "cannot serialize parsed entities in canonical mode"))
|
||||
(write-rod #"<!ENTITY " sink)
|
||||
(when (eq kind :parameter)
|
||||
(write-rod #" % " sink))
|
||||
(write-rod name sink)
|
||||
(cond
|
||||
((zerop (length public-id))
|
||||
(write-rod #" SYSTEM '" sink)
|
||||
(write-rod system-id sink)
|
||||
(write-rune #/' sink))
|
||||
((zerop (length system-id))
|
||||
(write-rod #" PUBLIC '" sink)
|
||||
(write-rod public-id sink)
|
||||
(write-rune #/' sink))
|
||||
(t
|
||||
(write-rod #" PUBLIC '" sink)
|
||||
(write-rod public-id sink)
|
||||
(write-rod #"' '" sink)
|
||||
(write-rod system-id sink)
|
||||
(write-rune #/' sink)))
|
||||
(write-rune #/> sink)
|
||||
(write-rune #/U+000A sink))
|
||||
|
||||
(defmethod sax:internal-entity-declaration ((sink sink) kind name value)
|
||||
(when (canonical sink)
|
||||
(error "cannot serialize parsed entities in canonical mode"))
|
||||
(write-rod #"<!ENTITY " sink)
|
||||
(when (eq kind :parameter)
|
||||
(write-rod #" % " sink))
|
||||
(write-rod name sink)
|
||||
(write-rune #/U+0020 sink)
|
||||
(write-rune #/\" sink)
|
||||
(unparse-string value sink)
|
||||
(write-rune #/\" sink)
|
||||
(write-rune #/> sink)
|
||||
(write-rune #/U+000A sink))
|
||||
|
||||
(defmethod sax:element-declaration ((sink sink) name model)
|
||||
(when (canonical sink)
|
||||
(error "cannot serialize element type declarations in canonical mode"))
|
||||
(write-rod #"<!ELEMENT " sink)
|
||||
(write-rod name sink)
|
||||
(write-rune #/U+0020 sink)
|
||||
(labels ((walk (m)
|
||||
(cond
|
||||
((eq m :EMPTY)
|
||||
(write-rod "EMPTY" sink))
|
||||
((eq m :PCDATA)
|
||||
(write-rod "#PCDATA" sink))
|
||||
((atom m)
|
||||
(unparse-string m sink))
|
||||
(t
|
||||
(ecase (car m)
|
||||
(and
|
||||
(write-rune #/\( sink)
|
||||
(loop for (n . rest) on (cdr m) do
|
||||
(walk n)
|
||||
(when rest
|
||||
(write-rune #\, sink)))
|
||||
(write-rune #/\) sink))
|
||||
(or
|
||||
(write-rune #/\( sink)
|
||||
(loop for (n . rest) on (cdr m) do
|
||||
(walk n)
|
||||
(when rest
|
||||
(write-rune #\| sink)))
|
||||
(write-rune #/\) sink))
|
||||
(*
|
||||
(walk (second m))
|
||||
(write-rod #/* sink))
|
||||
(+
|
||||
(walk (second m))
|
||||
(write-rod #/+ sink))
|
||||
(?
|
||||
(walk (second m))
|
||||
(write-rod #/? sink)))))))
|
||||
(walk model))
|
||||
(write-rune #/> sink)
|
||||
(write-rune #/U+000A sink))
|
||||
|
||||
(defmethod sax:attribute-declaration ((sink sink) ename aname type default)
|
||||
(when (canonical sink)
|
||||
(error "cannot serialize attribute type declarations in canonical mode"))
|
||||
(write-rod #"<!ATTLIST " sink)
|
||||
(write-rod ename sink)
|
||||
(write-rune #/U+0020 sink)
|
||||
(write-rod aname sink)
|
||||
(write-rune #/U+0020 sink)
|
||||
(cond
|
||||
((atom type)
|
||||
(write-rod (rod (string-upcase (symbol-name type))) sink))
|
||||
(t
|
||||
(when (eq :NOTATION (car type))
|
||||
(write-rod #"NOTATION " sink))
|
||||
(write-rune #/\( sink)
|
||||
(loop for (n . rest) on (cdr type) do
|
||||
(write-rod n sink)
|
||||
(when rest
|
||||
(write-rune #\| sink)))
|
||||
(write-rune #/\) sink)))
|
||||
(cond
|
||||
((atom default)
|
||||
(write-rune #/# sink)
|
||||
(write-rod (rod (string-upcase (symbol-name default))) sink))
|
||||
(t
|
||||
(when (eq :FIXED (car default))
|
||||
(write-rod #"#FIXED " sink))
|
||||
(write-rune #/\" sink)
|
||||
(unparse-string (second default) sink)
|
||||
(write-rune #/\" sink)))
|
||||
(write-rune #/> sink)
|
||||
(write-rune #/U+000A sink))
|
||||
|
||||
(defmethod sax:end-dtd ((sink sink))
|
||||
(when (have-doctype sink)
|
||||
(when (previous-notation sink)
|
||||
(write-rod #"]" sink))
|
||||
(write-rod #">" sink)
|
||||
(write-rune #/U+000A sink)))
|
||||
|
||||
|
||||
@ -1517,7 +1517,6 @@
|
||||
delim))))))
|
||||
|
||||
(defun read-character-reference (input)
|
||||
;; xxx eof handling
|
||||
;; The #/& is already read
|
||||
(let ((res
|
||||
(let ((c (read-rune input)))
|
||||
@ -2080,9 +2079,9 @@
|
||||
;;; to indicate whether the end tag is valid.
|
||||
;;;
|
||||
;;; Function B will be called with the character data rod as its argument, it
|
||||
;;; returns a boolean indicating whether this text element is allowed.
|
||||
;;; returns a boolean indicating whether this text node is allowed.
|
||||
;;;
|
||||
;;; That is, if one of the functions ever returns NIL, the element is
|
||||
;;; That is, if one of the functions ever returns NIL, the node is
|
||||
;;; rejected as invalid.
|
||||
|
||||
(defun cmodel-done (actual-value)
|
||||
@ -2471,6 +2470,7 @@
|
||||
(wf-error input "document includes an internal subset"))
|
||||
(ensure-dtd)
|
||||
(consume-token input)
|
||||
(sax:start-internal-subset (handler *ctx*))
|
||||
(while (progn (p/S? input)
|
||||
(not (eq (peek-token input) :\] )))
|
||||
(if (eq (peek-token input) :PE-REFERENCE)
|
||||
@ -2487,6 +2487,7 @@
|
||||
(let ((*expand-pe-p* t))
|
||||
(p/markup-decl input))))
|
||||
(consume-token input)
|
||||
(sax:end-internal-subset (handler *ctx*))
|
||||
(p/S? input))
|
||||
(expect input :>)
|
||||
(when extid
|
||||
|
||||
Reference in New Issue
Block a user