--- /dev/null
+;;; dom.el --- DOM implementation
+
+;; Copyright (C) 2001 Alex Schroeder <alex@gnu.org>
+
+;; Author: Alex Schroeder <alex@gnu.org>
+;; Henrik.Motakef <elisp@henrik-motakef.de>
+;; Maintainer: Henrik.Motakef <elisp@henrik-motakef.de>
+;; Version: 1.0.1
+;; Keywords: xml
+;; URL: http://www.emacswiki.org/cgi-bin/wiki.pl?XmlParser
+;; Version: $Id: dom.el,v 1.1 2002/08/14 20:22:21 henrik Exp henrik $
+
+;; This file is not part of GNU Emacs.
+
+;; This is free software; you can redistribute it and/or modify it under
+;; the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2, or (at your option) any later
+;; version.
+
+;; This is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; If you are working with XML documents, the parsed data structure
+;; returned by the XML parser (xml.el) may be enough for you: Lists of
+;; lists, symbols, strings, plus a number of accessor functions.
+;;
+;; If you want a more elaborate data structure to work with your XML
+;; document, you can create a document object model (DOM) from the XML
+;; data structure using dom.el.
+;;
+;; You can create a DOM from XML using `dom-make-document-from-xml'.
+;; Note that `xml-parse-file' will return a list of top level elements
+;; found in the file, so you must choose one element in that list.
+;; Here's an example:
+;;
+;; (setq doc (dom-make-document-from-xml (car (xml-parse-file "sample.xml"))))
+;;
+;; Note that this DOM implementation uses the attributes and tag names
+;; used by the XML parser. If the XML parser uses symbols instead of
+;; string (like xml.el does), then dom.el will also use symbols. If the
+;; XML parsers uses strings (like xml-parse.el does), then dom.el will
+;; use strings.
+;;
+;; It should be trivial to write functions analogous to the
+;; dom-*-from-xml functions in order to use an another XML parsers (from
+;; psgml.el, for example).
+
+;;; On Interfaces and Classes
+
+;; The elisp DOM implementation uses the dom-node structure to store all
+;; attributes. The various interfaces consist of sets of functions to
+;; manipulate these dom-nodes. The functions of a certain interface
+;; share the same prefix.
+
+;;; Test:
+
+;; The test code assumes a file named sample.xml with the following
+;; content:
+
+;; <book id="compiler">
+;; <bookinfo>
+;; <bookbiblio>
+;; <title>My own book!</title>
+;; <edition>First</edition>
+;; <authorgroup>
+;; <author>
+;; <firstname>John</firstname>
+;; <surname>Wiegley</surname>
+;; </author>
+;; </authorgroup>
+;; </bookbiblio>
+;; </bookinfo>
+;; <chapter>
+;; <title>A very small chapter</title>
+;; <para>Wonder where the content is...</para>
+;; </chapter>
+;; </book>
+
+;;; Code:
+
+(require 'cl)
+(require 'xml)
+
+;;; Exception DOMException
+
+;; DOM operations only raise exceptions in "exceptional" circumstances,
+;; i.e., when an operation is impossible to perform (either for logical
+;; reasons, because data is lost, or because the implementation has
+;; become unstable). In general, DOM methods return specific error
+;; values in ordinary processing situations, such as out-of-bound errors
+;; when using NodeList.
+
+;; Implementations should raise other exceptions under other
+;; circumstances. For example, implementations should raise an
+;; implementation-dependent exception if a null argument is passed.
+
+;; Some languages and object systems do not support the concept of
+;; exceptions. For such systems, error conditions may be indicated using
+;; native error reporting mechanisms. For some bindings, for example,
+;; methods may return error codes similar to those listed in the
+;; corresponding method descriptions.
+
+(let ((errors
+ ;; Note that the numeric code is not used at the moment.
+ '((dom-hierarchy-request-err 3
+ "Node doesn't belong here")
+ (dom-wrong-document-err 4
+ "Node is used in a different document than the one that created it")
+ (dom-not-found-err 8
+ "A reference to a node was made in a context where it does not exist"))))
+ (dolist (err errors)
+ (put (nth 0 err)
+ 'error-conditions
+ (list 'error 'dom-exception (nth 0 err)))
+ (put (nth 0 err)
+ 'error-message
+ (nth 2 err))))
+
+(defun dom-exception (exception &rest data)
+ "Signal error EXCEPTION, possibly providing DATA.
+The error signaled has the condition 'dom-exception in addition
+to the catch-all 'error and EXCEPTION itself."
+ ;; FIXME: Redefine this to do something else?
+ (signal exception data))
+
+;;; Interface Document
+
+;; The Document interface represents the entire HTML or XML document.
+;; Conceptually, it is the root of the document tree, and provides the
+;; primary access to the document's data.
+
+;; Since elements, text nodes, comments, processing instructions, etc.
+;; cannot exist outside the context of a Document, the Document interface
+;; also contains the factory methods needed to create these objects. The
+;; Node objects created have a ownerDocument attribute which associates
+;; them with the Document within whose context they were created.
+
+;; createAttribute
+
+;; Creates an Attr of the given name. Note that the Attr instance can
+;; then be set on an Element using the setAttributeNode method.
+
+(defun dom-document-create-attribute (doc name)
+ "Create an attribute of the given NAME.
+DOC is the owner-document."
+ (when (stringp name)
+ (setq name (intern name)))
+ (make-dom-attr
+ :name name
+ :type dom-attribute-node
+ :owner-document doc))
+
+;; createElement
+
+;; Creates an element of the type specified. Note that the instance
+;; returned implements the Element interface, so attributes can be
+;; specified directly on the returned object.
+
+;; FIXME: In addition, if there are known attributes with default
+;; values, Attr nodes representing them are automatically created and
+;; attached to the element. (not implemented)
+
+(defun dom-document-create-element (doc type)
+ "Create an element of the given TYPE.
+TYPE will be interned, if it is a string.
+DOC is the owner-document."
+ (when (stringp type)
+ (setq type (intern type)))
+ (make-dom-element
+ :name type
+ :type dom-element-node
+ :owner-document doc))
+
+;; createTextNode
+
+;; Creates a Text node given the specified string.
+
+(defun dom-document-create-text-node (doc data)
+ "Create an element of the type specified by the tag NAME.
+DOC is the owner-document."
+ (make-dom-text
+ :name dom-text-node-name
+ :value data
+ :type dom-text-node
+ :owner-document doc))
+
+;; getElementsByTagName
+
+;; Returns a NodeList of all the Elements with a given tag name in the
+;; order in which they are encountered in a preorder traversal of the
+;; Document tree.
+
+(defun dom-document-get-elements-by-tag-name (doc tagname)
+ "Return a list of all the elements with the given tagname.
+The elements are returned in the order in which they are encountered in
+a preorder traversal of the document tree. The special value \"*\"
+matches all tags."
+ (dom-element-get-elements-by-tag-name-1
+ (dom-document-element doc)
+ tagname))
+
+;;; Interface Node
+
+;; The Node interface is the primary datatype for the entire Document
+;; Object Model. It represents a single node in the document tree. While
+;; all objects implementing the Node interface expose methods for dealing
+;; with children, not all objects implementing the Node interface may have
+;; children. For example, Text nodes may not have children, and adding
+;; children to such nodes results in a DOMException being raised.
+
+;; The attributes name, value and attributes are included as a mechanism
+;; to get at node information without casting down to the specific
+;; derived interface. In cases where there is no obvious mapping of
+;; these attributes for a specific type (e.g., value for an Element or
+;; attributes for a Comment), this returns null. Note that the
+;; specialized interfaces may contain additional and more convenient
+;; mechanisms to get and set the relevant information.
+
+;; FIXME: Use symbols instead of numbers?
+(defconst dom-element-node 1)
+(defconst dom-attribute-node 2)
+(defconst dom-text-node 3)
+; (defconst dom-cdata-section-node 4)
+; (defconst dom-entity-reference-node 5)
+; (defconst dom-entity-node 6)
+; (defconst dom-processing-instruction-node 7)
+; (defconst dom-comment-node 8)
+(defconst dom-document-node 9)
+; (defconst dom-document-type-node 10)
+; (defconst dom-document-fragment-node 11)
+; (defconst dom-notation-node 12)
+
+;; Default names used for Text and Document nodes.
+
+(defconst dom-text-node-name '\#text)
+(defconst dom-document-node-name '\#document)
+
+;; readonly attribute DOMString nodeName;
+;; attribute DOMString nodeValue;
+;; readonly attribute unsigned short nodeType;
+;; readonly attribute Node parentNode;
+;; readonly attribute NodeList childNodes;
+;; readonly attribute Node firstChild;
+;; readonly attribute Node lastChild;
+;; readonly attribute Node previousSibling;
+;; readonly attribute Node nextSibling;
+;; readonly attribute NamedNodeMap attributes;
+;; readonly attribute Document ownerDocument;
+
+(defstruct dom-node
+ (name nil :read-only t)
+ value
+ (type nil :read-only t)
+ parent-node
+ child-nodes
+ attributes
+ owner-document)
+
+(defstruct (dom-document (:include dom-node))
+ element)
+
+(defstruct (dom-element (:include dom-node)))
+
+(defstruct (dom-attr (:include dom-node))
+ owner-element
+ specified)
+
+(defstruct (dom-character-data (:include dom-node)))
+
+(defstruct (dom-text (:include dom-character-data)))
+
+;; All functions defined for nodes are defined for documents and
+;; elements as well. Use `dom-node-defun' to define aliases.
+
+(defun dom-node-defun (func)
+ "Define aliases for symbol FUNC.
+FUNC must have the form dom-node-foo. The aliases created will be named
+dom-document-foo, dom-element-foo, and dom-attr-foo."
+ (if (and (fboundp func)
+ (string-match "^dom-node-" (symbol-name func)))
+ (let ((method (substring (symbol-name func) 9)))
+ (mapc (lambda (prefix)
+ (defalias
+ (intern (concat prefix method)) func))
+ '("dom-document-" "dom-element-" "dom-attr-")))
+ (error "%S is not a dom function" func)))
+
+;; The followin functions implement the virtual attributes firstChild,
+;; lastChild, previousSibling and nextSibling.
+
+(defun dom-node-first-child (node)
+ (car (dom-node-child-nodes node)))
+(dom-node-defun 'dom-node-first-child)
+
+(defun dom-node-last-child (node)
+ (car (last (dom-node-child-nodes node))))
+(dom-node-defun 'dom-node-last-child)
+
+(defun dom-node-previous-sibling (node)
+ (let ((parent (dom-node-parent-node node)))
+ (when parent
+ (let ((list (dom-node-child-nodes parent))
+ prev
+ done)
+ (while (and (not done) list)
+ (if (eq (car list) node)
+ (setq done t)
+ (setq prev (car list)
+ list (cdr list))))
+ prev))))
+(dom-node-defun 'dom-node-previous-sibling)
+
+(defun dom-node-next-sibling (node)
+ (let ((parent (dom-node-parent-node node)))
+ (when parent
+ (nth 1 (memq node (dom-node-child-nodes parent))))))
+(dom-node-defun 'dom-node-next-sibling)
+
+;; appendChild
+
+;; Adds the node newChild to the end of the list of children of
+;; this node. If the newChild is already in the tree, it is
+;; first removed.
+
+;; FIXME: newChild of type Node: The node to add. If it is a DocumentFragment
+;; object, the entire contents of the document fragment are moved into
+;; the child list of this node
+
+(defun dom-node-append-child (node new-child)
+ "Adds NEW-CHILD to the end of the list of children of NODE.
+If NEW-CHILD is already in the document tree, it is first removed.
+NEW-CHILD will be removed from anywhere in the document!
+Return the node added."
+ (dom-node-test-new-child node new-child)
+ (dom-node-unlink-child-from-parent new-child)
+ ;; add new-child at the end of the list
+ (let ((children (dom-node-child-nodes node)))
+ (setf (dom-node-child-nodes node) (nconc children (list new-child))))
+ (setf (dom-node-parent-node new-child) node)
+ new-child)
+(dom-node-defun 'dom-node-append-child)
+
+;; cloneNode
+
+;; Returns a duplicate of this node, i.e., serves as a generic copy
+;; constructor for nodes. The duplicate node has no parent; (parentNode
+;; is null.).
+
+;; FIXME: Cloning an Element copies all attributes and their values,
+;; including those generated by the XML processor to represent defaulted
+;; attributes, but this method does not copy any text it contains unless
+;; it is a deep clone, since the text is contained in a child Text
+;; node. Cloning an Attribute directly, as opposed to be cloned as part
+;; of an Element cloning operation, returns a specified attribute
+;; (specified is true). Cloning any other type of node simply returns a
+;; copy of this node. (the attribute specified is not implemented)
+
+;; FIXME: Note that cloning an immutable subtree results in a mutable
+;; copy, but the children of an EntityReference clone are readonly. In
+;; addition, clones of unspecified Attr nodes are specified. And,
+;; cloning Document, DocumentType, Entity, and Notation nodes is
+;; implementation dependent. (immutable subtrees not implemented)
+
+;; FIXME: The specification says nothing about nextSibling and
+;; previousSibling. We set these to nil as well, matching parentNode.
+
+(defun dom-node-clone-node (node &optional deep)
+ "Return a duplicate of NODE.
+The duplicate node has no parent. Cloning will copy all attributes and
+their values, but this method does not copy any text it contains unless
+it is a DEEP clone, since the text is contained in a child text node.
+
+When the optional argument DEEP is non-nil, this recursively clones the
+subtree under the specified node; if false, clone only the node itself
+\(and its attributes, if it has any)."
+ ;; We don't want to call this recursively because of performance.
+ (let* ((first-copy (copy-dom-node node))
+ (copy first-copy)
+ stack)
+ ;; unlink neighbours of the first copy
+ (setf (dom-node-parent-node first-copy) nil)
+ (while copy
+ ;; prevent sharing of text in text nodes
+ (let ((value (dom-node-value copy)))
+ (when (and value (sequencep value))
+ (setf (dom-node-value copy) (copy-sequence value))))
+ ;; copy attributes, and prevent sharing of text in attribute nodes
+ (let ((attributes (mapcar 'copy-dom-node (dom-node-attributes copy))))
+ (mapc (lambda (attr)
+ (let ((value (dom-node-value attr)))
+ (when (and value (sequencep value))
+ (setf (dom-node-value attr) (copy-sequence value)))))
+ attributes)
+ (setf (dom-node-attributes copy) attributes))
+ (if (not deep)
+ ;; if this is not a deep copy, we are done
+ (setq copy nil)
+ ;; first clone all children
+ (let ((children (mapcar 'copy-dom-node (dom-node-child-nodes copy)))
+ (parent copy))
+ (when children
+ ;; set the children info for the parent
+ (setf (dom-node-child-nodes parent) children)
+ ;; set parent for all children
+ (mapc (lambda (child)
+ (setf (dom-node-parent-node child) parent))
+ children)))
+ ;; move to the next copy, depth first, storing missed branches
+ ;; on the stack -- note that "node" continues to refer to the
+ ;; original node, it should not be used within the while copy
+ ;; loop!
+ (setq copy
+ (cond ((dom-element-first-child copy)
+ (when (dom-element-next-sibling copy)
+ (push (dom-element-next-sibling copy) stack))
+ (dom-element-first-child copy))
+ ((dom-element-next-sibling copy))
+ (t (pop stack))))))
+ first-copy))
+(dom-node-defun 'dom-node-clone-node)
+
+;; hasAttributes introduced in DOM Level 2
+
+;; Returns whether this node (if it is an element) has any
+;; attributes.
+
+(defun dom-node-has-attributes (node)
+ "Return t when NODE has any attributes."
+ (not (null (dom-node-attributes node))))
+(dom-node-defun 'dom-node-has-attributes)
+
+;; hasChildNodes
+
+;; Returns whether this node has any children.
+
+(defun dom-node-has-child-nodes (node)
+ "Return t when NODE has any child nodes."
+ (not (null (dom-node-child-nodes node))))
+(dom-node-defun 'dom-node-has-child-nodes)
+
+;; insertBefore
+
+;; Inserts the node newChild before the existing child node refChild. If
+;; refChild is null, insert newChild at the end of the list of children.
+
+;; FIXME: If newChild is a DocumentFragment object, all of its children
+;; are inserted, in the same order, before refChild. If the newChild is
+;; already in the tree, it is first removed.
+
+(defun dom-node-insert-before (node new-child &optional ref-child)
+ "Insert NEW-CHILD before NODE's existing child REF-CHILD.
+If optional argument REF-CHILD is nil or not given, insert NEW-CHILD at
+the end of the list of NODE's children.
+If NEW-CHILD is already in the document tree, it is first removed.
+NEW-CHILD will be removed from anywhere in the document!
+Return the node added."
+ ;; without ref-child, append it at the end of the list
+ (if (not ref-child)
+ (dom-node-append-child node new-child)
+ (dom-node-test-new-child node new-child)
+ (dom-node-unlink-child-from-parent new-child)
+ ;; find the correct position and insert new-child
+ (let ((children (dom-node-child-nodes node))
+ child-cell done)
+ (while (and (not done) children)
+ (if (eq ref-child (car children))
+ (progn
+ ;; if the first child is ref-child, set the list anew
+ (if (not child-cell)
+ (setf (dom-node-child-nodes node)
+ (cons new-child children))
+ ;; else splice new-child into the list
+ (setcdr child-cell (cons new-child children)))
+ (setq done t))
+ ;; if we didn't find it, advance
+ (setq child-cell children
+ children (cdr children))))
+ (unless done
+ (dom-exception 'dom-not-found-err)))
+ new-child))
+(dom-node-defun 'dom-node-insert-before)
+
+;; removeChild
+
+;; Removes the child node indicated by oldChild from the list of
+;; children, and returns it.
+
+(defun dom-node-remove-child (node old-child)
+ "Remove OLD-CHILD from the list of NODE's children and return it.
+This is very similar to `dom-node-unlink-child-from-parent' but it will
+raise an exception if OLD-CHILD is NODE's child."
+ (let ((children (dom-node-child-nodes node)))
+ (if (memq old-child children)
+ (setf (dom-node-child-nodes node) (delq old-child children)
+ (dom-node-parent-node old-child) nil)
+ (dom-exception 'dom-not-found-err))
+ old-child))
+(dom-node-defun 'dom-node-remove-child)
+
+;; replaceChild
+
+;; Replaces the child node oldChild with newChild in the list of
+;; children, and returns the oldChild node.
+
+;; FIXME: If newChild is a DocumentFragment object, oldChild is replaced
+;; by all of the DocumentFragment children, which are inserted in the
+;; same order.
+
+;; If the newChild is already in the tree, it is first removed.
+
+(defun dom-node-replace-child (node new-child old-child)
+ "Replace OLD-CHILD with NEW-CHILD in the list NODE's children.
+Return OLD-CHILD."
+ (dom-node-test-new-child node new-child)
+ (dom-node-unlink-child-from-parent new-child)
+ (let ((children (dom-node-child-nodes node)))
+ (unless (memq old-child children)
+ (dom-exception 'dom-not-found-err))
+ (setf (dom-node-child-nodes node)
+ (nsubstitute new-child old-child children)))
+ ;; set parent of new-child and old-child
+ (setf (dom-node-parent-node old-child) nil
+ (dom-node-parent-node new-child) node))
+(dom-node-defun 'dom-node-replace-child)
+
+;; textContent of type DOMString, introduced in DOM Level 3
+
+;; This attribute returns the text content of this node and its
+;; descendants.
+
+;; FIXME: When set, any possible children this node may have are
+;; removed and replaced by a single Text node containing the string this
+;; attribute is set to. (not implemented yet)
+
+;; On getting, no serialization is performed, the returned string does
+;; not contain any markup. Similarly, on setting, no parsing is
+;; performed either, the input string is taken as pure textual content.
+
+(defun dom-node-text-content (node)
+ "Return the text content of NODE and its children.
+If NODE is an attribute or a text node, its value is returned."
+ (if (or (dom-attr-p node)
+ (dom-text-p node))
+ (dom-node-value node)
+ (apply 'concat
+ (mapcar 'dom-node-value
+ (dom-element-get-elements-by-tag-name
+ node dom-text-node-name)))))
+(dom-node-defun 'dom-node-text-content)
+
+(defun dom-node-set-text-content (node data)
+ "Set the text content of NODE, replacing all its children.
+If NODE is an attribute or a text node, its value is set."
+ (if (or (dom-attr-p node)
+ (dom-text-p node))
+ (setf (dom-node-value node) data)
+ (setf (dom-node-child-nodes node)
+ (list (dom-document-create-text-node
+ (dom-node-owner-document node)
+ data)))))
+(dom-node-defun 'dom-node-set-text-content)
+
+(defsetf dom-node-text-content dom-node-set-text-content)
+
+;;; Utility functions
+
+;; These utility functions are defined for nodes only.
+
+(defun dom-node-ancestor-p (node ancestor)
+ "Return t if ANCESTOR is an ancestor of NODE in the tree."
+ (let ((parent (dom-node-parent-node node))
+ result)
+ (while (and (not result) parent)
+ (setq result (eq parent ancestor)
+ parent (dom-node-parent-node parent)))
+ result))
+
+(defun dom-node-valid-child (node child)
+ "Return t if CHILD is a valid child for NODE.
+This depends on the node-type of NODE and CHILD."
+ ;; FIXME: Add stuff as we go along.
+ t)
+
+(defun dom-node-test-new-child (node new-child)
+ "Check wether NEW-CHILD is acceptable addition to NODE's children."
+ (when (or (dom-node-ancestor-p node new-child)
+ (eq new-child node)
+ (not (dom-node-valid-child node new-child)))
+ (dom-exception 'dom-hierarchy-request-err))
+ (when (not (eq (dom-node-owner-document node)
+ (dom-node-owner-document new-child)))
+ (dom-exception 'dom-wrong-document-err))
+ new-child)
+
+(defun dom-node-unlink-child-from-parent (node)
+ "Unlink NODE from is previous location.
+This is very similar to `dom-node-remove-child' but it will check wether
+this node is the child of a particular other node."
+ ;; remove node from it's old position
+ (let ((parent (dom-node-parent-node node)))
+ (when parent
+ ;; remove from parent's child-nodes and set own parent to nil
+ (setf (dom-node-child-nodes parent)
+ (delq node (dom-node-child-nodes parent))
+ (dom-node-parent-node node)
+ nil)))
+ node)
+
+;;; Interface NodeList
+
+;; The NodeList interface provides the abstraction of an ordered
+;; collection of nodes, without defining or constraining how this
+;; collection is implemented. NodeList objects in the DOM are live.
+
+;; The items in the NodeList are accessible via an integral index,
+;; starting from 0.
+
+;; This provides alternate names for plain lisp list accessor functions.
+
+(defalias 'dom-node-list-length 'length)
+
+(defun dom-node-list-item (list index); for the sake of argument order
+ "Return element at INDEX in LIST.
+Equivalent to (nth INDEX NODE)."
+ (nth index list))
+
+;; Interface Attr
+
+;; The Attr interface represents an attribute in an Element object.
+;; Typically the allowable values for the attribute are defined in a
+;; document type definition.
+
+;; Attr objects inherit the Node interface, but since they are not
+;; actually child nodes of the element they describe, the DOM does not
+;; consider them part of the document tree. Thus, the Node attributes
+;; parentNode, previousSibling, and nextSibling have a null value for Attr
+;; objects. The DOM takes the view that attributes are properties of
+;; elements rather than having a separate identity from the elements they
+;; are associated with; this should make it more efficient to implement
+;; such features as default attributes associated with all elements of a
+;; given type. Furthermore, Attr nodes may not be immediate children of a
+;; DocumentFragment. However, they can be associated with Element nodes
+;; contained within a DocumentFragment. In short, users and implementors
+;; of the DOM need to be aware that Attr nodes have some things in common
+;; with other objects inheriting the Node interface, but they also are
+;; quite distinct.
+
+;; The attribute's effective value is determined as follows: if this
+;; attribute has been explicitly assigned any value, that value is the
+;; attribute's effective value; otherwise, if there is a declaration for
+;; this attribute, and that declaration includes a default value, then
+;; that default value is the attribute's effective value; otherwise, the
+;; attribute does not exist on this element in the structure model until
+;; it has been explicitly added. Note that the nodeValue attribute on the
+;; Attr instance can also be used to retrieve the string version of the
+;; attribute's value(s).
+
+;; In XML, where the value of an attribute can contain entity references,
+;; the child nodes of the Attr node may be either Text or EntityReference
+;; nodes (when these are in use; see the description of EntityReference
+;; for discussion). Because the DOM Core is not aware of attribute types,
+;; it treats all attribute values as simple strings, even if the DTD or
+;; schema declares them as having tokenized types.
+
+;; ownerElement of type Element, readonly, introduced in DOM Level 2
+
+;; The Element node this attribute is attached to or null if
+;; this attribute is not in use.
+
+;; Interface Element
+
+;; The Element interface represents an element in an HTML or XML
+;; document. Elements may have attributes associated with them; since
+;; the Element interface inherits from Node, the generic Node interface
+;; attribute attributes may be used to retrieve the set of all
+;; attributes for an element. There are methods on the Element interface
+;; to retrieve either an Attr object by name or an attribute value by
+;; name. In XML, where an attribute value may contain entity references,
+;; an Attr object should be retrieved to examine the possibly fairly
+;; complex sub-tree representing the attribute value. On the other hand,
+;; in HTML, where all attributes have simple string values, methods to
+;; directly access an attribute value can safely be used as a
+;; convenience.
+
+(defun dom-element-get-elements-by-tag-name-1 (element name)
+ "Return a list of elements with tag NAME.
+The elements are ELEMENT, its siblings, and their descendants.
+This is used by `dom-element-get-elements-by-tag-name' and
+`dom-document-get-elements-by-tag-name'."
+ ;; We don't want to call this recursively because of performance.
+ (let (stack result)
+ (while element
+ (when (or (string= name "*")
+ (string= name (dom-node-name element)))
+ (setq result (cons element result)))
+ (setq element
+ (cond ((dom-node-first-child element)
+ (when (dom-node-next-sibling element)
+ (push (dom-node-next-sibling element) stack))
+ (dom-node-first-child element))
+ ((dom-node-next-sibling element))
+ (t (pop stack)))))
+ (nreverse result)))
+
+(defun dom-element-get-elements-by-tag-name (element name)
+ "Return a list of all descendant of ELEMENT with tag NAME.
+The elements are returned in the order in which they are encountered in
+a preorder traversal of this element tree."
+ (dom-element-get-elements-by-tag-name-1
+ (dom-element-first-child element)
+ name))
+
+;; Interface Text
+
+;; The Text interface inherits from CharacterData and represents the
+;; textual content (termed character data in XML) of an Element or Attr.
+;; If there is no markup inside an element's content, the text is
+;; contained in a single object implementing the Text interface that is
+;; the only child of the element. If there is markup, it is parsed into
+;; the information items (elements, comments, etc.) and Text nodes that
+;; form the list of children of the element.
+
+;; When a document is first made available via the DOM, there is only one
+;; Text node for each block of text. Users may create adjacent Text nodes
+;; that represent the contents of a given element without any intervening
+;; markup, but should be aware that there is no way to represent the
+;; separations between these nodes in XML or HTML, so they will not (in
+;; general) persist between DOM editing sessions. The normalize() method
+;; on Node merges any such adjacent Text objects into a single node for
+;; each block of text.
+
+;; Character data is represented as a plain string.
+
+
+
+;;; Converting XML to DOM
+
+;; Converting XML (hierarchy of nodes, simple lists, symbols and
+;; strings) to DOM (hierarchy of dom-nodes, defstructs from CL)
+
+(defun dom-make-attribute-from-xml (attribute element doc)
+ "Make a DOM node of attributes based on ATTRIBUTE.
+Called from `dom-make-element-from-xml'.
+ELEMENT is the owner-element.
+DOC is the owner-document."
+ (let* ((name (car attribute))
+ (value (cdr attribute))
+ (attr (dom-document-create-attribute doc name)))
+ (setf (dom-attr-value attr) value
+ (dom-attr-owner-element attr) element)
+ attr))
+
+(defun dom-add-children (parent children)
+ "Add CHILDREN to PARENT.
+CHILDREN is a list of XML NODE elements. Each must
+be converted to a dom-node first."
+ (when children
+ (setf (dom-node-child-nodes parent)
+ (mapcar (lambda (child)
+ (dom-make-node-from-xml
+ child
+ (dom-node-owner-document parent)))
+ children))
+ (mapc (lambda (child)
+ (setf (dom-node-parent-node child)
+ parent))
+ (dom-node-child-nodes parent))))
+
+(defun dom-make-element-from-xml (node owner)
+ "Make a DOM element based on NODE.
+Called from `dom-make-node-from-xml'.
+The atttributes are created by `dom-make-attribute-from-xml'.
+OWNER is stored as the owner-document."
+ (let* ((children (xml-node-children node))
+ (attributes (xml-node-attributes node))
+ (type (xml-node-name node))
+ (element (dom-document-create-element owner type)))
+ (when attributes
+ (setf (dom-node-attributes element)
+ (mapcar (lambda (attribute)
+ (dom-make-attribute-from-xml attribute element owner))
+ attributes)))
+ (when children
+ (dom-add-children element children))
+ element))
+
+(defun dom-make-node-from-xml (node owner)
+ "Make a DOM node based on NODE.
+If NODE is a list, the node is created by `dom-make-element-from-xml'.
+OWNER is stored as the owner-document."
+ (cond ((stringp node)
+ (dom-document-create-text-node owner node))
+ ((listp node)
+ (dom-make-element-from-xml node owner))
+ (t
+ (error "Illegal node: %S" node))))
+
+(defun dom-make-document-from-xml (node)
+ "Return a DOM document based on NODE.
+NODE is a node as returned by `xml-parse-file', either
+a string or a list. The DOM nodes are created using
+`dom-make-node-from-xml'.
+
+Note that `xml-parse-file' returns a list of elements.
+You can only pass one of these nodes as NODE."
+ (let* ((doc (make-dom-document
+ :name dom-document-node-name
+ :type dom-document-node))
+ (node (dom-make-node-from-xml node doc)))
+ (setf (dom-document-owner-document doc) doc; required in dom-add-children
+ (dom-document-element doc) node)
+ doc))
+
+;;; Test stuff
+
+(eval-when-compile
+ (when (file-readable-p "sample.xml")
+ (let ((data (car (xml-parse-file "sample.xml"))))
+ ;; (setq data (car (xml-parse-file "sample.xml")))
+ (assert (fboundp 'dom-node-name))
+ (assert (fboundp 'dom-document-name))
+ (assert (fboundp 'dom-element-name))
+ (assert (fboundp 'dom-attr-name))
+
+ (let ((attr (dom-make-attribute-from-xml
+ (car (xml-node-attributes data)) 'none 'none)))
+ (assert (string= "id" (dom-node-name attr)))
+ (assert (string= "compiler" (dom-node-value attr)))
+ (assert (eq dom-attribute-node (dom-node-type attr))))
+
+ (let ((element (dom-make-node-from-xml data 'no-owner)))
+ (assert (string= "book" (dom-node-name element)))
+ (assert (string= "id" (dom-node-name
+ (car (dom-node-attributes element)))))
+ (assert (string= "compiler"
+ (dom-node-value
+ (car (dom-node-attributes element)))))
+ (assert (string= "bookinfo"
+ (dom-node-name
+ (first (dom-node-child-nodes element)))))
+ (assert (string= "chapter"
+ (dom-node-name
+ (second (dom-node-child-nodes element)))))
+ (let ((title (first
+ (dom-node-child-nodes
+ (first
+ (dom-node-child-nodes
+ (first
+ (dom-node-child-nodes element))))))))
+ (assert (eq 'title (dom-node-name title)))
+ (assert (string= "My own book!"
+ (dom-node-value
+ (first (dom-node-child-nodes title)))))))
+
+ (let ((doc (dom-make-document-from-xml data)))
+ (assert (eq dom-document-node-name (dom-document-name doc)))
+ (assert (string= "book" (dom-node-name (dom-document-element doc))))
+ (assert (eq (dom-node-parent-node
+ (first (dom-node-child-nodes (dom-document-element doc))))
+ (dom-document-element doc)))
+ (assert (eq (first (dom-node-child-nodes (dom-document-element doc)))
+ (dom-node-first-child (dom-document-element doc))))
+ (assert (eq (dom-node-next-sibling
+ (first (dom-node-child-nodes (dom-document-element doc))))
+ (second (dom-node-child-nodes (dom-document-element doc)))))
+ (assert (eq doc
+ (dom-node-owner-document
+ (dom-node-first-child (dom-document-element doc)))))
+ (assert (string= "chapter"
+ (dom-node-name
+ (dom-element-last-child
+ (dom-document-element doc)))))
+ (assert (eq nil (dom-node-previous-sibling (dom-document-element doc)))))
+
+ (assert (eq 3 (dom-node-list-length '(1 2 3))))
+
+ (assert (eq 2 (dom-node-list-item '(1 2 3) 1)))
+
+ (let ((doc (dom-make-document-from-xml data)))
+ (assert (equal (mapcar 'dom-node-name
+ (dom-document-get-elements-by-tag-name
+ doc '*))
+ '(book bookinfo bookbiblio title \#text edition
+ \#text authorgroup author firstname \#text
+ surname \#text chapter title \#text para
+ \#text)))
+ (assert (equal (mapcar 'dom-node-name
+ (dom-document-get-elements-by-tag-name
+ doc 'title))
+ '(title title)))
+ (assert (equal (mapcar 'dom-node-name
+ (dom-element-get-elements-by-tag-name
+ (dom-document-element doc) 'title))
+ '(title title)))
+ (assert (equal (mapcar (lambda (element)
+ (dom-node-value
+ (dom-element-first-child element)))
+ (dom-document-get-elements-by-tag-name
+ doc 'title))
+ '("My own book!" "A very small chapter"))))
+
+ (let* ((doc (dom-make-document-from-xml data))
+ (ancestor (dom-document-element doc))
+ (child (car (dom-document-get-elements-by-tag-name doc 'title))))
+ (assert (dom-node-ancestor-p child ancestor)))
+
+ (let* ((doc (dom-make-document-from-xml data))
+ (book (dom-document-element doc))
+ (old-chapter (dom-element-last-child book))
+ (new-chapter (dom-document-create-element doc 'chapter)))
+ (assert (string= (dom-node-name
+ (dom-element-append-child book new-chapter))
+ "chapter"))
+ (assert (equal (mapcar 'dom-element-name
+ (dom-element-child-nodes book))
+ '(bookinfo chapter chapter)))
+ (assert (eq (dom-element-last-child book) new-chapter))
+ (assert (not (eq (dom-element-last-child book) old-chapter)))
+ (assert (eq (dom-element-next-sibling old-chapter) new-chapter))
+ (assert (eq (dom-element-previous-sibling new-chapter) old-chapter))
+ (assert (eq (dom-element-parent-node new-chapter) book))
+ (assert (dom-node-ancestor-p new-chapter book))
+ (assert (not (eq t (condition-case var
+ (dom-element-append-child book new-chapter)
+ ('dom-hierarchy-request-err
+ t)))))
+ (assert (eq t (condition-case var
+ (dom-element-append-child new-chapter book)
+ ('dom-hierarchy-request-err
+ t)))))
+
+ (let* ((doc (dom-make-document-from-xml data))
+ (book (dom-document-element doc))
+ (old-chapter (dom-element-last-child book))
+ (new-chapter (dom-document-create-element doc 'chapter))
+ (new-title (dom-document-create-element doc 'title))
+ (text (dom-document-create-text-node doc "Test Chapter")))
+ (assert (eq text (dom-element-append-child
+ (dom-element-append-child
+ (dom-element-append-child book new-chapter)
+ new-title)
+ text)))
+ (assert (= 2 (length (dom-node-child-nodes old-chapter))))
+ (assert (= 1 (length (dom-node-child-nodes new-chapter))))
+ (assert (string= "title" (dom-node-name
+ (car (dom-node-child-nodes new-chapter)))))
+ (assert (eq (car (dom-node-child-nodes new-chapter))
+ (dom-node-first-child new-chapter)))
+ (assert (eq new-title
+ (dom-node-first-child new-chapter)))
+ (assert (eq text
+ (dom-node-first-child new-title)))
+ (assert (equal
+ (mapcar (lambda (node)
+ (dom-node-value
+ (dom-node-first-child node)))
+ (dom-document-get-elements-by-tag-name doc 'title))
+ '("My own book!" "A very small chapter" "Test Chapter"))))
+
+ (let* ((doc (dom-make-document-from-xml data))
+ (book (dom-document-element doc))
+ (copy (dom-node-clone-node book)))
+ (assert (not (eq book copy)))
+ (assert (eq (dom-node-child-nodes book)
+ (dom-node-child-nodes copy)))
+ (assert (eq (car (dom-node-child-nodes book))
+ (car (dom-node-child-nodes copy))))
+ (assert (eq (dom-node-first-child book)
+ (dom-node-first-child copy)))
+ (assert (eq (dom-node-last-child book)
+ (dom-node-last-child copy)))
+ (assert (not (eq (dom-node-attributes book)
+ (dom-node-attributes copy))))
+ (assert (eq (dom-node-name (car (dom-node-attributes book)))
+ (dom-node-name (car (dom-node-attributes copy)))))
+ (assert (not (eq (dom-node-value (car (dom-node-attributes book)))
+ (dom-node-value (car (dom-node-attributes copy))))))
+ (assert (equal (dom-node-value (car (dom-node-attributes book)))
+ (dom-node-value (car (dom-node-attributes copy))))))
+
+ (let* ((doc (dom-make-document-from-xml data))
+ (book (dom-document-element doc))
+ (deepcopy (dom-node-clone-node book t)))
+ (assert (not (eq book deepcopy)))
+ (assert (equal (dom-node-attributes book)
+ (dom-node-attributes deepcopy)))
+ (assert (not (eq (dom-node-attributes book)
+ (dom-node-attributes deepcopy))))
+ (assert (equal
+ (mapcar 'dom-node-name
+ (dom-element-get-elements-by-tag-name book '*))
+ (mapcar 'dom-node-name
+ (dom-element-get-elements-by-tag-name deepcopy '*))))
+ (assert (equal
+ (mapcar 'dom-node-value
+ (dom-element-get-elements-by-tag-name book '*))
+ (mapcar 'dom-node-value
+ (dom-element-get-elements-by-tag-name deepcopy '*))))
+ (assert (not (eq (car (dom-element-get-elements-by-tag-name
+ book 'firstname))
+ (car (dom-element-get-elements-by-tag-name
+ deepcopy 'firstname)))))
+ (assert (not (eq (dom-text-value
+ (third (dom-element-get-elements-by-tag-name
+ book '\#text)))
+ (dom-text-value
+ (third (dom-element-get-elements-by-tag-name
+ deepcopy '\#text))))))
+ (assert (string= (dom-text-value
+ (third (dom-element-get-elements-by-tag-name
+ book '\#text)))
+ (dom-text-value
+ (third (dom-element-get-elements-by-tag-name
+ deepcopy '\#text)))))
+ (assert (not (eq (dom-text-value
+ (third (dom-element-get-elements-by-tag-name
+ book '\#text)))
+ (dom-text-value
+ (third (dom-element-get-elements-by-tag-name
+ deepcopy '\#text)))))))
+
+ (let* ((doc (dom-make-document-from-xml data))
+ (book (dom-document-element doc))
+ (old-chapter (dom-element-last-child book))
+ (new-chapter (dom-document-create-element doc 'chapter)))
+ (assert (eq (dom-node-name (dom-element-insert-before book new-chapter))
+ 'chapter))
+ (assert (equal (mapcar 'dom-element-name
+ (dom-element-child-nodes book))
+ '(bookinfo chapter chapter)))
+ (assert (eq new-chapter (dom-element-insert-before
+ book new-chapter
+ (dom-element-first-child book))))
+ (assert (equal (mapcar 'dom-element-name
+ (dom-element-child-nodes book))
+ '(chapter bookinfo chapter)))
+ (let ((new-bookinfo (dom-document-create-element doc 'bookinfo)))
+ (dom-element-insert-before book new-bookinfo old-chapter))
+ (assert (equal (mapcar 'dom-element-name
+ (dom-element-child-nodes book))
+ '(chapter bookinfo bookinfo chapter))))
+
+ ;; FIXME: some more tests for `dom-node-remove-child' and
+ ;; `dom-node-replace-child' would be nice... :)
+ (let* ((doc (dom-make-document-from-xml data))
+ (book (dom-document-element doc))
+ (old-chapter (dom-element-last-child book))
+ (new-chapter (dom-document-create-element doc 'chapter)))
+ (dom-node-remove-child book old-chapter)
+ (assert (equal (mapcar 'dom-node-name (dom-node-child-nodes book))
+ '(bookinfo)))
+ (dom-node-replace-child book new-chapter
+ (dom-node-first-child book))
+ (assert (equal (mapcar 'dom-node-name (dom-node-child-nodes book))
+ '(chapter))))
+
+ (let* ((doc (make-dom-document))
+ (par (dom-document-create-element doc 'p))
+ (part1 (dom-document-create-text-node doc "This is "))
+ (part2 (dom-document-create-element doc 'b))
+ (part3 (dom-document-create-text-node doc ".")))
+ (dom-element-append-child
+ part2 (dom-document-create-text-node doc "bold"))
+ (dom-element-append-child par part1)
+ (dom-element-append-child par part2)
+ (dom-element-append-child par part3)
+ (setf (dom-document-owner-document doc) doc
+ (dom-document-element doc) par)
+ (assert (eq (dom-document-element doc) par))
+ (assert (string= (dom-node-text-content par)
+ "This is bold."))
+ (dom-node-set-text-content par "This is plain.")
+ (assert (string= (dom-node-text-content par)
+ "This is plain."))
+ (assert (equal (mapcar 'dom-node-name (dom-node-child-nodes par))
+ '(\#text)))
+ (setf (dom-node-text-content par) "New text.")
+ (assert (string= (dom-node-text-content par)
+ "New text."))
+ (setf (dom-element-text-content par) "Different text.")
+ (assert (string= (dom-element-text-content par)
+ "Different text."))
+ (let ((at (dom-document-create-attribute doc 'foo)))
+ (setf (dom-attr-value at) "domino"
+ (dom-element-attributes par) (list at))
+ (assert (string= "domino"
+ (dom-node-value
+ (dom-node-list-item
+ (dom-element-attributes par)
+ 0))))
+ (assert (string= "domino"
+ (dom-node-text-content
+ (dom-node-list-item
+ (dom-element-attributes par)
+ 0))))))
+
+ (let* ((doc (dom-make-document-from-xml data))
+ (title (car (dom-document-get-elements-by-tag-name doc "title"))))
+ (assert (equal (dom-element-text-content title)
+ "My own book!"))))))
+
+(provide 'dom)
+
+;;; dom.el ends here.
projects / emacs-init.git / blobdiff