auto-install/dom.el

   1 ;;; dom.el --- DOM implementation
   2
   3 ;; Copyright (C) 2001  Alex Schroeder <alex@gnu.org>
   4
   5 ;; Author: Alex Schroeder <alex@gnu.org>
   6 ;;      Henrik.Motakef <elisp@henrik-motakef.de>
   7 ;; Maintainer: Henrik.Motakef <elisp@henrik-motakef.de>
   8 ;; Version: 1.0.1
   9 ;; Keywords: xml
  10 ;; URL: http://www.emacswiki.org/cgi-bin/wiki.pl?XmlParser
  11 ;; Version: $Id: dom.el,v 1.1 2002/08/14 20:22:21 henrik Exp henrik $
  12
  13 ;; This file is not part of GNU Emacs.
  14
  15 ;; This is free software; you can redistribute it and/or modify it under
  16 ;; the terms of the GNU General Public License as published by the Free
  17 ;; Software Foundation; either version 2, or (at your option) any later
  18 ;; version.
  19
  20 ;; This is distributed in the hope that it will be useful,
  21 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  22 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  23 ;; GNU General Public License for more details.
  24
  25 ;; You should have received a copy of the GNU General Public License
  26 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  27 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  28 ;; Boston, MA 02111-1307, USA.
  29
  30 ;;; Commentary:
  31
  32 ;; If you are working with XML documents, the parsed data structure
  33 ;; returned by the XML parser (xml.el) may be enough for you: Lists of
  34 ;; lists, symbols, strings, plus a number of accessor functions.
  35 ;;
  36 ;; If you want a more elaborate data structure to work with your XML
  37 ;; document, you can create a document object model (DOM) from the XML
  38 ;; data structure using dom.el.
  39 ;;
  40 ;; You can create a DOM from XML using `dom-make-document-from-xml'.
  41 ;; Note that `xml-parse-file' will return a list of top level elements
  42 ;; found in the file, so you must choose one element in that list.
  43 ;; Here's an example:
  44 ;;
  45 ;; (setq doc (dom-make-document-from-xml (car (xml-parse-file "sample.xml"))))
  46 ;;
  47 ;; Note that this DOM implementation uses the attributes and tag names
  48 ;; used by the XML parser.  If the XML parser uses symbols instead of
  49 ;; string (like xml.el does), then dom.el will also use symbols.  If the
  50 ;; XML parsers uses strings (like xml-parse.el does), then dom.el will
  51 ;; use strings.
  52 ;;
  53 ;; It should be trivial to write functions analogous to the
  54 ;; dom-*-from-xml functions in order to use an another XML parsers (from
  55 ;; psgml.el, for example).
  56
  57 ;;; On Interfaces and Classes
  58
  59 ;; The elisp DOM implementation uses the dom-node structure to store all
  60 ;; attributes.  The various interfaces consist of sets of functions to
  61 ;; manipulate these dom-nodes.  The functions of a certain interface
  62 ;; share the same prefix.
  63
  64 ;;; Test:
  65
  66 ;; The test code assumes a file named sample.xml with the following
  67 ;; content:
  68
  69 ;;   <book id="compiler">
  70 ;;     <bookinfo>
  71 ;;       <bookbiblio>
  72 ;;         <title>My own book!</title>
  73 ;;         <edition>First</edition>
  74 ;;         <authorgroup>
  75 ;;           <author>
  76 ;;             <firstname>John</firstname>
  77 ;;             <surname>Wiegley</surname>
  78 ;;           </author>
  79 ;;         </authorgroup>
  80 ;;       </bookbiblio>
  81 ;;     </bookinfo>
  82 ;;     <chapter>
  83 ;;       <title>A very small chapter</title>
  84 ;;       <para>Wonder where the content is...</para>
  85 ;;     </chapter>
  86 ;;   </book>
  87
  88 ;;; Code:
  89
  90 (require 'cl)
  91 (require 'xml)
  92
  93 ;;; Exception DOMException
  94
  95 ;; DOM operations only raise exceptions in "exceptional" circumstances,
  96 ;; i.e., when an operation is impossible to perform (either for logical
  97 ;; reasons, because data is lost, or because the implementation has
  98 ;; become unstable). In general, DOM methods return specific error
  99 ;; values in ordinary processing situations, such as out-of-bound errors
 100 ;; when using NodeList.
 101
 102 ;; Implementations should raise other exceptions under other
 103 ;; circumstances. For example, implementations should raise an
 104 ;; implementation-dependent exception if a null argument is passed.
 105
 106 ;; Some languages and object systems do not support the concept of
 107 ;; exceptions. For such systems, error conditions may be indicated using
 108 ;; native error reporting mechanisms. For some bindings, for example,
 109 ;; methods may return error codes similar to those listed in the
 110 ;; corresponding method descriptions.
 111
 112 (let ((errors
 113        ;; Note that the numeric code is not used at the moment.
 114        '((dom-hierarchy-request-err 3
 115           "Node doesn't belong here")
 116          (dom-wrong-document-err 4
 117           "Node is used in a different document than the one that created it")
 118          (dom-not-found-err 8
 119           "A reference to a node was made in a context where it does not exist"))))
 120   (dolist (err errors)
 121     (put (nth 0 err)
 122          'error-conditions
 123          (list 'error 'dom-exception (nth 0 err)))
 124     (put (nth 0 err)
 125          'error-message
 126          (nth 2 err))))
 127
 128 (defun dom-exception (exception &rest data)
 129   "Signal error EXCEPTION, possibly providing DATA.
 130 The error signaled has the condition 'dom-exception in addition
 131 to the catch-all 'error and EXCEPTION itself."
 132   ;; FIXME: Redefine this to do something else?
 133   (signal exception data))
 134
 135 ;;; Interface Document
 136
 137 ;; The Document interface represents the entire HTML or XML document.
 138 ;; Conceptually, it is the root of the document tree, and provides the
 139 ;; primary access to the document's data.
 140
 141 ;; Since elements, text nodes, comments, processing instructions, etc.
 142 ;; cannot exist outside the context of a Document, the Document interface
 143 ;; also contains the factory methods needed to create these objects. The
 144 ;; Node objects created have a ownerDocument attribute which associates
 145 ;; them with the Document within whose context they were created.
 146
 147 ;; createAttribute
 148
 149 ;; Creates an Attr of the given name. Note that the Attr instance can
 150 ;; then be set on an Element using the setAttributeNode method.
 151
 152 (defun dom-document-create-attribute (doc name)
 153   "Create an attribute of the given NAME.
 154 DOC is the owner-document."
 155   (when (stringp name)
 156     (setq name (intern name)))
 157   (make-dom-attr
 158    :name name
 159    :type dom-attribute-node
 160    :owner-document doc))
 161
 162 ;; createElement
 163
 164 ;; Creates an element of the type specified. Note that the instance
 165 ;; returned implements the Element interface, so attributes can be
 166 ;; specified directly on the returned object.
 167
 168 ;; FIXME: In addition, if there are known attributes with default
 169 ;; values, Attr nodes representing them are automatically created and
 170 ;; attached to the element.  (not implemented)
 171
 172 (defun dom-document-create-element (doc type)
 173   "Create an element of the given TYPE.
 174 TYPE will be interned, if it is a string.
 175 DOC is the owner-document."
 176   (when (stringp type)
 177     (setq type (intern type)))
 178   (make-dom-element
 179    :name type
 180    :type dom-element-node
 181    :owner-document doc))
 182
 183 ;; createTextNode
 184
 185 ;; Creates a Text node given the specified string.
 186
 187 (defun dom-document-create-text-node (doc data)
 188   "Create an element of the type specified by the tag NAME.
 189 DOC is the owner-document."
 190   (make-dom-text
 191    :name dom-text-node-name
 192    :value data
 193    :type dom-text-node
 194    :owner-document doc))
 195
 196 ;; getElementsByTagName
 197
 198 ;; Returns a NodeList of all the Elements with a given tag name in the
 199 ;; order in which they are encountered in a preorder traversal of the
 200 ;; Document tree.
 201
 202 (defun dom-document-get-elements-by-tag-name (doc tagname)
 203   "Return a list of all the elements with the given tagname.
 204 The elements are returned in the order in which they are encountered in
 205 a preorder traversal of the document tree.  The special value \"*\"
 206 matches all tags."
 207   (dom-element-get-elements-by-tag-name-1
 208    (dom-document-element doc)
 209    tagname))
 210
 211 ;;; Interface Node
 212
 213 ;; The Node interface is the primary datatype for the entire Document
 214 ;; Object Model. It represents a single node in the document tree. While
 215 ;; all objects implementing the Node interface expose methods for dealing
 216 ;; with children, not all objects implementing the Node interface may have
 217 ;; children. For example, Text nodes may not have children, and adding
 218 ;; children to such nodes results in a DOMException being raised.
 219
 220 ;; The attributes name, value and attributes are included as a mechanism
 221 ;; to get at node information without casting down to the specific
 222 ;; derived interface. In cases where there is no obvious mapping of
 223 ;; these attributes for a specific type (e.g., value for an Element or
 224 ;; attributes for a Comment), this returns null. Note that the
 225 ;; specialized interfaces may contain additional and more convenient
 226 ;; mechanisms to get and set the relevant information.
 227
 228 ;; FIXME: Use symbols instead of numbers?
 229 (defconst dom-element-node 1)
 230 (defconst dom-attribute-node 2)
 231 (defconst dom-text-node 3)
 232 ; (defconst dom-cdata-section-node 4)
 233 ; (defconst dom-entity-reference-node 5)
 234 ; (defconst dom-entity-node 6)
 235 ; (defconst dom-processing-instruction-node 7)
 236 ; (defconst dom-comment-node 8)
 237 (defconst dom-document-node 9)
 238 ; (defconst dom-document-type-node 10)
 239 ; (defconst dom-document-fragment-node 11)
 240 ; (defconst dom-notation-node 12)
 241
 242 ;; Default names used for Text and Document nodes.
 243
 244 (defconst dom-text-node-name '\#text)
 245 (defconst dom-document-node-name '\#document)
 246
 247 ;; readonly attribute DOMString        nodeName;
 248 ;;          attribute DOMString        nodeValue;
 249 ;; readonly attribute unsigned short   nodeType;
 250 ;; readonly attribute Node             parentNode;
 251 ;; readonly attribute NodeList         childNodes;
 252 ;; readonly attribute Node             firstChild;
 253 ;; readonly attribute Node             lastChild;
 254 ;; readonly attribute Node             previousSibling;
 255 ;; readonly attribute Node             nextSibling;
 256 ;; readonly attribute NamedNodeMap     attributes;
 257 ;; readonly attribute Document         ownerDocument;
 258
 259 (defstruct dom-node
 260   (name nil :read-only t)
 261   value
 262   (type nil :read-only t)
 263   parent-node
 264   child-nodes
 265   attributes
 266   owner-document)
 267
 268 (defstruct (dom-document (:include dom-node))
 269   element)
 270
 271 (defstruct (dom-element (:include dom-node)))
 272
 273 (defstruct (dom-attr (:include dom-node))
 274   owner-element
 275   specified)
 276
 277 (defstruct (dom-character-data (:include dom-node)))
 278
 279 (defstruct (dom-text (:include dom-character-data)))
 280
 281 ;; All functions defined for nodes are defined for documents and
 282 ;; elements as well.  Use `dom-node-defun' to define aliases.
 283
 284 (defun dom-node-defun (func)
 285   "Define aliases for symbol FUNC.
 286 FUNC must have the form dom-node-foo.  The aliases created will be named
 287 dom-document-foo, dom-element-foo, and dom-attr-foo."
 288   (if (and (fboundp func)
 289            (string-match "^dom-node-" (symbol-name func)))
 290       (let ((method (substring (symbol-name func) 9)))
 291         (mapc (lambda (prefix)
 292                 (defalias
 293                   (intern (concat prefix method)) func))
 294               '("dom-document-" "dom-element-" "dom-attr-")))
 295     (error "%S is not a dom function" func)))
 296
 297 ;; The followin functions implement the virtual attributes firstChild,
 298 ;; lastChild, previousSibling and nextSibling.
 299
 300 (defun dom-node-first-child (node)
 301   (car (dom-node-child-nodes node)))
 302 (dom-node-defun 'dom-node-first-child)
 303
 304 (defun dom-node-last-child (node)
 305   (car (last (dom-node-child-nodes node))))
 306 (dom-node-defun 'dom-node-last-child)
 307
 308 (defun dom-node-previous-sibling (node)
 309   (let ((parent (dom-node-parent-node node)))
 310     (when parent
 311       (let ((list (dom-node-child-nodes parent))
 312             prev
 313             done)
 314         (while (and (not done) list)
 315           (if (eq (car list) node)
 316               (setq done t)
 317             (setq prev (car list)
 318                   list (cdr list))))
 319         prev))))
 320 (dom-node-defun 'dom-node-previous-sibling)
 321
 322 (defun dom-node-next-sibling (node)
 323   (let ((parent (dom-node-parent-node node)))
 324     (when parent
 325       (nth 1 (memq node (dom-node-child-nodes parent))))))
 326 (dom-node-defun 'dom-node-next-sibling)
 327
 328 ;; appendChild
 329
 330 ;; Adds the node newChild to the end of the list of children of
 331 ;; this node. If the newChild is already in the tree, it is
 332 ;; first removed.
 333
 334 ;; FIXME: newChild of type Node: The node to add.  If it is a DocumentFragment
 335 ;; object, the entire contents of the document fragment are moved into
 336 ;; the child list of this node
 337
 338 (defun dom-node-append-child (node new-child)
 339   "Adds NEW-CHILD to the end of the list of children of NODE.
 340 If NEW-CHILD is already in the document tree, it is first removed.
 341 NEW-CHILD will be removed from anywhere in the document!
 342 Return the node added."
 343   (dom-node-test-new-child node new-child)
 344   (dom-node-unlink-child-from-parent new-child)
 345   ;; add new-child at the end of the list
 346   (let ((children (dom-node-child-nodes node)))
 347     (setf (dom-node-child-nodes node) (nconc children (list new-child))))
 348   (setf (dom-node-parent-node new-child) node)
 349   new-child)
 350 (dom-node-defun 'dom-node-append-child)
 351
 352 ;; cloneNode
 353
 354 ;; Returns a duplicate of this node, i.e., serves as a generic copy
 355 ;; constructor for nodes. The duplicate node has no parent; (parentNode
 356 ;; is null.).
 357
 358 ;; FIXME: Cloning an Element copies all attributes and their values,
 359 ;; including those generated by the XML processor to represent defaulted
 360 ;; attributes, but this method does not copy any text it contains unless
 361 ;; it is a deep clone, since the text is contained in a child Text
 362 ;; node. Cloning an Attribute directly, as opposed to be cloned as part
 363 ;; of an Element cloning operation, returns a specified attribute
 364 ;; (specified is true). Cloning any other type of node simply returns a
 365 ;; copy of this node.  (the attribute specified is not implemented)
 366
 367 ;; FIXME: Note that cloning an immutable subtree results in a mutable
 368 ;; copy, but the children of an EntityReference clone are readonly. In
 369 ;; addition, clones of unspecified Attr nodes are specified. And,
 370 ;; cloning Document, DocumentType, Entity, and Notation nodes is
 371 ;; implementation dependent.  (immutable subtrees not implemented)
 372
 373 ;; FIXME: The specification says nothing about nextSibling and
 374 ;; previousSibling.  We set these to nil as well, matching parentNode.
 375
 376 (defun dom-node-clone-node (node &optional deep)
 377   "Return a duplicate of NODE.
 378 The duplicate node has no parent.  Cloning will copy all attributes and
 379 their values, but this method does not copy any text it contains unless
 380 it is a DEEP clone, since the text is contained in a child text node.
 381
 382 When the optional argument DEEP is non-nil, this recursively clones the
 383 subtree under the specified node; if false, clone only the node itself
 384 \(and its attributes, if it has any)."
 385   ;; We don't want to call this recursively because of performance.
 386   (let* ((first-copy (copy-dom-node node))
 387          (copy first-copy)
 388          stack)
 389     ;; unlink neighbours of the first copy
 390     (setf (dom-node-parent-node first-copy) nil)
 391     (while copy
 392       ;; prevent sharing of text in text nodes
 393       (let ((value (dom-node-value copy)))
 394         (when (and value (sequencep value))
 395           (setf (dom-node-value copy) (copy-sequence value))))
 396       ;; copy attributes, and prevent sharing of text in attribute nodes
 397       (let ((attributes (mapcar 'copy-dom-node (dom-node-attributes copy))))
 398         (mapc (lambda (attr)
 399                 (let ((value (dom-node-value attr)))
 400                   (when (and value (sequencep value))
 401                     (setf (dom-node-value attr) (copy-sequence value)))))
 402               attributes)
 403         (setf (dom-node-attributes copy) attributes))
 404       (if (not deep)
 405           ;; if this is not a deep copy, we are done
 406           (setq copy nil)
 407         ;; first clone all children
 408         (let ((children (mapcar 'copy-dom-node (dom-node-child-nodes copy)))
 409               (parent copy))
 410           (when children
 411             ;; set the children info for the parent
 412             (setf (dom-node-child-nodes parent) children)
 413             ;; set parent for all children
 414             (mapc (lambda (child)
 415                     (setf (dom-node-parent-node child) parent))
 416                   children)))
 417         ;; move to the next copy, depth first, storing missed branches
 418         ;; on the stack -- note that "node" continues to refer to the
 419         ;; original node, it should not be used within the while copy
 420         ;; loop!
 421         (setq copy
 422               (cond ((dom-element-first-child copy)
 423                      (when (dom-element-next-sibling copy)
 424                        (push (dom-element-next-sibling copy) stack))
 425                      (dom-element-first-child copy))
 426                     ((dom-element-next-sibling copy))
 427                     (t (pop stack))))))
 428     first-copy))
 429 (dom-node-defun 'dom-node-clone-node)
 430
 431 ;; hasAttributes introduced in DOM Level 2
 432
 433 ;; Returns whether this node (if it is an element) has any
 434 ;; attributes.
 435
 436 (defun dom-node-has-attributes (node)
 437   "Return t when NODE has any attributes."
 438   (not (null (dom-node-attributes node))))
 439 (dom-node-defun 'dom-node-has-attributes)
 440
 441 ;; hasChildNodes
 442
 443 ;; Returns whether this node has any children.
 444
 445 (defun dom-node-has-child-nodes (node)
 446   "Return t when NODE has any child nodes."
 447   (not (null (dom-node-child-nodes node))))
 448 (dom-node-defun 'dom-node-has-child-nodes)
 449
 450 ;; insertBefore
 451
 452 ;; Inserts the node newChild before the existing child node refChild. If
 453 ;; refChild is null, insert newChild at the end of the list of children.
 454
 455 ;; FIXME: If newChild is a DocumentFragment object, all of its children
 456 ;; are inserted, in the same order, before refChild. If the newChild is
 457 ;; already in the tree, it is first removed.
 458
 459 (defun dom-node-insert-before (node new-child &optional ref-child)
 460   "Insert NEW-CHILD before NODE's existing child REF-CHILD.
 461 If optional argument REF-CHILD is nil or not given, insert NEW-CHILD at
 462 the end of the list of NODE's children.
 463 If NEW-CHILD is already in the document tree, it is first removed.
 464 NEW-CHILD will be removed from anywhere in the document!
 465 Return the node added."
 466   ;; without ref-child, append it at the end of the list
 467   (if (not ref-child)
 468       (dom-node-append-child node new-child)
 469     (dom-node-test-new-child node new-child)
 470     (dom-node-unlink-child-from-parent new-child)
 471     ;; find the correct position and insert new-child
 472     (let ((children (dom-node-child-nodes node))
 473           child-cell done)
 474       (while (and (not done) children)
 475         (if (eq ref-child (car children))
 476             (progn
 477               ;; if the first child is ref-child, set the list anew
 478               (if (not child-cell)
 479                   (setf (dom-node-child-nodes node)
 480                         (cons new-child children))
 481                 ;; else splice new-child into the list
 482                 (setcdr child-cell (cons new-child children)))
 483               (setq done t))
 484           ;; if we didn't find it, advance
 485           (setq child-cell children
 486                 children (cdr children))))
 487       (unless done
 488         (dom-exception 'dom-not-found-err)))
 489     new-child))
 490 (dom-node-defun 'dom-node-insert-before)
 491
 492 ;; removeChild
 493
 494 ;; Removes the child node indicated by oldChild from the list of
 495 ;; children, and returns it.
 496
 497 (defun dom-node-remove-child (node old-child)
 498   "Remove OLD-CHILD from the list of NODE's children and return it.
 499 This is very similar to `dom-node-unlink-child-from-parent' but it will
 500 raise an exception if OLD-CHILD is NODE's child."
 501   (let ((children (dom-node-child-nodes node)))
 502     (if (memq old-child children)
 503         (setf (dom-node-child-nodes node) (delq old-child children)
 504               (dom-node-parent-node old-child) nil)
 505       (dom-exception 'dom-not-found-err))
 506     old-child))
 507 (dom-node-defun 'dom-node-remove-child)
 508
 509 ;; replaceChild
 510
 511 ;; Replaces the child node oldChild with newChild in the list of
 512 ;; children, and returns the oldChild node.
 513
 514 ;; FIXME: If newChild is a DocumentFragment object, oldChild is replaced
 515 ;; by all of the DocumentFragment children, which are inserted in the
 516 ;; same order.
 517
 518 ;; If the newChild is already in the tree, it is first removed.
 519
 520 (defun dom-node-replace-child (node new-child old-child)
 521   "Replace OLD-CHILD with NEW-CHILD in the list NODE's children.
 522 Return OLD-CHILD."
 523   (dom-node-test-new-child node new-child)
 524   (dom-node-unlink-child-from-parent new-child)
 525   (let ((children (dom-node-child-nodes node)))
 526     (unless (memq old-child children)
 527       (dom-exception 'dom-not-found-err))
 528     (setf (dom-node-child-nodes node)
 529           (nsubstitute new-child old-child children)))
 530   ;; set parent of new-child and old-child
 531   (setf (dom-node-parent-node old-child) nil
 532         (dom-node-parent-node new-child) node))
 533 (dom-node-defun 'dom-node-replace-child)
 534
 535 ;; textContent of type DOMString, introduced in DOM Level 3
 536
 537 ;; This attribute returns the text content of this node and its
 538 ;; descendants.
 539
 540 ;;  FIXME: When set, any possible children this node may have are
 541 ;; removed and replaced by a single Text node containing the string this
 542 ;; attribute is set to.  (not implemented yet)
 543
 544 ;; On getting, no serialization is performed, the returned string does
 545 ;; not contain any markup. Similarly, on setting, no parsing is
 546 ;; performed either, the input string is taken as pure textual content.
 547
 548 (defun dom-node-text-content (node)
 549   "Return the text content of NODE and its children.
 550 If NODE is an attribute or a text node, its value is returned."
 551   (if (or (dom-attr-p node)
 552           (dom-text-p node))
 553       (dom-node-value node)
 554     (apply 'concat
 555            (mapcar 'dom-node-value
 556                    (dom-element-get-elements-by-tag-name
 557                     node dom-text-node-name)))))
 558 (dom-node-defun 'dom-node-text-content)
 559
 560 (defun dom-node-set-text-content (node data)
 561   "Set the text content of NODE, replacing all its children.
 562 If NODE is an attribute or a text node, its value is set."
 563   (if (or (dom-attr-p node)
 564           (dom-text-p node))
 565       (setf (dom-node-value node) data)
 566     (setf (dom-node-child-nodes node)
 567           (list (dom-document-create-text-node
 568                  (dom-node-owner-document node)
 569                  data)))))
 570 (dom-node-defun 'dom-node-set-text-content)
 571
 572 (defsetf dom-node-text-content dom-node-set-text-content)
 573
 574 ;;; Utility functions
 575
 576 ;; These utility functions are defined for nodes only.
 577
 578 (defun dom-node-ancestor-p (node ancestor)
 579   "Return t if ANCESTOR is an ancestor of NODE in the tree."
 580   (let ((parent (dom-node-parent-node node))
 581         result)
 582     (while (and (not result) parent)
 583       (setq result (eq parent ancestor)
 584             parent (dom-node-parent-node parent)))
 585     result))
 586
 587 (defun dom-node-valid-child (node child)
 588   "Return t if CHILD is a valid child for NODE.
 589 This depends on the node-type of NODE and CHILD."
 590   ;; FIXME: Add stuff as we go along.
 591   t)
 592
 593 (defun dom-node-test-new-child (node new-child)
 594   "Check wether NEW-CHILD is acceptable addition to NODE's children."
 595   (when (or (dom-node-ancestor-p node new-child)
 596             (eq new-child node)
 597             (not (dom-node-valid-child node new-child)))
 598     (dom-exception 'dom-hierarchy-request-err))
 599   (when (not (eq (dom-node-owner-document node)
 600                  (dom-node-owner-document new-child)))
 601     (dom-exception 'dom-wrong-document-err))
 602   new-child)
 603
 604 (defun dom-node-unlink-child-from-parent (node)
 605   "Unlink NODE from is previous location.
 606 This is very similar to `dom-node-remove-child' but it will check wether
 607 this node is the child of a particular other node."
 608   ;; remove node from it's old position
 609   (let ((parent (dom-node-parent-node node)))
 610     (when parent
 611       ;; remove from parent's child-nodes and set own parent to nil
 612       (setf (dom-node-child-nodes parent)
 613             (delq node (dom-node-child-nodes parent))
 614             (dom-node-parent-node node)
 615             nil)))
 616   node)
 617
 618 ;;; Interface NodeList
 619
 620 ;; The NodeList interface provides the abstraction of an ordered
 621 ;; collection of nodes, without defining or constraining how this
 622 ;; collection is implemented. NodeList objects in the DOM are live.
 623
 624 ;; The items in the NodeList are accessible via an integral index,
 625 ;; starting from 0.
 626
 627 ;; This provides alternate names for plain lisp list accessor functions.
 628
 629 (defalias 'dom-node-list-length 'length)
 630
 631 (defun dom-node-list-item (list index); for the sake of argument order
 632   "Return element at INDEX in LIST.
 633 Equivalent to (nth INDEX NODE)."
 634   (nth index list))
 635
 636 ;; Interface Attr
 637
 638 ;; The Attr interface represents an attribute in an Element object.
 639 ;; Typically the allowable values for the attribute are defined in a
 640 ;; document type definition.
 641
 642 ;; Attr objects inherit the Node interface, but since they are not
 643 ;; actually child nodes of the element they describe, the DOM does not
 644 ;; consider them part of the document tree. Thus, the Node attributes
 645 ;; parentNode, previousSibling, and nextSibling have a null value for Attr
 646 ;; objects. The DOM takes the view that attributes are properties of
 647 ;; elements rather than having a separate identity from the elements they
 648 ;; are associated with; this should make it more efficient to implement
 649 ;; such features as default attributes associated with all elements of a
 650 ;; given type. Furthermore, Attr nodes may not be immediate children of a
 651 ;; DocumentFragment. However, they can be associated with Element nodes
 652 ;; contained within a DocumentFragment. In short, users and implementors
 653 ;; of the DOM need to be aware that Attr nodes have some things in common
 654 ;; with other objects inheriting the Node interface, but they also are
 655 ;; quite distinct.
 656
 657 ;; The attribute's effective value is determined as follows: if this
 658 ;; attribute has been explicitly assigned any value, that value is the
 659 ;; attribute's effective value; otherwise, if there is a declaration for
 660 ;; this attribute, and that declaration includes a default value, then
 661 ;; that default value is the attribute's effective value; otherwise, the
 662 ;; attribute does not exist on this element in the structure model until
 663 ;; it has been explicitly added. Note that the nodeValue attribute on the
 664 ;; Attr instance can also be used to retrieve the string version of the
 665 ;; attribute's value(s).
 666
 667 ;; In XML, where the value of an attribute can contain entity references,
 668 ;; the child nodes of the Attr node may be either Text or EntityReference
 669 ;; nodes (when these are in use; see the description of EntityReference
 670 ;; for discussion). Because the DOM Core is not aware of attribute types,
 671 ;; it treats all attribute values as simple strings, even if the DTD or
 672 ;; schema declares them as having tokenized types.
 673
 674 ;; ownerElement of type Element, readonly, introduced in DOM Level 2
 675
 676 ;; The Element node this attribute is attached to or null if
 677 ;; this attribute is not in use.
 678
 679 ;; Interface Element
 680
 681 ;; The Element interface represents an element in an HTML or XML
 682 ;; document.  Elements may have attributes associated with them; since
 683 ;; the Element interface inherits from Node, the generic Node interface
 684 ;; attribute attributes may be used to retrieve the set of all
 685 ;; attributes for an element. There are methods on the Element interface
 686 ;; to retrieve either an Attr object by name or an attribute value by
 687 ;; name. In XML, where an attribute value may contain entity references,
 688 ;; an Attr object should be retrieved to examine the possibly fairly
 689 ;; complex sub-tree representing the attribute value. On the other hand,
 690 ;; in HTML, where all attributes have simple string values, methods to
 691 ;; directly access an attribute value can safely be used as a
 692 ;; convenience.
 693
 694 (defun dom-element-get-elements-by-tag-name-1 (element name)
 695   "Return a list of elements with tag NAME.
 696 The elements are ELEMENT, its siblings, and their descendants.
 697 This is used by `dom-element-get-elements-by-tag-name' and
 698 `dom-document-get-elements-by-tag-name'."
 699   ;; We don't want to call this recursively because of performance.
 700   (let (stack result)
 701     (while element
 702       (when (or (string= name "*")
 703                 (string= name (dom-node-name element)))
 704         (setq result (cons element result)))
 705       (setq element
 706             (cond ((dom-node-first-child element)
 707                    (when (dom-node-next-sibling element)
 708                      (push (dom-node-next-sibling element) stack))
 709                    (dom-node-first-child element))
 710                   ((dom-node-next-sibling element))
 711                   (t (pop stack)))))
 712     (nreverse result)))
 713
 714 (defun dom-element-get-elements-by-tag-name (element name)
 715   "Return a list of all descendant of ELEMENT with tag NAME.
 716 The elements are returned in the order in which they are encountered in
 717 a preorder traversal of this element tree."
 718   (dom-element-get-elements-by-tag-name-1
 719    (dom-element-first-child element)
 720    name))
 721
 722 ;; Interface Text
 723
 724 ;; The Text interface inherits from CharacterData and represents the
 725 ;; textual content (termed character data in XML) of an Element or Attr.
 726 ;; If there is no markup inside an element's content, the text is
 727 ;; contained in a single object implementing the Text interface that is
 728 ;; the only child of the element. If there is markup, it is parsed into
 729 ;; the information items (elements, comments, etc.) and Text nodes that
 730 ;; form the list of children of the element.
 731
 732 ;; When a document is first made available via the DOM, there is only one
 733 ;; Text node for each block of text. Users may create adjacent Text nodes
 734 ;; that represent the contents of a given element without any intervening
 735 ;; markup, but should be aware that there is no way to represent the
 736 ;; separations between these nodes in XML or HTML, so they will not (in
 737 ;; general) persist between DOM editing sessions. The normalize() method
 738 ;; on Node merges any such adjacent Text objects into a single node for
 739 ;; each block of text.
 740
 741 ;; Character data is represented as a plain string.
 742
 743
 744
 745 ;;; Converting XML to DOM
 746
 747 ;; Converting XML (hierarchy of nodes, simple lists, symbols and
 748 ;; strings) to DOM (hierarchy of dom-nodes, defstructs from CL)
 749
 750 (defun dom-make-attribute-from-xml (attribute element doc)
 751   "Make a DOM node of attributes based on ATTRIBUTE.
 752 Called from `dom-make-element-from-xml'.
 753 ELEMENT is the owner-element.
 754 DOC is the owner-document."
 755   (let* ((name (car attribute))
 756          (value (cdr attribute))
 757          (attr (dom-document-create-attribute doc name)))
 758     (setf (dom-attr-value attr) value
 759           (dom-attr-owner-element attr) element)
 760     attr))
 761
 762 (defun dom-add-children (parent children)
 763   "Add CHILDREN to PARENT.
 764 CHILDREN is a list of XML NODE elements.  Each must
 765 be converted to a dom-node first."
 766   (when children
 767     (setf (dom-node-child-nodes parent)
 768           (mapcar (lambda (child)
 769                     (dom-make-node-from-xml
 770                      child
 771                      (dom-node-owner-document parent)))
 772                   children))
 773     (mapc (lambda (child)
 774             (setf (dom-node-parent-node child)
 775                   parent))
 776           (dom-node-child-nodes parent))))
 777
 778 (defun dom-make-element-from-xml (node owner)
 779   "Make a DOM element based on NODE.
 780 Called from `dom-make-node-from-xml'.
 781 The atttributes are created by `dom-make-attribute-from-xml'.
 782 OWNER is stored as the owner-document."
 783   (let* ((children (xml-node-children node))
 784          (attributes (xml-node-attributes node))
 785          (type (xml-node-name node))
 786          (element (dom-document-create-element owner type)))
 787     (when attributes
 788       (setf (dom-node-attributes element)
 789             (mapcar (lambda (attribute)
 790                       (dom-make-attribute-from-xml attribute element owner))
 791                     attributes)))
 792     (when children
 793       (dom-add-children element children))
 794     element))
 795
 796 (defun dom-make-node-from-xml (node owner)
 797   "Make a DOM node based on NODE.
 798 If NODE is a list, the node is created by `dom-make-element-from-xml'.
 799 OWNER is stored as the owner-document."
 800   (cond ((stringp node)
 801          (dom-document-create-text-node owner node))
 802         ((listp node)
 803          (dom-make-element-from-xml node owner))
 804         (t
 805          (error "Illegal node: %S" node))))
 806
 807 (defun dom-make-document-from-xml (node)
 808   "Return a DOM document based on NODE.
 809 NODE is a node as returned by `xml-parse-file', either
 810 a string or a list.  The DOM nodes are created using
 811 `dom-make-node-from-xml'.
 812
 813 Note that `xml-parse-file' returns a list of elements.
 814 You can only pass one of these nodes as NODE."
 815   (let* ((doc (make-dom-document
 816                :name dom-document-node-name
 817                :type dom-document-node))
 818          (node (dom-make-node-from-xml node doc)))
 819     (setf (dom-document-owner-document doc) doc; required in dom-add-children
 820           (dom-document-element doc) node)
 821     doc))
 822
 823 ;;; Test stuff
 824
 825 (eval-when-compile
 826   (when (file-readable-p "sample.xml")
 827     (let ((data (car (xml-parse-file "sample.xml"))))
 828       ;; (setq data (car (xml-parse-file "sample.xml")))
 829       (assert (fboundp 'dom-node-name))
 830       (assert (fboundp 'dom-document-name))
 831       (assert (fboundp 'dom-element-name))
 832       (assert (fboundp 'dom-attr-name))
 833
 834       (let ((attr (dom-make-attribute-from-xml
 835                    (car (xml-node-attributes data)) 'none 'none)))
 836         (assert (string= "id" (dom-node-name attr)))
 837         (assert (string= "compiler" (dom-node-value attr)))
 838         (assert (eq dom-attribute-node (dom-node-type attr))))
 839
 840       (let ((element (dom-make-node-from-xml data 'no-owner)))
 841         (assert (string= "book" (dom-node-name element)))
 842         (assert (string= "id" (dom-node-name
 843                                (car (dom-node-attributes element)))))
 844         (assert (string= "compiler"
 845                          (dom-node-value
 846                           (car (dom-node-attributes element)))))
 847         (assert (string= "bookinfo"
 848                     (dom-node-name
 849                      (first (dom-node-child-nodes element)))))
 850         (assert (string= "chapter"
 851                          (dom-node-name
 852                           (second (dom-node-child-nodes element)))))
 853         (let ((title (first
 854                       (dom-node-child-nodes
 855                        (first
 856                         (dom-node-child-nodes
 857                          (first
 858                           (dom-node-child-nodes element))))))))
 859           (assert (eq 'title (dom-node-name title)))
 860           (assert (string= "My own book!"
 861                            (dom-node-value
 862                             (first (dom-node-child-nodes title)))))))
 863
 864       (let ((doc (dom-make-document-from-xml data)))
 865         (assert (eq dom-document-node-name (dom-document-name doc)))
 866         (assert (string= "book" (dom-node-name (dom-document-element doc))))
 867         (assert (eq (dom-node-parent-node
 868                      (first (dom-node-child-nodes (dom-document-element doc))))
 869                     (dom-document-element doc)))
 870         (assert (eq (first (dom-node-child-nodes (dom-document-element doc)))
 871                     (dom-node-first-child (dom-document-element doc))))
 872         (assert (eq (dom-node-next-sibling
 873                      (first (dom-node-child-nodes (dom-document-element doc))))
 874                     (second (dom-node-child-nodes (dom-document-element doc)))))
 875         (assert (eq doc
 876                     (dom-node-owner-document
 877                      (dom-node-first-child (dom-document-element doc)))))
 878         (assert (string= "chapter"
 879                          (dom-node-name
 880                           (dom-element-last-child
 881                            (dom-document-element doc)))))
 882         (assert (eq nil (dom-node-previous-sibling (dom-document-element doc)))))
 883
 884       (assert (eq 3 (dom-node-list-length '(1 2 3))))
 885
 886       (assert (eq 2 (dom-node-list-item '(1 2 3) 1)))
 887
 888       (let ((doc (dom-make-document-from-xml data)))
 889         (assert (equal (mapcar 'dom-node-name
 890                                (dom-document-get-elements-by-tag-name
 891                                 doc '*))
 892                        '(book bookinfo bookbiblio title \#text edition
 893                               \#text authorgroup author firstname \#text
 894                               surname \#text chapter title \#text para
 895                               \#text)))
 896         (assert (equal (mapcar 'dom-node-name
 897                                (dom-document-get-elements-by-tag-name
 898                                 doc 'title))
 899                        '(title title)))
 900         (assert (equal (mapcar 'dom-node-name
 901                                (dom-element-get-elements-by-tag-name
 902                                 (dom-document-element doc) 'title))
 903                        '(title title)))
 904         (assert (equal (mapcar (lambda (element)
 905                                  (dom-node-value
 906                                   (dom-element-first-child element)))
 907                                (dom-document-get-elements-by-tag-name
 908                                 doc 'title))
 909                        '("My own book!" "A very small chapter"))))
 910
 911       (let* ((doc (dom-make-document-from-xml data))
 912              (ancestor (dom-document-element doc))
 913              (child (car (dom-document-get-elements-by-tag-name doc 'title))))
 914         (assert (dom-node-ancestor-p child ancestor)))
 915
 916       (let* ((doc (dom-make-document-from-xml data))
 917              (book (dom-document-element doc))
 918              (old-chapter (dom-element-last-child book))
 919              (new-chapter (dom-document-create-element doc 'chapter)))
 920         (assert (string= (dom-node-name
 921                           (dom-element-append-child book new-chapter))
 922                          "chapter"))
 923         (assert (equal (mapcar 'dom-element-name
 924                                (dom-element-child-nodes book))
 925                        '(bookinfo chapter chapter)))
 926         (assert (eq (dom-element-last-child book) new-chapter))
 927         (assert (not (eq (dom-element-last-child book) old-chapter)))
 928         (assert (eq (dom-element-next-sibling old-chapter) new-chapter))
 929         (assert (eq (dom-element-previous-sibling new-chapter) old-chapter))
 930         (assert (eq (dom-element-parent-node new-chapter) book))
 931         (assert (dom-node-ancestor-p new-chapter book))
 932         (assert (not (eq t (condition-case var
 933                                (dom-element-append-child book new-chapter)
 934                              ('dom-hierarchy-request-err
 935                               t)))))
 936         (assert (eq t (condition-case var
 937                           (dom-element-append-child new-chapter book)
 938                         ('dom-hierarchy-request-err
 939                          t)))))
 940
 941       (let* ((doc (dom-make-document-from-xml data))
 942              (book (dom-document-element doc))
 943              (old-chapter (dom-element-last-child book))
 944              (new-chapter (dom-document-create-element doc 'chapter))
 945              (new-title (dom-document-create-element doc 'title))
 946              (text (dom-document-create-text-node doc "Test Chapter")))
 947         (assert (eq text (dom-element-append-child
 948                           (dom-element-append-child
 949                            (dom-element-append-child book new-chapter)
 950                            new-title)
 951                           text)))
 952         (assert (= 2 (length (dom-node-child-nodes old-chapter))))
 953         (assert (= 1 (length (dom-node-child-nodes new-chapter))))
 954         (assert (string= "title" (dom-node-name
 955                             (car (dom-node-child-nodes new-chapter)))))
 956         (assert (eq (car (dom-node-child-nodes new-chapter))
 957                     (dom-node-first-child new-chapter)))
 958         (assert (eq new-title
 959                     (dom-node-first-child new-chapter)))
 960         (assert (eq text
 961                     (dom-node-first-child new-title)))
 962         (assert (equal
 963                  (mapcar (lambda (node)
 964                            (dom-node-value
 965                             (dom-node-first-child node)))
 966                          (dom-document-get-elements-by-tag-name doc 'title))
 967                  '("My own book!" "A very small chapter" "Test Chapter"))))
 968
 969       (let* ((doc (dom-make-document-from-xml data))
 970              (book (dom-document-element doc))
 971              (copy (dom-node-clone-node book)))
 972         (assert (not (eq book copy)))
 973         (assert (eq (dom-node-child-nodes book)
 974                     (dom-node-child-nodes copy)))
 975         (assert (eq (car (dom-node-child-nodes book))
 976                     (car (dom-node-child-nodes copy))))
 977         (assert (eq (dom-node-first-child book)
 978                     (dom-node-first-child copy)))
 979         (assert (eq (dom-node-last-child book)
 980                     (dom-node-last-child copy)))
 981         (assert (not (eq (dom-node-attributes book)
 982                          (dom-node-attributes copy))))
 983         (assert (eq (dom-node-name (car (dom-node-attributes book)))
 984                     (dom-node-name (car (dom-node-attributes copy)))))
 985         (assert (not (eq (dom-node-value (car (dom-node-attributes book)))
 986                          (dom-node-value (car (dom-node-attributes copy))))))
 987         (assert (equal (dom-node-value (car (dom-node-attributes book)))
 988                        (dom-node-value (car (dom-node-attributes copy))))))
 989
 990       (let* ((doc (dom-make-document-from-xml data))
 991              (book (dom-document-element doc))
 992              (deepcopy (dom-node-clone-node book t)))
 993         (assert (not (eq book deepcopy)))
 994         (assert (equal (dom-node-attributes book)
 995                        (dom-node-attributes deepcopy)))
 996         (assert (not (eq (dom-node-attributes book)
 997                          (dom-node-attributes deepcopy))))
 998         (assert (equal
 999                  (mapcar 'dom-node-name
1000                          (dom-element-get-elements-by-tag-name book '*))
1001                  (mapcar 'dom-node-name
1002                          (dom-element-get-elements-by-tag-name deepcopy '*))))
1003         (assert (equal
1004                  (mapcar 'dom-node-value
1005                          (dom-element-get-elements-by-tag-name book '*))
1006                  (mapcar 'dom-node-value
1007                          (dom-element-get-elements-by-tag-name deepcopy '*))))
1008         (assert (not (eq (car (dom-element-get-elements-by-tag-name
1009                                book 'firstname))
1010                          (car (dom-element-get-elements-by-tag-name
1011                                deepcopy 'firstname)))))
1012         (assert (not (eq (dom-text-value
1013                           (third (dom-element-get-elements-by-tag-name
1014                                   book '\#text)))
1015                          (dom-text-value
1016                           (third (dom-element-get-elements-by-tag-name
1017                                   deepcopy '\#text))))))
1018         (assert (string= (dom-text-value
1019                           (third (dom-element-get-elements-by-tag-name
1020                                   book '\#text)))
1021                          (dom-text-value
1022                           (third (dom-element-get-elements-by-tag-name
1023                                   deepcopy '\#text)))))
1024         (assert (not (eq (dom-text-value
1025                           (third (dom-element-get-elements-by-tag-name
1026                                   book '\#text)))
1027                          (dom-text-value
1028                           (third (dom-element-get-elements-by-tag-name
1029                                   deepcopy '\#text)))))))
1030
1031       (let* ((doc (dom-make-document-from-xml data))
1032              (book (dom-document-element doc))
1033              (old-chapter (dom-element-last-child book))
1034              (new-chapter (dom-document-create-element doc 'chapter)))
1035         (assert (eq (dom-node-name (dom-element-insert-before book new-chapter))
1036                     'chapter))
1037         (assert (equal (mapcar 'dom-element-name
1038                                (dom-element-child-nodes book))
1039                        '(bookinfo chapter chapter)))
1040         (assert (eq new-chapter (dom-element-insert-before
1041                                  book new-chapter
1042                                  (dom-element-first-child book))))
1043         (assert (equal (mapcar 'dom-element-name
1044                                (dom-element-child-nodes book))
1045                        '(chapter bookinfo chapter)))
1046         (let ((new-bookinfo (dom-document-create-element doc 'bookinfo)))
1047            (dom-element-insert-before book new-bookinfo old-chapter))
1048         (assert (equal (mapcar 'dom-element-name
1049                                (dom-element-child-nodes book))
1050                        '(chapter bookinfo bookinfo chapter))))
1051
1052       ;; FIXME: some more tests for `dom-node-remove-child' and
1053       ;; `dom-node-replace-child' would be nice...  :)
1054       (let* ((doc (dom-make-document-from-xml data))
1055              (book (dom-document-element doc))
1056              (old-chapter (dom-element-last-child book))
1057              (new-chapter (dom-document-create-element doc 'chapter)))
1058         (dom-node-remove-child book old-chapter)
1059         (assert (equal (mapcar 'dom-node-name (dom-node-child-nodes book))
1060                        '(bookinfo)))
1061         (dom-node-replace-child book new-chapter
1062                                 (dom-node-first-child book))
1063         (assert (equal (mapcar 'dom-node-name (dom-node-child-nodes book))
1064                        '(chapter))))
1065
1066       (let* ((doc (make-dom-document))
1067              (par (dom-document-create-element doc 'p))
1068              (part1 (dom-document-create-text-node doc "This is "))
1069              (part2 (dom-document-create-element doc 'b))
1070              (part3 (dom-document-create-text-node doc ".")))
1071         (dom-element-append-child
1072          part2 (dom-document-create-text-node doc "bold"))
1073         (dom-element-append-child par part1)
1074         (dom-element-append-child par part2)
1075         (dom-element-append-child par part3)
1076         (setf (dom-document-owner-document doc) doc
1077               (dom-document-element doc) par)
1078         (assert (eq (dom-document-element doc) par))
1079         (assert (string= (dom-node-text-content par)
1080                          "This is bold."))
1081         (dom-node-set-text-content par "This is plain.")
1082         (assert (string= (dom-node-text-content par)
1083                          "This is plain."))
1084         (assert (equal (mapcar 'dom-node-name (dom-node-child-nodes par))
1085                        '(\#text)))
1086         (setf (dom-node-text-content par) "New text.")
1087         (assert (string= (dom-node-text-content par)
1088                          "New text."))
1089         (setf (dom-element-text-content par) "Different text.")
1090         (assert (string= (dom-element-text-content par)
1091                          "Different text."))
1092         (let ((at (dom-document-create-attribute doc 'foo)))
1093           (setf (dom-attr-value at) "domino"
1094                 (dom-element-attributes par) (list at))
1095           (assert (string= "domino"
1096                            (dom-node-value
1097                             (dom-node-list-item
1098                              (dom-element-attributes par)
1099                              0))))
1100           (assert (string= "domino"
1101                            (dom-node-text-content
1102                             (dom-node-list-item
1103                              (dom-element-attributes par)
1104                              0))))))
1105
1106       (let* ((doc (dom-make-document-from-xml data))
1107              (title (car (dom-document-get-elements-by-tag-name doc "title"))))
1108         (assert (equal (dom-element-text-content title)
1109                        "My own book!"))))))
1110
1111 (provide 'dom)
1112
1113 ;;; dom.el ends here.