1 ;;; xml.el --- XML parser
3 ;; Copyright (C) 2000, 2001 Free Software Foundation, Inc.
5 ;; Author: Emmanuel Briot <briot@gnat.com>
6 ;; Maintainer: Emmanuel Briot <briot@gnat.com>
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software: you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
26 ;; This file contains a full XML parser. It parses a file, and returns a list
27 ;; that can be used internally by any other lisp file.
28 ;; See some example in todo.el
32 ;; It does not parse the DTD, if present in the XML file, but knows how to
33 ;; ignore it. The XML file is assumed to be well-formed. In case of error, the
34 ;; parsing stops and the XML file is shown where the parsing stopped.
36 ;; It also knows how to ignore comments, as well as the special ?xml? tag
39 ;; The XML file should have the following format:
40 ;; <node1 attr1="name1" attr2="name2" ...>value
41 ;; <node2 attr3="name3" attr4="name4">value2</node2>
42 ;; <node3 attr5="name5" attr6="name6">value3</node3>
44 ;; Of course, the name of the nodes and attributes can be anything. There can
45 ;; be any number of attributes (or none), as well as any number of children
48 ;; There can be only top level node, but with any number of children below.
52 ;; The functions `xml-parse-file' and `xml-parse-tag' return a list with
53 ;; the following format:
55 ;; xml-list ::= (node node ...)
56 ;; node ::= (tag_name attribute-list . child_node_list)
57 ;; child_node_list ::= child_node child_node ...
58 ;; child_node ::= node | string
59 ;; tag_name ::= string
60 ;; attribute_list ::= (("attribute" . "value") ("attribute" . "value") ...)
64 ;; Some macros are provided to ease the parsing of this list
68 ;;*******************************************************************
70 ;;** Macros to parse the list
72 ;;*******************************************************************
74 (defsubst xml-node-name (node)
75 "Return the tag associated with NODE.
76 The tag is a lower-case symbol."
79 (defsubst xml-node-attributes (node)
80 "Return the list of attributes of NODE.
84 (defsubst xml-node-children (node)
85 "Return the list of children of NODE.
86 This is a list of nodes, and it can be nil."
89 (defun xml-get-children (node child-name)
90 "Return the children of NODE whose tag is CHILD-NAME.
91 CHILD-NAME should be a lower case symbol."
93 (dolist (child (xml-node-children node))
95 (if (equal (xml-node-name child) child-name)
99 (defun xml-get-attribute (node attribute)
100 "Get from NODE the value of ATTRIBUTE.
101 An empty string is returned if the attribute was not found."
102 (if (xml-node-attributes node)
103 (let ((value (assoc attribute (xml-node-attributes node))))
109 ;;*******************************************************************
111 ;;** Creating the list
113 ;;*******************************************************************
115 (defun xml-parse-file (file &optional parse-dtd)
116 "Parse the well-formed XML FILE.
117 If FILE is already edited, this will keep the buffer alive.
118 Returns the top node with all its children.
119 If PARSE-DTD is non-nil, the DTD is parsed rather than skipped."
121 (if (get-file-buffer file)
123 (set-buffer (get-file-buffer file))
127 (let ((xml (xml-parse-region (point-min)
133 (kill-buffer (current-buffer)))
136 (defun xml-parse-region (beg end &optional buffer parse-dtd)
137 "Parse the region from BEG to END in BUFFER.
138 If BUFFER is nil, it defaults to the current buffer.
139 Returns the XML list for the region, or raises an error if the region
140 is not a well-formed XML file.
141 If PARSE-DTD is non-nil, the DTD is parsed rather than skipped,
142 and returned as the first element of the list"
143 (let (xml result dtd)
148 (while (< (point) end)
149 (if (search-forward "<" end t)
154 (setq result (xml-parse-tag end parse-dtd))
157 ((listp (car result))
158 (setq dtd (car result))
159 (add-to-list 'xml (cdr result)))
161 (add-to-list 'xml result))))
163 ;; translation of rule [1] of XML specifications
164 (error "XML files can have only one toplevel tag")))
167 (cons dtd (reverse xml))
171 (defun xml-parse-tag (end &optional parse-dtd)
172 "Parse the tag that is just in front of point.
173 The end tag must be found before the position END in the current buffer.
174 If PARSE-DTD is non-nil, the DTD of the document, if any, is parsed and
175 returned as the first element in the list.
177 - a list : the matching node
178 - nil : the point is not looking at a tag.
179 - a cons cell: the first element is the DTD, the second is the node"
181 ;; Processing instructions (like the <?xml version="1.0"?> tag at the
182 ;; beginning of a document)
184 (search-forward "?>" end)
185 (skip-chars-forward " \t\n")
187 ;; Character data (CDATA) sections, in which no tag should be interpreted
188 ((looking-at "<!\\[CDATA\\[")
189 (let ((pos (match-end 0)))
190 (unless (search-forward "]]>" end t)
191 (error "CDATA section does not end anywhere in the document"))
192 (buffer-substring-no-properties pos (match-beginning 0))))
193 ;; DTD for the document
194 ((looking-at "<!DOCTYPE")
197 (setq dtd (xml-parse-dtd end))
199 (skip-chars-forward " \t\n")
201 (cons dtd (xml-parse-tag end))
202 (xml-parse-tag end))))
205 (search-forward "-->" end)
211 ((looking-at "<\\([^/> \t\n]+\\)")
212 (goto-char (match-end 1))
213 (let* ((case-fold-search nil) ;; XML is case-sensitive.
214 (node-name (match-string 1))
215 ;; Parse the attribute list.
216 (children (list (xml-parse-attlist end) (intern node-name)))
219 ;; is this an empty element ?
220 (if (looking-at "/>")
223 (nreverse (cons '("") children)))
225 ;; is this a valid start tag ?
226 (if (eq (char-after) ?>)
229 ;; Now check that we have the right end-tag. Note that this
230 ;; one might contain spaces after the tag name
231 (while (not (looking-at (concat "</" node-name "[ \t\n]*>")))
235 "XML: invalid syntax -- invalid end tag (expecting "
237 ") at pos " (number-to-string (point)))))
239 (let ((tag (xml-parse-tag end)))
241 (push tag children))))
244 (search-forward "<" end)
246 (let ((string (buffer-substring-no-properties pos (point)))
249 ;; Clean up the string (no newline characters)
250 ;; Not done, since as per XML specifications, the XML processor
251 ;; should always pass the whole string to the application.
252 ;; (while (string-match "\\s +" string pos)
253 ;; (setq string (replace-match " " t t string))
254 ;; (setq pos (1+ (match-beginning 0))))
256 (setq string (xml-substitute-special string))
258 (if (stringp (car children))
259 ;; The two strings were separated by a comment.
260 (cons (concat (car children) string)
262 (cons string children)))))))
263 (goto-char (match-end 0))
265 (error "XML: End tag for %s not found before end of region"
269 ;; This was an invalid start tag
270 (error "XML: Invalid attribute list")
272 (t ;; This is not a tag.
273 (error "XML: Invalid character"))
276 (defun xml-parse-attlist (end)
277 "Return the attribute-list that point is looking at.
278 The search for attributes end at the position END in the current buffer.
279 Leaves the point on the first non-blank character after the tag."
282 (skip-chars-forward " \t\n")
283 (while (looking-at "\\([a-zA-Z_:][-a-zA-Z0-9._:]*\\)[ \t\n]*=[ \t\n]*")
284 (setq name (intern (match-string 1)))
285 (goto-char (match-end 0))
287 ;; Do we have a string between quotes (or double-quotes),
288 ;; or a simple word ?
289 (unless (looking-at "\"\\([^\"]*\\)\"")
290 (unless (looking-at "'\\([^']*\\)'")
291 (error "XML: Attribute values must be given between quotes")))
293 ;; Each attribute must be unique within a given element
294 (if (assoc name attlist)
295 (error "XML: each attribute must be unique within an element"))
297 (push (cons name (match-string-no-properties 1)) attlist)
298 (goto-char (match-end 0))
299 (skip-chars-forward " \t\n")
301 (error "XML: end of attribute list not found before end of region"))
305 ;;*******************************************************************
307 ;;** The DTD (document type declaration)
308 ;;** The following functions know how to skip or parse the DTD of
311 ;;*******************************************************************
313 (defun xml-skip-dtd (end)
314 "Skip the DTD that point is looking at.
315 The DTD must end before the position END in the current buffer.
316 The point must be just before the starting tag of the DTD.
317 This follows the rule [28] in the XML specifications."
318 (forward-char (length "<!DOCTYPE"))
319 (if (looking-at "[ \t\n]*>")
320 (error "XML: invalid DTD (excepting name of the document)"))
323 (forward-word 1) ;; name of the document
324 (skip-chars-forward " \t\n")
325 (if (looking-at "\\[")
326 (re-search-forward "\\][ \t\n]*>" end)
327 (search-forward ">" end)))
328 (error (error "XML: No end to the DTD"))))
330 (defun xml-parse-dtd (end)
331 "Parse the DTD that point is looking at.
332 The DTD must end before the position END in the current buffer."
333 (forward-char (length "<!DOCTYPE"))
334 (skip-chars-forward " \t\n")
336 (error "XML: invalid DTD (excepting name of the document)"))
338 ;; Get the name of the document
340 (let ((dtd (list (match-string-no-properties 0) 'dtd))
341 type element end-pos)
342 (goto-char (match-end 0))
344 (skip-chars-forward " \t\n")
346 ;; External DTDs => don't know how to handle them yet
347 (if (looking-at "SYSTEM")
348 (error "XML: Don't know how to handle external DTDs"))
350 (if (not (= (char-after) ?\[))
351 (error "XML: Unknown declaration in the DTD"))
353 ;; Parse the rest of the DTD
355 (while (and (not (looking-at "[ \t\n]*\\]"))
359 ;; Translation of rule [45] of XML specifications
361 "[\t \n]*<!ELEMENT[ \t\n]+\\([a-zA-Z0-9.%;]+\\)[ \t\n]+\\([^>]+\\)>")
363 (setq element (intern (match-string-no-properties 1))
364 type (match-string-no-properties 2))
365 (setq end-pos (match-end 0))
367 ;; Translation of rule [46] of XML specifications
369 ((string-match "^EMPTY[ \t\n]*$" type) ;; empty declaration
371 ((string-match "^ANY[ \t\n]*$" type) ;; any type of contents
373 ((string-match "^(\\(.*\\))[ \t\n]*$" type) ;; children ([47])
374 (setq type (xml-parse-elem-type (match-string-no-properties 1 type))))
375 ((string-match "^%[^;]+;[ \t\n]*$" type) ;; substitution
378 (error "XML: Invalid element type in the DTD")))
380 ;; rule [45]: the element declaration must be unique
381 (if (assoc element dtd)
382 (error "XML: elements declaration must be unique in a DTD (<%s>)"
383 (symbol-name element)))
385 ;; Store the element in the DTD
386 (push (list element type) dtd)
391 (error "XML: Invalid DTD item"))
395 ;; Skip the end of the DTD
396 (search-forward ">" end)
400 (defun xml-parse-elem-type (string)
401 "Convert a STRING for an element type into an elisp structure."
404 (if (string-match "(\\([^)]+\\))\\([+*?]?\\)" string)
406 (setq elem (match-string 1 string)
407 modifier (match-string 2 string))
408 (if (string-match "|" elem)
409 (setq elem (cons 'choice
410 (mapcar 'xml-parse-elem-type
411 (split-string elem "|"))))
412 (if (string-match "," elem)
413 (setq elem (cons 'seq
414 (mapcar 'xml-parse-elem-type
415 (split-string elem ","))))
417 (if (string-match "[ \t\n]*\\([^+*?]+\\)\\([+*?]?\\)" string)
418 (setq elem (match-string 1 string)
419 modifier (match-string 2 string))))
421 (if (and (stringp elem) (string= elem "#PCDATA"))
425 ((string= modifier "+")
427 ((string= modifier "*")
429 ((string= modifier "?")
435 ;;*******************************************************************
437 ;;** Substituting special XML sequences
439 ;;*******************************************************************
441 (defun xml-substitute-special (string)
442 "Return STRING, after subsituting special XML sequences."
443 (while (string-match "&" string)
444 (setq string (replace-match "&" t nil string)))
445 (while (string-match "<" string)
446 (setq string (replace-match "<" t nil string)))
447 (while (string-match ">" string)
448 (setq string (replace-match ">" t nil string)))
449 (while (string-match "'" string)
450 (setq string (replace-match "'" t nil string)))
451 (while (string-match """ string)
452 (setq string (replace-match "\"" t nil string)))
455 ;;*******************************************************************
457 ;;** Printing a tree.
458 ;;** This function is intended mainly for debugging purposes.
460 ;;*******************************************************************
462 (defun xml-debug-print (xml)
464 (xml-debug-print-internal node "")))
466 (defun xml-debug-print-internal (xml indent-string)
467 "Outputs the XML tree in the current buffer.
468 The first line indented with INDENT-STRING."
471 (insert indent-string "<" (symbol-name (xml-node-name tree)))
473 ;; output the attribute list
474 (setq attlist (xml-node-attributes tree))
477 (insert (symbol-name (caar attlist)) "=\"" (cdar attlist) "\"")
478 (setq attlist (cdr attlist)))
482 (setq tree (xml-node-children tree))
484 ;; output the children
489 (xml-debug-print-internal node (concat indent-string " ")))
490 ((stringp node) (insert node))
492 (error "Invalid XML tree"))))
494 (insert "\n" indent-string
495 "</" (symbol-name (xml-node-name xml)) ">")))