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@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@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@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