Download
(require 'cl)
(require 'xml)
(let ((errors
'((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."
(signal exception data))
(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))
(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))
(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))
(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))
(defconst dom-element-node 1)
(defconst dom-attribute-node 2)
(defconst dom-text-node 3)
(defconst dom-document-node 9)
(defconst dom-text-node-name '\#text)
(defconst dom-document-node-name '\#document)
(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)))
(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)))
(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)
(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)
(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)
(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)."
(let* ((first-copy (copy-dom-node node))
(copy first-copy)
stack)
(setf (dom-node-parent-node first-copy) nil)
(while copy
(let ((value (dom-node-value copy)))
(when (and value (sequencep value))
(setf (dom-node-value copy) (copy-sequence value))))
(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)
(setq copy nil)
(let ((children (mapcar 'copy-dom-node (dom-node-child-nodes copy)))
(parent copy))
(when children
(setf (dom-node-child-nodes parent) children)
(mapc (lambda (child)
(setf (dom-node-parent-node child) parent))
children)))
(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)
(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)
(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)
(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."
(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)
(let ((children (dom-node-child-nodes node))
child-cell done)
(while (and (not done) children)
(if (eq ref-child (car children))
(progn
(if (not child-cell)
(setf (dom-node-child-nodes node)
(cons new-child children))
(setcdr child-cell (cons new-child children)))
(setq done t))
(setq child-cell children
children (cdr children))))
(unless done
(dom-exception 'dom-not-found-err)))
new-child))
(dom-node-defun 'dom-node-insert-before)
(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)
(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)))
(setf (dom-node-parent-node old-child) nil
(dom-node-parent-node new-child) node))
(dom-node-defun 'dom-node-replace-child)
(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)
(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."
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."
(let ((parent (dom-node-parent-node node)))
(when parent
(setf (dom-node-child-nodes parent)
(delq node (dom-node-child-nodes parent))
(dom-node-parent-node node)
nil)))
node)
(defalias 'dom-node-list-length 'length)
(defun dom-node-list-item (list index)
"Return element at INDEX in LIST.
Equivalent to (nth INDEX NODE)."
(nth index list))
(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'."
(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))
(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
(dom-document-element doc) node)
doc))
(eval-when-compile
(when (file-readable-p "sample.xml")
(let ((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))))
(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)