utf8-dom
This commit is contained in:
dlichteblau
28
cxml.asd
28
cxml.asd
@ -46,6 +46,7 @@
|
||||
#-rune-is-character "runes"
|
||||
#+rune-is-character "characters"
|
||||
:depends-on ("package" "definline"))
|
||||
#+rune-is-integer (:file "utf8" :depends-on ("package"))
|
||||
(:file "syntax" :depends-on ("package" "definline" runes))
|
||||
(:file "encodings" :depends-on ("package"))
|
||||
(:file "encodings-data" :depends-on ("package" "encodings"))
|
||||
@ -73,6 +74,25 @@
|
||||
(:file "sax-proxy" :depends-on ("xml-parse")))
|
||||
:depends-on (:cxml-runes :puri :trivial-gray-streams))
|
||||
|
||||
(defclass utf8dom-file (closure-source-file) ((of)))
|
||||
|
||||
(defmethod output-files ((operation compile-op) (c utf8dom-file))
|
||||
(let* ((normal (car (call-next-method)))
|
||||
(name (concatenate 'string (pathname-name normal) "-utf8"))
|
||||
(of (make-pathname :name name :defaults normal)))
|
||||
(setf (slot-value c 'of) of)
|
||||
(list of)))
|
||||
|
||||
(defmethod perform ((o load-op) (c utf8dom-file))
|
||||
(load (slot-value c 'of)))
|
||||
|
||||
(defvar *utf8-runes-readtable*)
|
||||
|
||||
(defmethod perform ((operation compile-op) (c utf8dom-file))
|
||||
(let ((*features* (cons 'utf8dom-file *features*))
|
||||
(*readtable* *utf8-runes-readtable*))
|
||||
(call-next-method)))
|
||||
|
||||
(asdf:defsystem :cxml-dom
|
||||
:default-component-class closure-source-file
|
||||
:pathname (merge-pathnames
|
||||
@ -80,8 +100,12 @@
|
||||
(make-pathname :name nil :type nil :defaults *load-truename*))
|
||||
:components
|
||||
((:file "package")
|
||||
(:file "dom-impl" :depends-on ("package"))
|
||||
(:file "dom-builder" :depends-on ("dom-impl"))
|
||||
(:file rune-impl :pathname "dom-impl" :depends-on ("package"))
|
||||
(:file rune-builder :pathname "dom-builder" :depends-on (rune-impl))
|
||||
#+rune-is-integer
|
||||
(utf8dom-file utf8-impl :pathname "dom-impl" :depends-on ("package"))
|
||||
#+rune-is-integer
|
||||
(utf8dom-file utf8-builder :pathname "dom-builder" :depends-on (utf8-impl))
|
||||
(:file "unparse" :depends-on ("package"))
|
||||
(:file "dom-sax" :depends-on ("package")))
|
||||
:depends-on (:cxml-xml))
|
||||
|
||||
@ -323,11 +323,10 @@
|
||||
builder, since DOM is specified to use UTF-16.
|
||||
</p>
|
||||
<p>
|
||||
<div class="def">Function CXML:MAKE-RECODER (chained-handler &optional recoder-fn)</div>
|
||||
<div class="def">Function CXML:MAKE-RECODER (chained-handler recoder-fn)</div>
|
||||
Return a SAX handler which passes all events on to
|
||||
<tt>chained-handler</tt> after converting all strings and rods
|
||||
using <tt>recoder-fn</tt>, a function of one argument which
|
||||
defaults to <tt>runes:rod-string</tt>.
|
||||
using <tt>recoder-fn</tt>, a function of one argument.
|
||||
</p>
|
||||
<p>
|
||||
<b>Example.</b> In a Lisp which ordinarily would use octet vector rods:
|
||||
@ -337,7 +336,7 @@
|
||||
<p>
|
||||
Use a SAX recoder to get strings instead::
|
||||
</p>
|
||||
<pre>CL-USER(17): (parse-string "<test/>" (cxml:make-recoder (cxml-xmls:make-xmls-builder)))
|
||||
<pre>CL-USER(17): (parse-string "<test/>" (cxml:make-recoder (cxml-xmls:make-xmls-builder) 'runes:rod-string))
|
||||
("test" NIL)</pre>
|
||||
|
||||
<a name="dtdcache"/>
|
||||
|
||||
@ -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
|
||||
|
||||
@ -61,6 +61,12 @@
|
||||
#:set-to-full-speed
|
||||
#:xstream-name))
|
||||
|
||||
(defpackage :utf8-runes
|
||||
(:use :cl)
|
||||
(:export *utf8-runes-readtable*
|
||||
#:rune #:rod #:simple-rod #:rod-string #:rod= #:make-rod
|
||||
#:string-rod))
|
||||
|
||||
(defpackage :runes-encoding
|
||||
(:use :cl :runes)
|
||||
(:export
|
||||
|
||||
44
runes/utf8.lisp
Normal file
44
runes/utf8.lisp
Normal file
@ -0,0 +1,44 @@
|
||||
;;; copyright (c) 2005 David Lichteblau <david@lichteblau.com>
|
||||
;;; License: Lisp-LGPL (See file COPYING for details).
|
||||
;;;
|
||||
;;; Rune emulation for the UTF-8-compatible DOM implementation.
|
||||
;;; Used only with 8 bit characters on non-unicode Lisps.
|
||||
|
||||
(in-package :utf8-runes)
|
||||
|
||||
(deftype rune () 'character)
|
||||
(deftype rod () '(vector rune))
|
||||
(deftype simple-rod () '(simple-array rune))
|
||||
|
||||
#+(or)
|
||||
(definline rune (rod index)
|
||||
(char rod index))
|
||||
|
||||
#+(or)
|
||||
(defun (setf rune) (newval rod index)
|
||||
(setf (char rod index) newval))
|
||||
|
||||
(defun rod= (r s)
|
||||
(string= r s))
|
||||
|
||||
(defun rod-string (rod &optional default)
|
||||
(declare (ignore default))
|
||||
rod)
|
||||
|
||||
(defun string-rod (string)
|
||||
string)
|
||||
|
||||
(defun make-rod (size)
|
||||
(make-string size :element-type 'rune))
|
||||
|
||||
(defun rune-reader (stream subchar arg)
|
||||
(runes::rune-char (runes::rune-reader stream subchar arg)))
|
||||
|
||||
(defun rod-reader (stream subchar arg)
|
||||
(runes::rod-string (runes::rod-reader stream subchar arg)))
|
||||
|
||||
(setf cxml-system::*utf8-runes-readtable*
|
||||
(let ((rt (copy-readtable)))
|
||||
(set-dispatch-macro-character #\# #\/ 'rune-reader rt)
|
||||
(set-dispatch-macro-character #\# #\" 'rod-reader rt)
|
||||
rt))
|
||||
@ -174,7 +174,7 @@
|
||||
|
||||
(defun read-members (&optional (directory *directory*))
|
||||
(let* ((pathname (merge-pathnames "build/dom2-interfaces.xml" directory))
|
||||
(builder (dom:make-dom-builder))
|
||||
(builder (rune-dom:make-dom-builder))
|
||||
(library (dom:document-element (cxml:parse-file pathname builder)))
|
||||
(methods '())
|
||||
(fields '()))
|
||||
@ -209,9 +209,9 @@
|
||||
(t (error "unknown condition: ~A" element))))
|
||||
|
||||
(defun equalsp (a b test)
|
||||
(when (typep a 'dom-impl::named-node-map)
|
||||
(when (dom:named-node-map-p a)
|
||||
(setf a (dom:items a)))
|
||||
(when (typep b 'dom-impl::named-node-map)
|
||||
(when (dom:named-node-map-p b)
|
||||
(setf b (dom:items b)))
|
||||
(if (and (typep a 'sequence) (typep b 'sequence))
|
||||
(null (set-exclusive-or (coerce a 'list) (coerce b 'list) :test test))
|
||||
@ -368,7 +368,7 @@
|
||||
|
||||
(defun translate-implementation (elt)
|
||||
(with-attributes (|var|) elt
|
||||
(maybe-setf (%intern |var|) `'dom-impl::implementation)))
|
||||
(maybe-setf (%intern |var|) `'rune-dom:implementation)))
|
||||
|
||||
(defun translate-length (load)
|
||||
;; XXX Soweit ich sehe unterscheiden die Tests nicht zwischen
|
||||
@ -406,7 +406,7 @@
|
||||
(if (nullify |obj|)
|
||||
(translate-member element)
|
||||
(maybe-setf (%intern |var|)
|
||||
`(dom:has-feature 'dom-impl::implementation
|
||||
`(dom:has-feature 'rune-dom:implementation
|
||||
,(parse-java-literal |feature|)
|
||||
,(parse-java-literal |version|))))))
|
||||
|
||||
@ -458,7 +458,7 @@
|
||||
(defun translate-assert-size (element)
|
||||
(with-attributes (|collection| |size|) element
|
||||
`(let ((collection ,(%intern |collection|)))
|
||||
(when (typep collection 'dom-impl::named-node-map)
|
||||
(when (dom:named-node-map-p collection)
|
||||
(setf collection (dom:items collection)))
|
||||
(assert (eql (length collection) ,(parse-java-literal |size|))))))
|
||||
|
||||
@ -493,9 +493,9 @@
|
||||
(return
|
||||
`(block assert-domexception
|
||||
(handler-bind
|
||||
((dom-impl::dom-exception
|
||||
((rune-dom::dom-exception
|
||||
(lambda (c)
|
||||
(when (eq (dom-impl::dom-exception-key c)
|
||||
(when (eq (rune-dom::dom-exception-key c)
|
||||
,(intern (tag-name c) :keyword))
|
||||
(return-from assert-domexception)))))
|
||||
,@(translate-body c)
|
||||
@ -506,7 +506,7 @@
|
||||
,@(map-child-elements
|
||||
'list
|
||||
(lambda (exception)
|
||||
`(when (eq (dom-impl::dom-exception-key c)
|
||||
`(when (eq (rune-dom::dom-exception-key c)
|
||||
,(intern (runes:rod-string (dom:get-attribute exception "code"))
|
||||
:keyword))
|
||||
,@(translate-body exception)
|
||||
@ -516,7 +516,7 @@
|
||||
(defun translate-try (element)
|
||||
`(block try
|
||||
(handler-bind
|
||||
((dom-impl::dom-exception
|
||||
((rune-dom::dom-exception
|
||||
,(translate-catch
|
||||
(do-child-elements (c element :name "catch") (return c))
|
||||
'(return-from try))))
|
||||
@ -556,7 +556,7 @@
|
||||
(defun translate-for-each (element)
|
||||
(with-attributes (|collection| |member|) element
|
||||
`(let ((collection ,(%intern |collection|)))
|
||||
(when (typep collection 'dom-impl::named-node-map)
|
||||
(when (dom:named-node-map-p collection)
|
||||
(setf collection (dom:items collection)))
|
||||
(map nil (lambda (,(%intern |member|)) ,@(translate-body element))
|
||||
collection))))
|
||||
@ -582,7 +582,7 @@
|
||||
(unless *fields*
|
||||
(multiple-value-setq (*methods* *fields*) (read-members)))
|
||||
(catch 'give-up
|
||||
(let* ((builder (dom:make-dom-builder))
|
||||
(let* ((builder (rune-dom:make-dom-builder))
|
||||
(cxml::*validate* nil) ;dom1.dtd is buggy
|
||||
(test (dom:document-element (cxml:parse-file pathname builder)))
|
||||
title
|
||||
@ -631,7 +631,7 @@
|
||||
(setf name (runes:rod-string name))
|
||||
(cxml:parse-file
|
||||
(make-pathname :name name :type "xml" :defaults *files-directory*)
|
||||
(dom:make-dom-builder)))
|
||||
(rune-dom:make-dom-builder)))
|
||||
|
||||
(defparameter *bad-tests*
|
||||
'("hc_elementnormalize2.xml"
|
||||
@ -654,7 +654,7 @@
|
||||
(nfailed 0))
|
||||
(flet ((parse (test-directory)
|
||||
(let* ((all-tests (merge-pathnames "alltests.xml" test-directory))
|
||||
(builder (dom:make-dom-builder))
|
||||
(builder (rune-dom:make-dom-builder))
|
||||
(suite (dom:document-element
|
||||
(cxml:parse-file all-tests builder)))
|
||||
(*files-directory*
|
||||
|
||||
@ -76,7 +76,7 @@
|
||||
|
||||
(defun run-all-tests (directory)
|
||||
(let* ((pathname (merge-pathnames "xmlconf.xml" directory))
|
||||
(builder (dom:make-dom-builder))
|
||||
(builder (rune-dom:make-dom-builder))
|
||||
(xmlconf (cxml:parse-file pathname builder))
|
||||
(ntried 0)
|
||||
(nfailed 0)
|
||||
@ -124,7 +124,7 @@
|
||||
(declare (ignore description))
|
||||
(let ((document (apply #'cxml:parse-file
|
||||
pathname
|
||||
(dom:make-dom-builder)
|
||||
(rune-dom:make-dom-builder)
|
||||
args)))
|
||||
(cond
|
||||
((null output)
|
||||
@ -161,7 +161,7 @@
|
||||
(handler-case
|
||||
(progn
|
||||
(format t " [validating:]")
|
||||
(cxml:parse-file pathname (dom:make-dom-builder) :validate t)
|
||||
(cxml:parse-file pathname (rune-dom:make-dom-builder) :validate t)
|
||||
(error "validity error not detected")
|
||||
nil)
|
||||
(cxml:validity-error ()
|
||||
@ -174,7 +174,7 @@
|
||||
(handler-case
|
||||
(progn
|
||||
(format t " [not validating:]")
|
||||
(cxml:parse-file pathname (dom:make-dom-builder) :validate nil)
|
||||
(cxml:parse-file pathname (rune-dom:make-dom-builder) :validate nil)
|
||||
(error "well-formedness violation not detected")
|
||||
nil)
|
||||
(cxml:well-formedness-violation ()
|
||||
@ -183,7 +183,7 @@
|
||||
(handler-case
|
||||
(progn
|
||||
(format t " [validating:]")
|
||||
(cxml:parse-file pathname (dom:make-dom-builder) :validate t)
|
||||
(cxml:parse-file pathname (rune-dom:make-dom-builder) :validate t)
|
||||
(error "well-formedness violation not detected")
|
||||
nil)
|
||||
(cxml:well-formedness-violation ()
|
||||
|
||||
@ -12,7 +12,7 @@
|
||||
((recoder :initarg :recoder :accessor recoder)
|
||||
(chained-handler :initarg :chained-handler :accessor chained-handler)))
|
||||
|
||||
(defun make-recoder (chained-handler &optional (recoder-fn #'rod-string))
|
||||
(defun make-recoder (chained-handler recoder-fn)
|
||||
(make-instance 'recoder
|
||||
:recoder recoder-fn
|
||||
:chained-handler chained-handler))
|
||||
|
||||
@ -639,6 +639,6 @@
|
||||
(let* ((bytes (map '(vector (unsigned-byte 8)) #'char-code str))
|
||||
(buffer (make-array (length bytes) :element-type '(unsigned-byte 16)))
|
||||
(n (decode-sequence :utf-8 bytes 0 (length bytes) buffer 0 0 nil))
|
||||
(result (make-array n :element-type 'rod)))
|
||||
(result (make-array n :element-type 'rune)))
|
||||
(map-into result #'code-rune buffer)
|
||||
result))
|
||||
|
||||
Reference in New Issue
Block a user