;;;; dom-impl.lisp -- Implementation of DOM 1 Core
;;;;
;;;; This file is part of the CXML parser, released under Lisp-LGPL.
;;;; See file COPYING for details.
;;;;
;;;; Author: Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
;;;; Author: David Lichteblau <david@lichteblau.com>
;;;; Author: knowledgeTools Int. GmbH

(defpackage :dom-impl
  (:use :cl :runes)
  (:export #:create-document))

(in-package :dom-impl)

;; Classes

(define-condition dom-exception (error)
  ((key       :initarg :key       :reader dom-exception-key)
   (string    :initarg :string    :reader dom-exception-string)
   (arguments :initarg :arguments :reader dom-exception-arguments))
  (:report
   (lambda (c s)
     (format s "~A (~D):~%~?"
             (dom-exception-key c)
             (dom:code c)
             (dom-exception-string c)
             (dom-exception-arguments c)))))

(defclass node ()
  ((parent      :initarg :parent        :initform nil)
   (children    :initarg :children      :initform (make-node-list))
   (owner       :initarg :owner         :initform nil)
   (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)))

(defmethod (setf dom:prefix) (newval (node namespace-mixin))
  (assert-writeable node)
  (when newval
    (safe-split-qname (concatenate 'rod newval #":foo")
		      (dom:namespace-uri node)))
  (setf (slot-value node 'prefix) newval))

(defclass document (node)
  ((doc-type    :initarg :doc-type     :reader dom:doctype)
   (dtd         :initform nil          :reader dtd)
   (entity-resolver :initform nil)))

(defclass document-fragment (node)
  ())

(defclass character-data (node)
  ((value       :initarg :data          :reader dom:data)))

(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)
  (print-unreadable-object (object stream :type t :identity t)
    (format stream "~A=~S"
            (rod-string (dom:name object))
            (rod-string (dom:value object)))))

(defclass element (namespace-mixin node)
  ((tag-name    :initarg :tag-name      :reader dom:tag-name)
   (attributes  :initarg :attributes    :reader dom:attributes)))

(defmethod print-object ((object element) stream)
  (print-unreadable-object (object stream :type t :identity t)
    (princ (rod-string (dom:tag-name object)) stream)))

(defclass text (character-data)
  ())

(defclass comment (character-data)
  ())

(defclass cdata-section (text)
  ())

(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)
   (internal-subset                       :accessor internal-subset)))

(defclass notation (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)))

(defclass entity (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)
   (notation-name :initarg :notation-name :reader dom:notation-name)))

(defclass entity-reference (node) 
  ((name          :initarg :name          :reader dom:name)))

(defclass processing-instruction (node)
  ((target        :initarg :target        :reader dom:target)
   (data          :initarg :data          :reader dom:data)))

(defclass named-node-map ()
  ((items         :initarg :items         :reader dom:items
                  :initform nil)
   (owner         :initarg :owner         :reader dom:owner-document)
   (read-only-p   :initform nil           :reader read-only-p)
   (element-type  :initarg :element-type)))

(defclass attribute-node-map (named-node-map)
  ((element       :initarg :element)))


;;; Implementation

(defun %rod (x)
  (etypecase x
    (null x)
    (rod x)
    (string (string-rod x))
    (vector x)))

(defun assert-writeable (node)
  (when (read-only-p node)
    (dom-error :NO_MODIFICATION_ALLOWED_ERR "~S is marked read-only." node)))

(defun dom:map-node-list (fn nodelist)
  (dotimes (i (dom:length nodelist))
    (funcall fn (dom:item nodelist i))))

(defmacro dom:do-node-list ((var nodelist &optional resultform) &body body)
  `(block nil
     (dom:map-node-list (lambda (,var) ,@body) ,nodelist)
     ,resultform))

(defmacro dovector ((var vector &optional resultform) &body body)
  `(loop
       for ,var across ,vector do (progn ,@body)
       ,@(when resultform `(finally (return ,resultform)))))

(defun move (from to from-start to-start length)
  ;; like (setf (subseq to to-start (+ to-start length))
  ;;            (subseq from from-start (+ from-start length)))
  ;; but without creating the garbage.
  ;; Also, this is using AREF not ELT so that fill-pointers are ignored.
  (if (< to-start from-start)
      (loop
          repeat length
          for i from from-start
          for j from to-start
          do (setf (aref to j) (aref from i)))
      (loop
          repeat length
          for i downfrom (+ from-start length -1)
          for j downfrom (+ to-start length -1)
          do (setf (aref to j) (aref from i)))))

(defun adjust-vector-exponentially (vector new-dimension set-fill-pointer-p)
  (let ((d (array-dimension vector 0)))
    (when (< d new-dimension)
      (loop
	  do (setf d (* 2 d))
	  while (< d new-dimension))
      (adjust-array vector d))
    (when set-fill-pointer-p
      (setf (fill-pointer vector) new-dimension))))

(defun make-space (vector &optional (n 1))
  (adjust-vector-exponentially vector (+ (length vector) n) nil))

(defun extension (vector)
  (max (array-dimension vector 0) 1))

;; dom-exception

(defun dom-error (key fmt &rest args)
  (error 'dom-exception :key key :string fmt :arguments args))

(defmethod dom:code ((self dom-exception))
  (ecase (dom-exception-key self)
    (:INDEX_SIZE_ERR                    1)
    (:DOMSTRING_SIZE_ERR                2)
    (:HIERARCHY_REQUEST_ERR             3)
    (:WRONG_DOCUMENT_ERR                4)
    (:INVALID_CHARACTER_ERR             5)
    (:NO_DATA_ALLOWED_ERR               6)
    (:NO_MODIFICATION_ALLOWED_ERR       7)
    (:NOT_FOUND_ERR                     8)
    (:NOT_SUPPORTED_ERR                 9)
    (:INUSE_ATTRIBUTE_ERR               10)
    (:INVALID_STATE_ERR                 11)
    (:SYNTAX_ERR                        12)
    (:INVALID_MODIFICATION_ERR          13)
    (:NAMESPACE_ERR                     14)
    (:INVALID_ACCESS_ERR                15)))

;; 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"))))

(defun %create-document-type (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-type
    ((factory (eql 'implementation)) name publicid systemid)
  (safe-split-qname name #"")
  (%create-document-type name publicid 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)
    (when doctype
      (unless (typep doctype 'document-type)
	(dom-error :WRONG_DOCUMENT_ERR
		   "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))
    (when (or uri qname)
      (dom:append-child document (dom:create-element-ns document uri qname)))
    document))

;; document-fragment protocol
;; document protocol

(defmethod dom:implementation ((document document))
  'implementation)

(defmethod dom:document-element ((document document))
  (dovector (k (dom:child-nodes document))
    (cond ((typep k 'element)
           (return k)))))

(defmethod dom:create-element ((document document) tag-name)
  (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
                  :tag-name tag-name
		  :namespace-uri nil
		  :local-name nil
		  :prefix nil
                  :owner document)))
    (setf (slot-value result 'attributes)
          (make-instance 'attribute-node-map
            :element-type :attribute
            :owner document
            :element result))
    (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
      (unless uri
	(dom-error :NAMESPACE_ERR "prefix specified but no namespace URI"))
      (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))

(defmethod dom:create-text-node ((document document) data)
  (setf data (%rod data))
  (make-instance 'text
    :data data
    :owner document))

(defmethod dom:create-comment ((document document) data)
  (setf data (%rod data))
  (make-instance 'comment
    :data data
    :owner document))

(defmethod dom:create-cdata-section ((document document) data)
  (setf data (%rod data))
  (make-instance 'cdata-section
    :data data
    :owner document))

(defmethod dom:create-processing-instruction ((document document) target data)
  (setf target (%rod target))
  (setf data (%rod data))
  (unless (cxml::valid-name-p target)
    (dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string target)))
  (make-instance 'processing-instruction
    :owner document
    :target target
    :data data))

(defmethod dom:create-attribute ((document document) name)
  (setf name (%rod name))
  (unless (cxml::valid-name-p name)
    (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-element nil
    :owner document))

(defmethod dom:create-attribute-ns ((document document) uri qname)
  (setf uri (%rod uri))
  (setf qname (%rod qname))
  (when (and (rod= qname #"xmlns")
	     (not (rod= uri #"http://www.w3.org/2000/xmlns/")))
    (dom-error :NAMESPACE_ERR "invalid uri for qname `xmlns'"))
  (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-element nil
      :owner document)))

(defmethod dom:create-entity-reference ((document document) name)
  (setf name (%rod name))
  (unless (cxml::valid-name-p name)
    (dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string name)))
  (make-instance 'entity-reference
    :name name
    :owner document))

(defmethod get-elements-by-tag-name-internal (node tag-name)
  (setf tag-name (%rod tag-name))
  (let ((result (make-node-list))
	(wild-p (rod= tag-name #"*")))
    (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 #"*"))
	(wild-lname-p (rod= lname #"*")))
    (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))

(defmethod dom:child-nodes ((node node))
  (slot-value node 'children))

(defmethod dom:first-child ((node node))
  (dom:item (slot-value node 'children) 0))

(defmethod dom:last-child ((node node))
  (with-slots (children) node
    (if (plusp (length children))
        (elt children (1- (length children)))
        nil)))

(defmethod dom:previous-sibling ((node node))
  (with-slots (parent) node
    (when parent
      (with-slots (children) parent
        (let ((index (1- (position node children))))
          (if (eql index -1)
              nil
              (elt children index)))))))

(defmethod dom:next-sibling ((node node))
  (with-slots (parent) node
    (when parent
      (with-slots (children) parent
        (let ((index (1+ (position node children))))
          (if (eql index (length children))
              nil
              (elt children index)))))))

(defmethod dom:owner-document ((node node))
  (slot-value node 'owner))

(defun ensure-valid-insertion-request (node new-child)
  (assert-writeable node)
  (unless (can-adopt-p node new-child)
    (dom-error :HIERARCHY_REQUEST_ERR "~S cannot adopt ~S." node new-child))
  #+(or)                                ;XXX needs to be moved elsewhere
  (when (eq (dom:node-type node) :document)
    (let ((child-type (dom:node-type new-child)))
      (when (and (member child-type '(:element :document-type))
                 (find child-type (dom:child-nodes node) :key #'dom:node-type))
        (dom-error :HIERARCHY_REQUEST_ERR
                   "~S cannot adopt a second child of type ~S."
                   node child-type))))
  (unless (eq (if (eq (dom:node-type node) :document)
                  node
                  (dom:owner-document node))
              (dom:owner-document new-child))
    (dom-error :WRONG_DOCUMENT_ERR
               "~S cannot adopt ~S, since it was created by a different document."
               node new-child))
  (do ((n node (dom:parent-node n)))
      ((null n))
    (when (eq n new-child)
      (dom-error :HIERARCHY_REQUEST_ERR
                 "~S cannot adopt ~S, since that would create a cycle"
                 node new-child)))
  (unless (null (slot-value new-child 'parent))
    (dom:remove-child (slot-value new-child 'parent) new-child)))

(defmethod dom:insert-before ((node node) (new-child node) ref-child)
  (ensure-valid-insertion-request node new-child)
  (with-slots (children) node
    (if ref-child
        (let ((i (position ref-child children)))
          (unless i
            (dom-error :NOT_FOUND_ERR "~S is no child of ~S." ref-child node))
          (make-space children 1)
          (move children children i (1+ i) (- (length children) i))
          (incf (fill-pointer children))
          (setf (elt children i) new-child))
        (vector-push-extend new-child children (extension children)))
    (setf (slot-value new-child 'parent) node)
    new-child))

(defmethod dom:insert-before ((node node) (fragment document-fragment) ref-child)
  (dovector (child (dom:child-nodes fragment))
    (dom:insert-before node child ref-child))
  fragment)

(defmethod dom:replace-child ((node node) (new-child node) (old-child node))
  (ensure-valid-insertion-request node new-child)
  (with-slots (children) node
    (let ((i (position old-child children)))
      (unless i
        (dom-error :NOT_FOUND_ERR "~S is no child of ~S." old-child node))
      (setf (elt children i) new-child)) 
    (setf (slot-value new-child 'parent) node)
    (setf (slot-value old-child 'parent) nil)
    old-child))

(defmethod dom:replace-child
    ((node node) (new-child document-fragment) (old-child node))
  (dom:insert-before node new-child old-child)
  (dom:remove-child node old-child))

(defmethod dom:remove-child ((node node) (old-child node))
  (assert-writeable node)
  (with-slots (children) node
    (let ((i (position old-child children)))
      (unless i
        (dom-error :NOT_FOUND_ERR "~A not found in ~A" old-child node))
      (move children children (1+ i) i (- (length children) i 1))
      (decf (fill-pointer children)))
    (setf (slot-value old-child 'parent) nil)
    old-child))

(defmethod dom:append-child ((node node) (new-child node))
  (ensure-valid-insertion-request node new-child)
  (with-slots (children) node
    (vector-push-extend new-child children (extension children))
    (setf (slot-value new-child 'parent) node)
    new-child))

(defmethod dom:has-child-nodes ((node node))
  (plusp (length (slot-value node 'children))))

(defmethod dom:append-child ((node node) (new-child document-fragment))
  (assert-writeable node)
  (dovector (child (dom:child-nodes new-child))
    (dom:append-child node child))
  new-child)

;; was auf node noch implemetiert werden muss:
;; - node-type
;; - can-adopt-p
;; - ggf attributes 
;; - node-name
;; - node-value

;; node-name 

(defmethod dom:node-name ((self document))
  '#.(string-rod "#document"))

(defmethod dom:node-name ((self document-fragment))
  '#.(string-rod "#document-fragment"))

(defmethod dom:node-name ((self text))
  '#.(string-rod "#text"))

(defmethod dom:node-name ((self cdata-section))
  '#.(string-rod "#cdata-section"))

(defmethod dom:node-name ((self comment))
  '#.(string-rod "#comment"))

(defmethod dom:node-name ((self attribute))
  (dom:name self))

(defmethod dom:node-name ((self element))
  (dom:tag-name self))

(defmethod dom:node-name ((self document-type))
  (dom:name self))

(defmethod dom:node-name ((self notation))
  (dom:name self))

(defmethod dom:node-name ((self entity))
  (dom:name self))

(defmethod dom:node-name ((self entity-reference))
  (dom:name self))

(defmethod dom:node-name ((self processing-instruction))
  (dom:target self))

;; node-type

(defmethod dom:node-type ((self document)) :document)
(defmethod dom:node-type ((self document-fragment)) :document-fragment)
(defmethod dom:node-type ((self text)) :text)
(defmethod dom:node-type ((self comment)) :comment)
(defmethod dom:node-type ((self cdata-section)) :cdata-section)
(defmethod dom:node-type ((self attribute)) :attribute)
(defmethod dom:node-type ((self element)) :element)
(defmethod dom:node-type ((self document-type)) :document-type)
(defmethod dom:node-type ((self notation)) :notation)
(defmethod dom:node-type ((self entity)) :entity)
(defmethod dom:node-type ((self entity-reference)) :entity-reference)
(defmethod dom:node-type ((self processing-instruction)) :processing-instruction)

;; node-value

(defmethod dom:node-value ((self document)) nil)
(defmethod dom:node-value ((self document-fragment)) nil)
(defmethod dom:node-value ((self character-data)) (dom:data self))
(defmethod dom:node-value ((self attribute)) (dom:value self))
(defmethod dom:node-value ((self element)) nil)
(defmethod dom:node-value ((self document-type)) nil)
(defmethod dom:node-value ((self notation)) nil)
(defmethod dom:node-value ((self entity)) nil)
(defmethod dom:node-value ((self entity-reference)) nil)
(defmethod dom:node-value ((self processing-instruction)) (dom:data self))

;; (setf node-value), first the meaningful cases...

(defmethod (setf dom:node-value) (newval (self character-data))
  (assert-writeable self)
  (setf (dom:data self) newval))

(defmethod (setf dom:node-value) (newval (self attribute))
  (assert-writeable self)
  (setf (dom:value self) newval))

(defmethod (setf dom:node-value) (newval (self processing-instruction))
  (assert-writeable self)
  (setf (dom:data self) newval))

;; ... and (setf node-value), part II.  The DOM Level 1 spec fails to explain
;; this case, but it is covered by the (Level 1) test suite and clarified
;; in Level 2:
;;         nodeValue of type DOMString
;;                 The value of this node, depending on its type; see the
;;                 table above.  When it is defined to be null, setting
;;                 it has no effect.

(defmethod (setf dom:node-value) (newval (self element))
  (declare (ignore newval)))

(defmethod (setf dom:node-value) (newval (self entity-reference))
  (declare (ignore newval)))

(defmethod (setf dom:node-value) (newval (self entity))
  (declare (ignore newval)))

(defmethod (setf dom:node-value) (newval (self document))
  (declare (ignore newval)))

(defmethod (setf dom:node-value) (newval (self document-type))
  (declare (ignore newval)))

(defmethod (setf dom:node-value) (newval (self document-fragment))
  (declare (ignore newval)))

(defmethod (setf dom:node-value) (newval (self notation))
  (declare (ignore newval)))

;; attributes

;; (gibt es nur auf element)

(defmethod dom:attributes ((self node))
  nil)

;; dann fehlt noch can-adopt und attribute conventions fuer adoption

;;; NodeList

(defun make-node-list (&optional initial-contents)
  (make-array (length initial-contents)
              :adjustable t
              :fill-pointer (length initial-contents)
              :initial-contents initial-contents))

(defmethod dom:item ((self vector) index)
  (if (< index (length self))
      (elt self index)
      nil))

(defmethod dom:length ((self vector))
  (length self))

;;; NAMED-NODE-MAP

(defmethod dom:get-named-item ((self named-node-map) name)
  (setf name (%rod name))
  (with-slots (items) self
    (dolist (k items nil)
      (when (rod= name (dom:node-name k))
	(return k)))))

(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 (rod= uri (dom:namespace-uri k))
		 (rod= 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."
               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."
               map arg))
  (let ((old-map (slot-value arg 'map)))
    (when (and old-map (not (eq old-map map)))
      (dom-error :INUSE_ATTRIBUTE_ERR "Attribute node already mapped" arg)))
  (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)))
    (%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)
  (setf name (%rod name))
  (with-slots (items) self
    (dolist (k items (dom-error :NOT_FOUND_ERR "~A not found in ~A" name self))
      (cond ((rod= name (dom:node-name k))
             (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)))

(defmethod dom:item ((self named-node-map) index)
  (with-slots (items) self
    (do ((nthcdr items (cdr nthcdr))
         (i index (1- i)))
        ((zerop i) (car nthcdr)))))

;;; CHARACTER-DATA

(defmethod (setf dom:data) (newval (self character-data))
  (assert-writeable self)
  (setf newval (%rod newval))
  (setf (slot-value self 'value) newval))

(defmethod dom:length ((node character-data))
  (length (slot-value node 'value)))

(defmethod dom:substring-data ((node character-data) offset count)
  (with-slots (value) node
    (unless (<= 0 offset (length value))
      (dom-error :INDEX_SIZE_ERR "offset is invalid"))
    (let ((end (min (length value) (+ offset count))))
      (subseq value offset end))))

(defmethod dom:append-data ((node character-data) arg)
  (assert-writeable node)
  (setq arg (%rod arg))
  (with-slots (value) node
    (setf value (concatenate 'rod value arg)))
  (values))

(defmethod dom:delete-data ((node character-data) offset count)
  (assert-writeable node)
  (with-slots (value) node
    (unless (<= 0 offset (length value))
      (dom-error :INDEX_SIZE_ERR "offset is invalid"))
    (when (minusp count)
      (dom-error :INDEX_SIZE_ERR "count is negative"))
    (setf count (min count (- (length value) offset)))
    (let ((new (make-array (- (length value) count)
                           :element-type (array-element-type value))))
      (replace new value 
               :start1 0 :end1 offset
               :start2 0 :end2 offset)
      (replace new value 
               :start1 offset :end1 (length new)
               :start2 (+ offset count) :end2 (length value))
      (setf value new)))
  (values))

(defmethod dom:replace-data ((node character-data) offset count arg)
  ;; Although we could implement this by calling DELETE-DATA, then INSERT-DATA,
  ;; we implement this function directly to avoid creating temporary garbage.
  (assert-writeable node)
  (setf arg (%rod arg))
  (with-slots (value) node
    (unless (<= 0 offset (length value))
      (dom-error :INDEX_SIZE_ERR "offset is invalid"))
    (when (minusp count)
      (dom-error :INDEX_SIZE_ERR "count is negative"))
    (setf count (min count (- (length value) offset)))
    (if (= count (length arg))
        (replace value arg
                 :start1 offset :end1 (+ offset count)
                 :start2 0 :end2 count)
        (let ((new (make-array (+ (length value) (length arg) (- count))
                               :element-type (array-element-type value))))
          (replace new value :end1 offset)
          (replace new arg :start1 offset)
          (replace new value
                   :start1 (+ offset (length arg))
                   :start2 (+ offset count))
          (setf value new))))
  (values))

(defmethod dom:insert-data ((node character-data) offset arg)
  (assert-writeable node)
  (setf arg (%rod arg))
  (with-slots (value) node
    (unless (<= 0 offset (length value))
      (dom-error :INDEX_SIZE_ERR "offset is invalid"))
    (let ((new (make-array (+ (length value) (length arg))
                           :element-type (array-element-type value)))
          (arglen (length arg)))
      (replace new value :end1 offset)
      (replace new arg :start1 offset)
      (replace new value :start1 (+ offset arglen) :start2 offset)
      (setf value new)))
  (values))

;;; ATTR
;;;
;;; An attribute value can be read and set as a string using DOM:VALUE
;;; or frobbed by changing the attribute's children!
;;;
;;; We store the value in a TEXT node and read this node's DATA slot
;;; when asked for our VALUE -- until the user changes the child nodes,
;;; in which case we have to compute VALUE by traversing the children.

(defmethod dom:value ((node attribute))
  (with-slots (children) node
    (cond
      ((zerop (length children))
        #.(rod-string ""))
      ((and (eql (length children) 1)
            (eq (dom:node-type (elt children 0)) :text))
        ;; we have as single TEXT-NODE child, just return its DATA
        (dom:data (elt children 0)))
      (t
        ;; traverse children to compute value
        (attribute-to-string node)))))

(defmethod (setf dom:value) (new-value (node attribute))
  (assert-writeable node)
  (let ((rod (%rod new-value)))
    (with-slots (children owner) node
      ;; remove children, add new TEXT-NODE child
      ;; (alas, we must not reuse an old TEXT-NODE)
      (cxml::while (plusp (length children))
        (dom:remove-child node (dom:last-child node)))
      (dom:append-child node (dom:create-text-node owner rod))))
  new-value)

(defun attribute-to-string (attribute)
  (let ((stream (make-rod-stream)))
    (flet ((doit ()
             (dovector (child (dom:child-nodes attribute))
               (write-attribute-child child stream))))
      (doit)
      (initialize-rod-stream stream)
      (doit))
    (rod-stream-buf stream)))

(defmethod write-attribute-child ((node node) stream)
  (write-rod (dom:node-value node) stream))

(defmethod write-attribute-child ((node entity-reference) stream)
  (dovector (child (dom:child-nodes node))
    (write-attribute-child child stream)))

;;; ROD-STREAM als Ersatz fuer MAKE-STRING-OUTPUT-STREAM zu verwenden,
;;; nur dass der Buffer statische Groesse hat.  Solange er NIL ist,
;;; zaehlt der Stream nur die Runen.  Dann ruft man INITIALIZE-ROD-STREAM
;;; auf, um den Buffer zu erzeugen und die Position zurueckzusetzen, und
;;; schreibt alles abermals.  Dann ist der Buffer gefuellt.
(defstruct rod-stream
  (buf nil)
  (position 0))

(defun write-rod (rod rod-stream)
  (let ((buf (rod-stream-buf rod-stream)))
    (when buf
      (move rod buf 0 (rod-stream-position rod-stream) (length rod)))
    (incf (rod-stream-position rod-stream) (length rod)))
  rod)

(defun initialize-rod-stream (stream)
  (setf (rod-stream-buf stream) (make-rod (rod-stream-position stream)))
  (setf (rod-stream-position stream) 0)
  stream)

;;; 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))

(defmethod dom:set-attribute-node ((element element) (new-attr attribute))
  (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)
    (unless (find old-attr items)
      (dom-error :NOT_FOUND_ERR "Attribute not found."))
    (setf items (remove old-attr items))
    (maybe-add-default-attribute element (dom:name old-attr))
    old-attr))

;; eek, defaulting:

(defun maybe-add-default-attribute (element name)
  (let* ((dtd (dtd (slot-value element 'owner)))
         (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
		       (cxml::rod (dom:tag-name element))
		       dtd))))
    (when e
      (dolist (a (cxml::elmdef-attributes e))
        (when (and a (listp (cxml::attdef-default a)))
          (add-default-attribute element a))))))

(defun add-default-attribute (element adef)
  (let* ((value (second (cxml::attdef-default adef)))
         (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 'specified-p) nil)
    (setf (slot-value anode 'owner-element) element)
    (dom:append-child anode text)
    (push anode (slot-value (dom:attributes element) 'items))))

(defmethod dom:remove-named-item :after ((self attribute-node-map) name)
  (maybe-add-default-attribute (slot-value self 'element) name))

(defmethod dom:remove-named-item-ns
    ((self attribute-node-map) uri lname)
  (let ((k (call-next-method)))
    (maybe-add-default-attribute (slot-value self 'element) (dom:node-name k))
    k))

(defmethod dom:get-elements-by-tag-name ((element element) name)
  (assert-writeable element)
  (get-elements-by-tag-name-internal element name))

(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:set-named-item-ns :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))))
             (let ((children (dom:child-nodes n))
                   (i 0)
                   (previous nil))
               ;; careful here, we're modifying the array we are iterating over
               (cxml::while (< i (length children))
                 (let ((child (elt children i)))
                   (cond
                     ((not (eq (dom:node-type child) :text))
                       (setf previous nil)
                       (incf i))
                     ((and previous (eq (dom:node-type previous) :text))
                       (setf (slot-value previous 'value)
                             (concatenate 'rod
                               (dom:data previous)
                               (dom:data child)))
                       (dom:remove-child n child)
                       ;; not (incf i)
                       )
                     (t
                       (setf previous child)
                       (incf i)))))) 
             (map nil #'walk (dom:child-nodes n))))
    (walk node))
  (values))

;;; TEXT

(defmethod dom:split-text ((text text) offset)
  (assert-writeable text)
  (with-slots (owner parent value) text
    (unless (<= 0 offset (length value))
      (dom-error :INDEX_SIZE_ERR "offset is invalid"))
    (prog1
        (dom:insert-before parent
                           (dom:create-text-node owner (subseq value offset))
                           (dom:next-sibling text))
      (setf value (subseq value 0 offset)))))

;;; COMMENT -- nix
;;; CDATA-SECTION -- nix

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

;;; ENTITY-REFERENCE

(defmethod initialize-instance :after ((instance entity-reference) &key)
  (let* ((owner (dom:owner-document instance))
         (handler (dom:make-dom-builder))
         (resolver (slot-value owner 'entity-resolver)))
    (unless resolver
      (dom-error :NOT_SUPPORTED_ERR "No entity resolver registered."))
    (setf (document handler) owner)
    (push instance (element-stack handler))
    (funcall resolver (dom:name instance) handler))
  (labels ((walk (n)
             (setf (slot-value n 'read-only-p) t)
             (when (dom:element-p n)
	       (setf (slot-value (dom:attributes n) 'read-only-p) t)
               (map nil #'walk (dom:items (dom:attributes n))))
             (map nil #'walk (dom:child-nodes n))))
    (walk instance)))

;;; PROCESSING-INSTRUCTION

(defmethod (setf dom:data) (newval (self processing-instruction))
  (assert-writeable self)
  (setf newval (%rod newval))
  (setf (slot-value self 'data) newval))

;; das koennte man auch mit einer GF machen
(defun can-adopt-p (parent child)
  (member (dom:node-type child)
          (let ((default '(:element :processing-instruction :comment :text
                           :cdata-section :entity-reference)))
            (etypecase parent
              (document
                '(:element :processing-instruction :comment :document-type))
              (document-fragment default)
              (document-type nil)
              (entity-reference default)
              (element default)
              (attribute '(:text :entity-reference))
              (processing-instruction nil)
              (comment nil)
              (text nil)
              (cdata-section nil)
              (entity default)
              (notation nil)))))


;;; predicates

(defmethod dom:node-p ((object node)) t)
(defmethod dom:node-p ((object t)) nil)

(defmethod dom:document-p ((object document)) t)
(defmethod dom:document-p ((object t)) nil)

(defmethod dom:document-fragment-p ((object document-fragment)) t)
(defmethod dom:document-fragment-p ((object t)) nil)

(defmethod dom:character-data-p ((object character-data)) t)
(defmethod dom:character-data-p ((object t)) nil)

(defmethod dom:attribute-p ((object attribute)) t)
(defmethod dom:attribute-p ((object t)) nil)

(defmethod dom:element-p ((object element)) t)
(defmethod dom:element-p ((object t)) nil)

(defmethod dom:text-node-p ((object text)) t)
(defmethod dom:text-node-p ((object t)) nil)

(defmethod dom:comment-p ((object comment)) t)
(defmethod dom:comment-p ((object t)) nil)

(defmethod dom:cdata-section-p ((object cdata-section)) t)
(defmethod dom:cdata-section-p ((object t)) nil)

(defmethod dom:document-type-p ((object document-type)) t)
(defmethod dom:document-type-p ((object t)) nil)

(defmethod dom:notation-p ((object notation)) t)
(defmethod dom:notation-p ((object t)) nil)

(defmethod dom:entity-p ((object entity)) t)
(defmethod dom:entity-p ((object t)) nil)

(defmethod dom:entity-reference-p ((object entity-reference)) t)
(defmethod dom:entity-reference-p ((object t)) nil)

(defmethod dom:processing-instruction-p ((object processing-instruction)) t)
(defmethod dom:processing-instruction-p ((object t)) nil)

(defmethod dom:named-node-map-p ((object named-node-map)) t)
(defmethod dom:named-node-map-p ((object t)) nil)


;;; IMPORT-NODE

(defvar *clone-not-import* nil)         ;not beautiful, I know.  See below.

(defmethod import-node-internal (class document node deep &rest initargs)
  (let ((result (apply #'make-instance class :owner document initargs)))
    (when deep
      (dovector (child (dom:child-nodes node))
        (dom:append-child result (dom:import-node document child t))))
    result))

(defmethod dom:import-node ((document document) (node t) deep)
  (declare (ignore deep))
  (dom-error :NOT_SUPPORTED_ERR "not implemented"))

(defmethod dom:import-node ((document document) (node attribute) deep)
  (declare (ignore deep))
  (import-node-internal 'attribute
			document node
			t
			:name (dom:name node)
			:namespace-uri (dom:namespace-uri node)
			:local-name (dom:local-name node)
			:prefix (dom:prefix node)
			:owner-element nil))

(defmethod dom:import-node ((document document) (node document-fragment) deep)
  (import-node-internal 'document-fragment document node deep))

(defmethod dom:import-node ((document document) (node element) deep)
  (let* ((attributes (make-instance 'attribute-node-map
                       :element-type :attribute
                       :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)))
      (when (or (dom:specified attribute) *clone-not-import*)
        (dom:set-attribute result (dom:name attribute) (dom:value attribute))))
    result))

(defmethod dom:import-node ((document document) (node entity) deep)
  (import-node-internal 'entity document node deep
                        :public-id (dom:public-id node)
                        :system-id (dom:system-id node)
                        :notation-name (dom:notation-name node)))

(defmethod dom:import-node ((document document) (node entity-reference) deep)
  (declare (ignore deep))
  #+(or)
  (import-node-internal 'entity-reference document node nil
                        :name (dom:name node))
  ;; XXX If the document being imported into provides a definition for
  ;; this entity name, its value is assigned.
  (dom-error :NOT_SUPPORTED_ERR "not implemented"))

(defmethod dom:import-node ((document document) (node notation) deep)
  (import-node-internal 'notation document node deep
                        :name (dom:name node)
                        :public-id (dom:public-id node)
                        :system-id (dom:system-id node)))

(defmethod dom:import-node
    ((document document) (node processing-instruction) deep)
  (import-node-internal 'processing-instruction document node deep
                        :target (dom:target node)
                        :data (dom:data node)))

;; TEXT_NODE, CDATA_SECTION_NODE, COMMENT_NODE
(defmethod dom:import-node
    ((document document) (node character-data) deep)
  (import-node-internal (class-of node) document node deep
                        :data (copy-seq (dom:data node))))

;;; CLONE-NODE
;;;
;;; As far as I can tell, cloneNode is the same as importNode, except
;;; for one difference involving element attributes: importNode imports
;;; only specified attributes, cloneNode copies even default values.
;;;
;;; Since I don't want to reimplement all of importNode here, we run
;;; importNode with a special flag...

(defmethod dom:clone-node ((node node) deep)
  (let ((*clone-not-import* t))
    (dom:import-node (dom:owner-document node) node deep)))


;;; Erweiterung

(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))
         (cxml::*ctx* (cxml::make-context :handler handler))
         (result
          (progn
            (sax:start-document handler)
            (sax:end-document handler))))
    (when document-element
      (dom:append-child result (dom:import-node result document-element t)))
    result))