utf8-dom
This commit is contained in:
dlichteblau
@ -8,14 +8,19 @@
|
||||
;;;; Author: David Lichteblau <david@lichteblau.com>
|
||||
;;;; Author: knowledgeTools Int. GmbH
|
||||
|
||||
(in-package :dom-impl)
|
||||
#-cxml-system::utf8dom-file
|
||||
(in-package :rune-dom)
|
||||
|
||||
#+cxml-system::utf8dom-file
|
||||
(in-package :utf8-dom)
|
||||
|
||||
|
||||
(defclass dom-builder ()
|
||||
((document :initform nil :accessor document)
|
||||
(element-stack :initform '() :accessor element-stack)
|
||||
(internal-subset :accessor internal-subset)))
|
||||
|
||||
(defun dom:make-dom-builder ()
|
||||
(defun make-dom-builder ()
|
||||
(make-instance 'dom-builder))
|
||||
|
||||
(defun fast-push (new-element vector)
|
||||
@ -26,9 +31,9 @@
|
||||
(not (and sax:*include-xmlns-attributes*
|
||||
sax:*use-xmlns-namespace*)))
|
||||
(error "SAX configuration is incompatible with DOM: *namespace-processing* is activated, but *include-xmlns-attributes* or *use-xmlns-namespace* are not"))
|
||||
(let ((document (make-instance 'dom-impl::document)))
|
||||
(setf (slot-value document 'dom-impl::owner) nil
|
||||
(slot-value document 'dom-impl::doc-type) nil)
|
||||
(let ((document (make-instance 'document)))
|
||||
(setf (slot-value document 'owner) nil
|
||||
(slot-value document 'doc-type) nil)
|
||||
(setf (document handler) document)
|
||||
(push document (element-stack handler))))
|
||||
|
||||
@ -46,16 +51,16 @@
|
||||
(defmethod sax:start-dtd ((handler dom-builder) name publicid systemid)
|
||||
(let* ((document (document handler))
|
||||
(doctype (%create-document-type 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)))
|
||||
(setf (slot-value doctype 'owner) document
|
||||
(slot-value (dom:notations doctype) 'owner) document
|
||||
(slot-value (dom:entities doctype) 'owner) document
|
||||
(slot-value document '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))
|
||||
(setf (dom::%internal-subset (slot-value (document handler) 'doc-type))
|
||||
(nreverse (internal-subset handler)))
|
||||
(slot-makunbound handler 'internal-subset))
|
||||
|
||||
@ -78,6 +83,7 @@
|
||||
|
||||
(defmethod sax:start-element
|
||||
((handler dom-builder) namespace-uri local-name qname attributes)
|
||||
(check-type qname rod)
|
||||
(with-slots (document element-stack) handler
|
||||
(let* ((nsp sax:*namespace-processing*)
|
||||
(element (make-instance 'element
|
||||
@ -85,7 +91,7 @@
|
||||
:owner document
|
||||
:namespace-uri (when nsp namespace-uri)
|
||||
:local-name (when nsp local-name)
|
||||
:prefix (when nsp (cxml::split-qname (cxml::rod qname)))))
|
||||
:prefix (%rod (when nsp (cxml::split-qname (real-rod qname))))))
|
||||
(parent (car element-stack))
|
||||
(anodes '()))
|
||||
(dolist (attr attributes)
|
||||
@ -97,20 +103,20 @@
|
||||
(dom:create-attribute document (sax:attribute-qname attr))))
|
||||
(text
|
||||
(dom:create-text-node document (sax:attribute-value attr))))
|
||||
(setf (slot-value anode 'dom-impl::specified-p)
|
||||
(setf (slot-value anode 'specified-p)
|
||||
(sax:attribute-specified-p attr))
|
||||
(setf (slot-value anode 'dom-impl::owner-element) element)
|
||||
(setf (slot-value anode 'owner-element) element)
|
||||
(dom:append-child anode text)
|
||||
(push anode anodes)))
|
||||
(setf (slot-value element 'dom-impl::parent) parent)
|
||||
(fast-push element (slot-value parent 'dom-impl::children))
|
||||
(setf (slot-value element 'parent) parent)
|
||||
(fast-push element (slot-value parent 'children))
|
||||
(let ((map
|
||||
(make-instance 'attribute-node-map
|
||||
:items anodes
|
||||
:element-type :attribute
|
||||
:element element
|
||||
:owner document)))
|
||||
(setf (slot-value element 'dom-impl::attributes) map)
|
||||
(setf (slot-value element 'attributes) map)
|
||||
(dolist (anode anodes)
|
||||
(setf (slot-value anode 'map) map)))
|
||||
(push element element-stack))))
|
||||
@ -134,15 +140,15 @@
|
||||
(dom:append-data last-child data))
|
||||
(t
|
||||
(let ((node (dom:create-text-node document data)))
|
||||
(setf (slot-value node 'dom-impl::parent) parent)
|
||||
(fast-push node (slot-value (car element-stack) 'dom-impl::children))))))))
|
||||
(setf (slot-value node 'parent) parent)
|
||||
(fast-push node (slot-value (car element-stack) 'children))))))))
|
||||
|
||||
(defmethod sax:start-cdata ((handler dom-builder))
|
||||
(with-slots (document element-stack) handler
|
||||
(let ((node (dom:create-cdata-section document #""))
|
||||
(parent (car element-stack)))
|
||||
(setf (slot-value node 'dom-impl::parent) parent)
|
||||
(fast-push node (slot-value parent 'dom-impl::children))
|
||||
(setf (slot-value node 'parent) parent)
|
||||
(fast-push node (slot-value parent 'children))
|
||||
(push node element-stack))))
|
||||
|
||||
(defmethod sax:end-cdata ((handler dom-builder))
|
||||
@ -153,15 +159,15 @@
|
||||
(with-slots (document element-stack) handler
|
||||
(let ((node (dom:create-processing-instruction document target data))
|
||||
(parent (car element-stack)))
|
||||
(setf (slot-value node 'dom-impl::parent) parent)
|
||||
(fast-push node (slot-value (car element-stack) 'dom-impl::children)))))
|
||||
(setf (slot-value node 'parent) parent)
|
||||
(fast-push node (slot-value (car element-stack) 'children)))))
|
||||
|
||||
(defmethod sax:comment ((handler dom-builder) data)
|
||||
(with-slots (document element-stack) handler
|
||||
(let ((node (dom:create-comment document data))
|
||||
(parent (car element-stack)))
|
||||
(setf (slot-value node 'dom-impl::parent) parent)
|
||||
(fast-push node (slot-value (car element-stack) 'dom-impl::children)))))
|
||||
(setf (slot-value node 'parent) parent)
|
||||
(fast-push node (slot-value (car element-stack) 'children)))))
|
||||
|
||||
(defmethod sax:unparsed-entity-declaration
|
||||
((handler dom-builder) name public-id system-id notation-name)
|
||||
@ -182,7 +188,7 @@
|
||||
|
||||
(defun set-entity (handler name pid sid notation)
|
||||
(dom:set-named-item (dom:entities (dom:doctype (document handler)))
|
||||
(make-instance 'dom-impl::entity
|
||||
(make-instance 'entity
|
||||
:owner (document handler)
|
||||
:name name
|
||||
:public-id pid
|
||||
@ -192,7 +198,7 @@
|
||||
(defmethod sax:notation-declaration
|
||||
((handler dom-builder) name public-id system-id)
|
||||
(dom:set-named-item (dom:notations (dom:doctype (document handler)))
|
||||
(make-instance 'dom-impl::notation
|
||||
(make-instance 'notation
|
||||
:owner (document handler)
|
||||
:name name
|
||||
:public-id public-id
|
||||
|
||||
@ -7,11 +7,24 @@
|
||||
;;;; Author: David Lichteblau <david@lichteblau.com>
|
||||
;;;; Author: knowledgeTools Int. GmbH
|
||||
|
||||
(defpackage :dom-impl
|
||||
#-cxml-system::utf8dom-file
|
||||
(defpackage :rune-dom
|
||||
(:use :cl :runes)
|
||||
(:export #:create-document))
|
||||
#+rune-is-character (:nicknames :cxml-dom)
|
||||
(:export #:implementation #:make-dom-builder #:create-document))
|
||||
|
||||
#+cxml-system::utf8dom-file
|
||||
(defpackage :utf8-dom
|
||||
(:use :cl :utf8-runes)
|
||||
(:nicknames :cxml-dom)
|
||||
(:export #:implementation #:make-dom-builder #:create-document))
|
||||
|
||||
#-cxml-system::utf8dom-file
|
||||
(in-package :rune-dom)
|
||||
|
||||
#+cxml-system::utf8dom-file
|
||||
(in-package :utf8-dom)
|
||||
|
||||
(in-package :dom-impl)
|
||||
|
||||
;; Classes
|
||||
|
||||
@ -107,7 +120,7 @@
|
||||
(system-id :initarg :system-id :reader dom:system-id)
|
||||
(entities :initarg :entities :reader dom:entities)
|
||||
(notations :initarg :notations :reader dom:notations)
|
||||
(internal-subset :accessor internal-subset)))
|
||||
(dom::%internal-subset :accessor dom::%internal-subset)))
|
||||
|
||||
(defclass notation (node)
|
||||
((name :initarg :name :reader dom:name)
|
||||
@ -144,9 +157,24 @@
|
||||
(etypecase x
|
||||
(null x)
|
||||
(rod x)
|
||||
#+cxml-system::utf8dom-file (runes::rod (cxml::rod-to-utf8-string x))
|
||||
(string (string-rod x))
|
||||
(vector x)))
|
||||
|
||||
#-cxml-system::utf8dom-file
|
||||
(defun real-rod (x)
|
||||
(%rod x))
|
||||
|
||||
#+cxml-system::utf8dom-file
|
||||
(defun real-rod (x)
|
||||
(etypecase x
|
||||
(null x)
|
||||
(runes::rod x)
|
||||
(string (cxml::utf8-string-to-rod x))))
|
||||
|
||||
(defun valid-name-p (x)
|
||||
(cxml::valid-name-p (real-rod x)))
|
||||
|
||||
(defun assert-writeable (node)
|
||||
(when (read-only-p node)
|
||||
(dom-error :NO_MODIFICATION_ALLOWED_ERR "~S is marked read-only." node)))
|
||||
@ -231,12 +259,12 @@
|
||||
(string-equal (rod-string version) "2.0"))))
|
||||
|
||||
(defun %create-document-type (name publicid systemid)
|
||||
(make-instance 'dom-impl::document-type
|
||||
(make-instance 'document-type
|
||||
:name name
|
||||
:notations (make-instance 'dom-impl::named-node-map
|
||||
:notations (make-instance 'named-node-map
|
||||
:element-type :notation
|
||||
:owner nil)
|
||||
:entities (make-instance 'dom-impl::named-node-map
|
||||
:entities (make-instance 'named-node-map
|
||||
:element-type :entity
|
||||
:owner nil)
|
||||
:public-id publicid
|
||||
@ -249,7 +277,7 @@
|
||||
|
||||
(defmethod dom:create-document
|
||||
((factory (eql 'implementation)) uri qname doctype)
|
||||
(let ((document (make-instance 'dom-impl::document)))
|
||||
(let ((document (make-instance 'document)))
|
||||
(setf (slot-value document 'owner) nil
|
||||
(slot-value document 'doc-type) doctype)
|
||||
(when doctype
|
||||
@ -258,9 +286,9 @@
|
||||
"doctype was created by a different dom implementation"))
|
||||
(when (dom:owner-document doctype)
|
||||
(dom-error :WRONG_DOCUMENT_ERR "doctype already in use"))
|
||||
(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))
|
||||
(setf (slot-value doctype 'owner) document
|
||||
(slot-value (dom:notations doctype) 'owner) document
|
||||
(slot-value (dom:entities doctype) 'owner) document))
|
||||
(when (or uri qname)
|
||||
(dom:append-child document (dom:create-element-ns document uri qname)))
|
||||
document))
|
||||
@ -278,7 +306,7 @@
|
||||
|
||||
(defmethod dom:create-element ((document document) tag-name)
|
||||
(setf tag-name (%rod tag-name))
|
||||
(unless (cxml::valid-name-p tag-name)
|
||||
(unless (valid-name-p tag-name)
|
||||
(dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string tag-name)))
|
||||
(let ((result (make-instance 'element
|
||||
:tag-name tag-name
|
||||
@ -295,14 +323,16 @@
|
||||
result))
|
||||
|
||||
(defun safe-split-qname (qname uri)
|
||||
(unless (cxml::valid-name-p qname)
|
||||
(unless (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::split-qname (real-rod qname))
|
||||
(cxml:well-formedness-violation (c)
|
||||
(dom-error :NAMESPACE_ERR "~A" c)))
|
||||
(setf local-name (%rod local-name))
|
||||
(when prefix
|
||||
(setf prefix (%rod prefix))
|
||||
(unless uri
|
||||
(dom-error :NAMESPACE_ERR "prefix specified but no namespace URI"))
|
||||
(when (and (rod= prefix #"xml")
|
||||
@ -356,7 +386,7 @@
|
||||
(defmethod dom:create-processing-instruction ((document document) target data)
|
||||
(setf target (%rod target))
|
||||
(setf data (%rod data))
|
||||
(unless (cxml::valid-name-p target)
|
||||
(unless (valid-name-p target)
|
||||
(dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string target)))
|
||||
(make-instance 'processing-instruction
|
||||
:owner document
|
||||
@ -365,7 +395,7 @@
|
||||
|
||||
(defmethod dom:create-attribute ((document document) name)
|
||||
(setf name (%rod name))
|
||||
(unless (cxml::valid-name-p name)
|
||||
(unless (valid-name-p name)
|
||||
(dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string name)))
|
||||
(make-instance 'attribute
|
||||
:name name
|
||||
@ -395,7 +425,7 @@
|
||||
|
||||
(defmethod dom:create-entity-reference ((document document) name)
|
||||
(setf name (%rod name))
|
||||
(unless (cxml::valid-name-p name)
|
||||
(unless (valid-name-p name)
|
||||
(dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string name)))
|
||||
(make-instance 'entity-reference
|
||||
:name name
|
||||
@ -445,12 +475,12 @@
|
||||
(dovector (c (dom:child-nodes n))
|
||||
(when (dom:element-p c)
|
||||
(let ((e (cxml::find-element
|
||||
(cxml::rod (dom:tag-name c))
|
||||
(real-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)))
|
||||
(let* ((name (%rod (cxml::attdef-name a)))
|
||||
(value (dom:get-attribute c name)))
|
||||
(when (and value (rod= value id))
|
||||
(return-from t c)))))))
|
||||
@ -603,19 +633,19 @@
|
||||
;; node-name
|
||||
|
||||
(defmethod dom:node-name ((self document))
|
||||
'#.(string-rod "#document"))
|
||||
#"#document")
|
||||
|
||||
(defmethod dom:node-name ((self document-fragment))
|
||||
'#.(string-rod "#document-fragment"))
|
||||
#"#document-fragment")
|
||||
|
||||
(defmethod dom:node-name ((self text))
|
||||
'#.(string-rod "#text"))
|
||||
#"#text")
|
||||
|
||||
(defmethod dom:node-name ((self cdata-section))
|
||||
'#.(string-rod "#cdata-section"))
|
||||
#"#cdata-section")
|
||||
|
||||
(defmethod dom:node-name ((self comment))
|
||||
'#.(string-rod "#comment"))
|
||||
#"#comment")
|
||||
|
||||
(defmethod dom:node-name ((self attribute))
|
||||
(dom:name self))
|
||||
@ -999,13 +1029,13 @@
|
||||
(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)
|
||||
@ -1048,9 +1078,9 @@
|
||||
(let* ((qname (dom:name old-attr))
|
||||
(dtd (dtd (slot-value element 'owner)))
|
||||
(e (when dtd (cxml::find-element
|
||||
(cxml::rod (dom:tag-name element))
|
||||
(real-rod (dom:tag-name element))
|
||||
dtd)))
|
||||
(a (when e (cxml::find-attribute e qname))))
|
||||
(a (when e (cxml::find-attribute e (real-rod qname)))))
|
||||
(when (and a (listp (cxml::attdef-default a)))
|
||||
(let ((new (add-default-attribute element a)))
|
||||
(setf (slot-value new 'namespace-uri) (dom:namespace-uri old-attr))
|
||||
@ -1060,7 +1090,7 @@
|
||||
(defun add-default-attributes (element)
|
||||
(let* ((dtd (dtd (slot-value element 'owner)))
|
||||
(e (when dtd (cxml::find-element
|
||||
(cxml::rod (dom:tag-name element))
|
||||
(real-rod (dom:tag-name element))
|
||||
dtd))))
|
||||
(when e
|
||||
(dolist (a (cxml::elmdef-attributes e))
|
||||
@ -1068,13 +1098,15 @@
|
||||
(listp (cxml::attdef-default a))
|
||||
(not (dom:get-attribute-node
|
||||
element
|
||||
(cxml::attdef-name a))))
|
||||
(%rod (cxml::attdef-name a)))))
|
||||
(let ((anode (add-default-attribute element a)))
|
||||
(multiple-value-bind (prefix local-name)
|
||||
(handler-case
|
||||
(cxml::split-qname (cxml::attdef-name a))
|
||||
(cxml:well-formedness-violation (c)
|
||||
(dom-error :NAMESPACE_ERR "~A" c)))
|
||||
(when prefix (setf prefix (%rod prefix)))
|
||||
(setf local-name (%rod local-name))
|
||||
;; das ist fuer importnode07.
|
||||
;; so richtig ueberzeugend finde ich das ja nicht.
|
||||
(setf (slot-value anode 'prefix) prefix)
|
||||
@ -1173,14 +1205,14 @@
|
||||
|
||||
(defmethod dom:internal-subset ((node document-type))
|
||||
;; FIXME: encoding ist falsch, anderen sink nehmen!
|
||||
(if (and (slot-boundp node 'internal-subset)
|
||||
(if (and (slot-boundp node 'dom::%internal-subset)
|
||||
;; die damen und herren von der test suite sind wohl der meinung,
|
||||
;; dass ein leeres internal subset nicht vorhanden ist und
|
||||
;; wir daher nil liefern sollen. bittesehr!
|
||||
(internal-subset node))
|
||||
(dom::%internal-subset node))
|
||||
(with-output-to-string (stream)
|
||||
(let ((sink (cxml:make-character-stream-sink stream)))
|
||||
(dolist (def (internal-subset node))
|
||||
(dolist (def (dom::%internal-subset node))
|
||||
(apply (car def) sink (cdr def)))))
|
||||
nil))
|
||||
|
||||
@ -1191,7 +1223,7 @@
|
||||
|
||||
(defmethod initialize-instance :after ((instance entity-reference) &key)
|
||||
(let* ((owner (dom:owner-document instance))
|
||||
(handler (dom:make-dom-builder))
|
||||
(handler (make-dom-builder))
|
||||
(resolver (slot-value owner 'entity-resolver)))
|
||||
(when resolver
|
||||
(setf (document handler) owner)
|
||||
@ -1380,10 +1412,10 @@
|
||||
|
||||
;;; Erweiterung
|
||||
|
||||
(defun dom-impl:create-document (&optional document-element)
|
||||
(defun create-document (&optional document-element)
|
||||
;; Um ein neues Dokumentenobject zu erzeugen, parsen wir einfach ein
|
||||
;; Dummydokument.
|
||||
(let* ((handler (dom:make-dom-builder))
|
||||
(let* ((handler (make-dom-builder))
|
||||
(cxml::*ctx* (cxml::make-context :handler handler))
|
||||
(result
|
||||
(progn
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
;;;; Author: David Lichteblau <david@lichteblau.com>
|
||||
;;;; Copyright (c) 2004 knowledgeTools Int. GmbH
|
||||
|
||||
(in-package :dom-impl)
|
||||
(in-package :cxml)
|
||||
|
||||
(defun dom:map-document
|
||||
(handler document
|
||||
@ -23,9 +23,9 @@
|
||||
(dom:system-id doctype))
|
||||
(ecase include-doctype
|
||||
(:full-internal-subset
|
||||
(when (slot-boundp doctype 'internal-subset)
|
||||
(when (slot-boundp doctype 'dom::%internal-subset)
|
||||
(sax:start-internal-subset handler)
|
||||
(dolist (def (internal-subset doctype))
|
||||
(dolist (def (dom::%internal-subset doctype))
|
||||
(apply (car def) handler (cdr def)))
|
||||
(sax:end-internal-subset handler)))
|
||||
(:canonical-notations
|
||||
|
||||
@ -8,10 +8,6 @@
|
||||
(defpackage :dom
|
||||
(:use)
|
||||
(:export
|
||||
|
||||
;; lisp-specific extensions
|
||||
#:make-dom-builder
|
||||
|
||||
;; DOM 2 functions
|
||||
#:owner-element
|
||||
#:import-node
|
||||
@ -100,26 +96,29 @@
|
||||
#:target
|
||||
#:code
|
||||
|
||||
;; protocol classes
|
||||
#:dom-implementation
|
||||
#:document-fragment
|
||||
#:document
|
||||
#:node
|
||||
#:node-list
|
||||
#:named-node-map
|
||||
#:character-data
|
||||
#:attr
|
||||
#:element
|
||||
#:text
|
||||
#:comment
|
||||
#:cdata-section
|
||||
#:document-type
|
||||
#:notation
|
||||
#:entity
|
||||
#:entity-reference
|
||||
#:processing-instruction
|
||||
;; not exported:
|
||||
;;; ;; protocol classes
|
||||
;;; #:dom-implementation
|
||||
;;; #:document-fragment
|
||||
;;; #:document
|
||||
;;; #:node
|
||||
;;; #:node-list
|
||||
;;; #:named-node-map
|
||||
;;; #:character-data
|
||||
;;; #:attr
|
||||
;;; #:element
|
||||
;;; #:text
|
||||
;;; #:comment
|
||||
;;; #:cdata-section
|
||||
;;; #:document-type
|
||||
;;; #:notation
|
||||
;;; #:entity
|
||||
;;; #:entity-reference
|
||||
;;; #:processing-instruction
|
||||
|
||||
;;
|
||||
#:items
|
||||
|
||||
;;
|
||||
#:node-p
|
||||
#:document-p
|
||||
|
||||
Reference in New Issue
Block a user