Update of /project/cxml/cvsroot/cxml/dom
In directory common-lisp.net:/tmp/cvs-serv11709/dom
Modified Files:
dom-builder.lisp dom-impl.lisp dom-sax.lisp package.lisp
Log Message:
utf8-dom
Date: Tue Dec 27 01:21:31 2005
Author: dlichteblau
Index: cxml/dom/dom-builder.lisp
diff -u cxml/dom/dom-builder.lisp:1.8 cxml/dom/dom-builder.lisp:1.9
--- cxml/dom/dom-builder.lisp:1.8 Sun Dec 11 19:36:14 2005
+++ cxml/dom/dom-builder.lisp Tue Dec 27 01:21:31 2005
@@ -8,14 +8,19 @@
;;;; Author: David Lichteblau <david(a)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
Index: cxml/dom/dom-impl.lisp
diff -u cxml/dom/dom-impl.lisp:1.32 cxml/dom/dom-impl.lisp:1.33
--- cxml/dom/dom-impl.lisp:1.32 Mon Dec 12 00:56:48 2005
+++ cxml/dom/dom-impl.lisp Tue Dec 27 01:21:31 2005
@@ -7,11 +7,24 @@
;;;; Author: David Lichteblau <david(a)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
Index: cxml/dom/dom-sax.lisp
diff -u cxml/dom/dom-sax.lisp:1.3 cxml/dom/dom-sax.lisp:1.4
--- cxml/dom/dom-sax.lisp:1.3 Sun Dec 4 19:43:56 2005
+++ cxml/dom/dom-sax.lisp Tue Dec 27 01:21:31 2005
@@ -6,7 +6,7 @@
;;;; Author: David Lichteblau <david(a)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
Index: cxml/dom/package.lisp
diff -u cxml/dom/package.lisp:1.3 cxml/dom/package.lisp:1.4
--- cxml/dom/package.lisp:1.3 Sun Dec 4 19:43:56 2005
+++ cxml/dom/package.lisp Tue Dec 27 01:21:31 2005
@@ -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
