1 |
;;; xml.el --- XML parser |
;;; xml.el --- XML parser |
2 |
|
|
3 |
;; Copyright (C) 2000, 2001 Free Software Foundation, Inc. |
;; Copyright (C) 2000, 2001, 2003 Free Software Foundation, Inc. |
4 |
|
|
5 |
;; Author: Emmanuel Briot <briot@gnat.com> |
;; Author: Emmanuel Briot <briot@gnat.com> |
6 |
;; Maintainer: Emmanuel Briot <briot@gnat.com> |
;; Maintainer: FSF |
7 |
;; Keywords: xml |
;; Keywords: xml, data |
8 |
|
|
9 |
;; This file is part of GNU Emacs. |
;; This file is part of GNU Emacs. |
10 |
|
|
25 |
|
|
26 |
;;; Commentary: |
;;; Commentary: |
27 |
|
|
28 |
;; This file contains a full XML parser. It parses a file, and returns a list |
;; This file contains a somewhat incomplete non-validating XML parser. It |
29 |
;; that can be used internally by any other lisp file. |
;; parses a file, and returns a list that can be used internally by |
30 |
;; See some example in todo.el |
;; any other lisp libraries. |
31 |
|
|
32 |
;;; FILE FORMAT |
;;; FILE FORMAT |
33 |
|
|
34 |
;; It does not parse the DTD, if present in the XML file, but knows how to |
;; The document type declaration may either be ignored or (optionally) |
35 |
;; ignore it. The XML file is assumed to be well-formed. In case of error, the |
;; parsed, but currently the parsing will only accept element |
36 |
;; parsing stops and the XML file is shown where the parsing stopped. |
;; declarations. The XML file is assumed to be well-formed. In case |
37 |
|
;; of error, the parsing stops and the XML file is shown where the |
38 |
|
;; parsing stopped. |
39 |
;; |
;; |
40 |
;; It also knows how to ignore comments, as well as the special ?xml? tag |
;; It also knows how to ignore comments and processing instructions. |
|
;; in the XML file. |
|
41 |
;; |
;; |
42 |
;; The XML file should have the following format: |
;; The XML file should have the following format: |
43 |
;; <node1 attr1="name1" attr2="name2" ...>value |
;; <node1 attr1="name1" attr2="name2" ...>value |
64 |
;; | nil |
;; | nil |
65 |
;; string ::= "..." |
;; string ::= "..." |
66 |
;; |
;; |
67 |
;; Some macros are provided to ease the parsing of this list |
;; Some macros are provided to ease the parsing of this list. |
68 |
|
;; Whitespace is preserved. Fixme: There should be a tree-walker that |
69 |
|
;; can remove it. |
70 |
|
|
71 |
;;; Code: |
;;; Code: |
72 |
|
|
73 |
|
;; Note that {buffer-substring,match-string}-no-properties were |
74 |
|
;; formerly used in several places, but that removes composition info. |
75 |
|
|
76 |
;;******************************************************************* |
;;******************************************************************* |
77 |
;;** |
;;** |
78 |
;;** Macros to parse the list |
;;** Macros to parse the list |
120 |
;;** |
;;** |
121 |
;;******************************************************************* |
;;******************************************************************* |
122 |
|
|
123 |
|
;;;###autoload |
124 |
(defun xml-parse-file (file &optional parse-dtd) |
(defun xml-parse-file (file &optional parse-dtd) |
125 |
"Parse the well-formed XML FILE. |
"Parse the well-formed XML file FILE. |
126 |
If FILE is already edited, this will keep the buffer alive. |
If FILE is already visited, use its buffer and don't kill it. |
127 |
Returns the top node with all its children. |
Returns the top node with all its children. |
128 |
If PARSE-DTD is non-nil, the DTD is parsed rather than skipped." |
If PARSE-DTD is non-nil, the DTD is parsed rather than skipped." |
129 |
(let ((keep)) |
(let ((keep)) |
131 |
(progn |
(progn |
132 |
(set-buffer (get-file-buffer file)) |
(set-buffer (get-file-buffer file)) |
133 |
(setq keep (point))) |
(setq keep (point))) |
134 |
(find-file file)) |
(let (auto-mode-alist) ; no need for xml-mode |
135 |
|
(find-file file))) |
136 |
|
|
137 |
(let ((xml (xml-parse-region (point-min) |
(let ((xml (xml-parse-region (point-min) |
138 |
(point-max) |
(point-max) |
143 |
(kill-buffer (current-buffer))) |
(kill-buffer (current-buffer))) |
144 |
xml))) |
xml))) |
145 |
|
|
146 |
|
;; Note that this is setup so that we can do whitespace-skipping with |
147 |
|
;; `(skip-syntax-forward " ")', inter alia. Previously this was slow |
148 |
|
;; compared with `re-search-forward', but that has been fixed. Also |
149 |
|
;; note that the standard syntax table contains other characters with |
150 |
|
;; whitespace syntax, like NBSP, but they are invalid in contexts in |
151 |
|
;; which we might skip whitespace -- specifically, they're not |
152 |
|
;; NameChars [XML 4]. |
153 |
|
|
154 |
|
(defvar xml-syntax-table |
155 |
|
(let ((table (make-syntax-table))) |
156 |
|
;; Get space syntax correct per XML [3]. |
157 |
|
(dotimes (c 31) |
158 |
|
(modify-syntax-entry c "." table)) ; all are space in standard table |
159 |
|
(dolist (c '(?\t ?\n ?\r)) ; these should be space |
160 |
|
(modify-syntax-entry c " " table)) |
161 |
|
;; For skipping attributes. |
162 |
|
(modify-syntax-entry ?\" "\"" table) |
163 |
|
(modify-syntax-entry ?' "\"" table) |
164 |
|
;; Non-alnum name chars should be symbol constituents (`-' and `_' |
165 |
|
;; are OK by default). |
166 |
|
(modify-syntax-entry ?. "_" table) |
167 |
|
(modify-syntax-entry ?: "_" table) |
168 |
|
;; XML [89] |
169 |
|
(dolist (c '(#x00B7 #x02D0 #x02D1 #x0387 #x0640 #x0E46 #x0EC6 #x3005 |
170 |
|
#x3031 #x3032 #x3033 #x3034 #x3035 #x309D #x309E #x30FC |
171 |
|
#x30FD #x30FE)) |
172 |
|
(modify-syntax-entry (decode-char 'ucs c) "w" table)) |
173 |
|
;; Fixme: rest of [4] |
174 |
|
table) |
175 |
|
"Syntax table used by `xml-parse-region'.") |
176 |
|
|
177 |
|
;; XML [5] |
178 |
|
;; Note that [:alpha:] matches all multibyte chars with word syntax. |
179 |
|
(defconst xml-name-regexp "[[:alpha:]_:][[:alnum:]._:-]*") |
180 |
|
|
181 |
|
;; Fixme: This needs re-writing to deal with the XML grammar properly, i.e. |
182 |
|
;; document ::= prolog element Misc* |
183 |
|
;; prolog ::= XMLDecl? Misc* (doctypedecl Misc*)? |
184 |
|
|
185 |
|
;;;###autoload |
186 |
(defun xml-parse-region (beg end &optional buffer parse-dtd) |
(defun xml-parse-region (beg end &optional buffer parse-dtd) |
187 |
"Parse the region from BEG to END in BUFFER. |
"Parse the region from BEG to END in BUFFER. |
188 |
If BUFFER is nil, it defaults to the current buffer. |
If BUFFER is nil, it defaults to the current buffer. |
189 |
Returns the XML list for the region, or raises an error if the region |
Returns the XML list for the region, or raises an error if the region |
190 |
is not a well-formed XML file. |
is not a well-formed XML file. |
191 |
If PARSE-DTD is non-nil, the DTD is parsed rather than skipped, |
If PARSE-DTD is non-nil, the DTD is parsed rather than skipped, |
192 |
and returned as the first element of the list" |
and returned as the first element of the list." |
193 |
(let (xml result dtd) |
(save-restriction |
194 |
(save-excursion |
(narrow-to-region beg end) |
195 |
(if buffer |
;; Use fixed syntax table to ensure regexp char classes and syntax |
196 |
(set-buffer buffer)) |
;; specs DTRT. |
197 |
(goto-char beg) |
(with-syntax-table (standard-syntax-table) |
198 |
(while (< (point) end) |
(let ((case-fold-search nil) ; XML is case-sensitive. |
199 |
(if (search-forward "<" end t) |
xml result dtd) |
200 |
(progn |
(save-excursion |
201 |
(forward-char -1) |
(if buffer |
202 |
(if (null xml) |
(set-buffer buffer)) |
203 |
(progn |
(goto-char (point-min)) |
204 |
(setq result (xml-parse-tag end parse-dtd)) |
(while (not (eobp)) |
205 |
|
(if (search-forward "<" nil t) |
206 |
|
(progn |
207 |
|
(forward-char -1) |
208 |
|
(if xml |
209 |
|
;; translation of rule [1] of XML specifications |
210 |
|
(error "XML files can have only one toplevel tag") |
211 |
|
(setq result (xml-parse-tag parse-dtd)) |
212 |
(cond |
(cond |
213 |
((null result)) |
((null result)) |
214 |
((listp (car result)) |
((listp (car result)) |
215 |
(setq dtd (car result)) |
(setq dtd (car result)) |
216 |
(add-to-list 'xml (cdr result))) |
(if (cdr result) ; possible leading comment |
217 |
|
(add-to-list 'xml (cdr result)))) |
218 |
(t |
(t |
219 |
(add-to-list 'xml result)))) |
(add-to-list 'xml result))))) |
220 |
|
(goto-char (point-max)))) |
221 |
;; translation of rule [1] of XML specifications |
(if parse-dtd |
222 |
(error "XML files can have only one toplevel tag"))) |
(cons dtd (nreverse xml)) |
223 |
(goto-char end))) |
(nreverse xml))))))) |
|
(if parse-dtd |
|
|
(cons dtd (reverse xml)) |
|
|
(reverse xml))))) |
|
224 |
|
|
225 |
|
|
226 |
(defun xml-parse-tag (end &optional parse-dtd) |
(defun xml-parse-tag (&optional parse-dtd) |
227 |
"Parse the tag that is just in front of point. |
"Parse the tag at point. |
|
The end tag must be found before the position END in the current buffer. |
|
228 |
If PARSE-DTD is non-nil, the DTD of the document, if any, is parsed and |
If PARSE-DTD is non-nil, the DTD of the document, if any, is parsed and |
229 |
returned as the first element in the list. |
returned as the first element in the list. |
230 |
Returns one of: |
Returns one of: |
231 |
- a list : the matching node |
- a list : the matching node |
232 |
- nil : the point is not looking at a tag. |
- nil : the point is not looking at a tag. |
233 |
- a cons cell: the first element is the DTD, the second is the node" |
- a pair : the first element is the DTD, the second is the node." |
234 |
(cond |
(cond |
235 |
;; Processing instructions (like the <?xml version="1.0"?> tag at the |
;; Processing instructions (like the <?xml version="1.0"?> tag at the |
236 |
;; beginning of a document) |
;; beginning of a document). |
237 |
((looking-at "<\\?") |
((looking-at "<\\?") |
238 |
(search-forward "?>" end) |
(search-forward "?>") |
239 |
(goto-char (- (re-search-forward "[^ \t\n\r]") 1)) |
(skip-syntax-forward " ") |
240 |
(xml-parse-tag end)) |
(xml-parse-tag parse-dtd)) |
241 |
;; Character data (CDATA) sections, in which no tag should be interpreted |
;; Character data (CDATA) sections, in which no tag should be interpreted |
242 |
((looking-at "<!\\[CDATA\\[") |
((looking-at "<!\\[CDATA\\[") |
243 |
(let ((pos (match-end 0))) |
(let ((pos (match-end 0))) |
244 |
(unless (search-forward "]]>" end t) |
(unless (search-forward "]]>" nil t) |
245 |
(error "CDATA section does not end anywhere in the document")) |
(error "CDATA section does not end anywhere in the document")) |
246 |
(buffer-substring-no-properties pos (match-beginning 0)))) |
(buffer-substring pos (match-beginning 0)))) |
247 |
;; DTD for the document |
;; DTD for the document |
248 |
((looking-at "<!DOCTYPE") |
((looking-at "<!DOCTYPE") |
249 |
(let (dtd) |
(let (dtd) |
250 |
(if parse-dtd |
(if parse-dtd |
251 |
(setq dtd (xml-parse-dtd end)) |
(setq dtd (xml-parse-dtd)) |
252 |
(xml-skip-dtd end)) |
(xml-skip-dtd)) |
253 |
(goto-char (- (re-search-forward "[^ \t\n\r]") 1)) |
(skip-syntax-forward " ") |
254 |
(if dtd |
(if dtd |
255 |
(cons dtd (xml-parse-tag end)) |
(cons dtd (xml-parse-tag)) |
256 |
(xml-parse-tag end)))) |
(xml-parse-tag)))) |
257 |
;; skip comments |
;; skip comments |
258 |
((looking-at "<!--") |
((looking-at "<!--") |
259 |
(search-forward "-->" end) |
(search-forward "-->") |
260 |
nil) |
nil) |
261 |
;; end tag |
;; end tag |
262 |
((looking-at "</") |
((looking-at "</") |
263 |
'()) |
'()) |
264 |
;; opening tag |
;; opening tag |
265 |
((looking-at "<\\([^/> \t\n\r]+\\)") |
((looking-at "<\\([^/>[:space:]]+\\)") |
266 |
(goto-char (match-end 1)) |
(goto-char (match-end 1)) |
267 |
(let* ((case-fold-search nil) ;; XML is case-sensitive. |
(let* ((node-name (match-string 1)) |
|
(node-name (match-string 1)) |
|
268 |
;; Parse the attribute list. |
;; Parse the attribute list. |
269 |
(children (list (xml-parse-attlist end) (intern node-name))) |
(children (list (xml-parse-attlist) (intern node-name))) |
270 |
pos) |
pos) |
271 |
|
|
272 |
;; is this an empty element ? |
;; is this an empty element ? |
273 |
(if (looking-at "/[ \t\n\r]*>") |
(if (looking-at "/>") |
274 |
(progn |
(progn |
275 |
(forward-char 2) |
(forward-char 2) |
276 |
|
;; Fixme: Inconsistent with the nil content returned from |
277 |
|
;; `<tag></tag>'. |
278 |
(nreverse (cons '("") children))) |
(nreverse (cons '("") children))) |
279 |
|
|
280 |
;; is this a valid start tag ? |
;; is this a valid start tag ? |
283 |
(forward-char 1) |
(forward-char 1) |
284 |
;; Now check that we have the right end-tag. Note that this |
;; Now check that we have the right end-tag. Note that this |
285 |
;; one might contain spaces after the tag name |
;; one might contain spaces after the tag name |
286 |
(while (not (looking-at (concat "</" node-name "[ \t\n\r]*>"))) |
(let ((end (concat "</" node-name "\\s-*>"))) |
287 |
(cond |
(while (not (looking-at end)) |
288 |
((looking-at "</") |
(cond |
289 |
(error (concat |
((looking-at "</") |
290 |
"XML: invalid syntax -- invalid end tag (expecting " |
(error "XML: Invalid end tag (expecting %s) at pos %d" |
291 |
node-name |
node-name (point))) |
292 |
") at pos " (number-to-string (point))))) |
((= (char-after) ?<) |
293 |
((= (char-after) ?<) |
(let ((tag (xml-parse-tag))) |
294 |
(let ((tag (xml-parse-tag end))) |
(when tag |
295 |
(when tag |
(push tag children)))) |
296 |
(push tag children)))) |
(t |
297 |
(t |
(setq pos (point)) |
298 |
(setq pos (point)) |
(search-forward "<") |
299 |
(search-forward "<" end) |
(forward-char -1) |
300 |
(forward-char -1) |
(let ((string (buffer-substring pos (point))) |
301 |
(let ((string (buffer-substring-no-properties pos (point))) |
(pos 0)) |
302 |
(pos 0)) |
|
303 |
|
;; Clean up the string. As per XML |
304 |
|
;; specifications, the XML processor should |
305 |
|
;; always pass the whole string to the |
306 |
|
;; application. But \r's should be replaced: |
307 |
|
;; http://www.w3.org/TR/2000/REC-xml-20001006#sec-line-ends |
308 |
|
(while (string-match "\r\n?" string pos) |
309 |
|
(setq string (replace-match "\n" t t string)) |
310 |
|
(setq pos (1+ (match-beginning 0)))) |
311 |
|
|
312 |
|
(setq string (xml-substitute-special string)) |
313 |
|
(setq children |
314 |
|
(if (stringp (car children)) |
315 |
|
;; The two strings were separated by a comment. |
316 |
|
(cons (concat (car children) string) |
317 |
|
(cdr children)) |
318 |
|
(cons string children)))))))) |
319 |
|
|
|
;; Clean up the string. As per XML |
|
|
;; specifications, the XML processor should |
|
|
;; always pass the whole string to the |
|
|
;; application. But \r's should be replaced: |
|
|
;; http://www.w3.org/TR/2000/REC-xml-20001006#sec-line-ends |
|
|
(while (string-match "\r\n?" string pos) |
|
|
(setq string (replace-match "\n" t t string)) |
|
|
(setq pos (1+ (match-beginning 0)))) |
|
|
|
|
|
(setq string (xml-substitute-special string)) |
|
|
(setq children |
|
|
(if (stringp (car children)) |
|
|
;; The two strings were separated by a comment. |
|
|
(cons (concat (car children) string) |
|
|
(cdr children)) |
|
|
(cons string children))))))) |
|
320 |
(goto-char (match-end 0)) |
(goto-char (match-end 0)) |
|
(if (> (point) end) |
|
|
(error "XML: End tag for %s not found before end of region" |
|
|
node-name)) |
|
321 |
(nreverse children)) |
(nreverse children)) |
|
|
|
322 |
;; This was an invalid start tag |
;; This was an invalid start tag |
323 |
(error "XML: Invalid attribute list") |
(error "XML: Invalid attribute list"))))) |
|
)))) |
|
324 |
(t ;; This is not a tag. |
(t ;; This is not a tag. |
325 |
(error "XML: Invalid character")) |
(error "XML: Invalid character")))) |
|
)) |
|
326 |
|
|
327 |
(defun xml-parse-attlist (end) |
(defun xml-parse-attlist () |
328 |
"Return the attribute-list that point is looking at. |
"Return the attribute-list after point. |
329 |
The search for attributes end at the position END in the current buffer. |
Leave point at the first non-blank character after the tag." |
|
Leaves the point on the first non-blank character after the tag." |
|
330 |
(let ((attlist ()) |
(let ((attlist ()) |
331 |
start-pos name) |
start-pos name) |
332 |
(goto-char (- (re-search-forward "[^ \t\n\r]") 1)) |
(skip-syntax-forward " ") |
333 |
(while (looking-at "\\([a-zA-Z_:][-a-zA-Z0-9._:]*\\)[ \t\n\r]*=[ \t\n\r]*") |
(while (looking-at (eval-when-compile |
334 |
|
(concat "\\(" xml-name-regexp "\\)\\s-*=\\s-*"))) |
335 |
(setq name (intern (match-string 1))) |
(setq name (intern (match-string 1))) |
336 |
(goto-char (match-end 0)) |
(goto-char (match-end 0)) |
337 |
|
|
351 |
|
|
352 |
;; Multiple whitespace characters should be replaced with a single one |
;; Multiple whitespace characters should be replaced with a single one |
353 |
;; in the attributes |
;; in the attributes |
354 |
(let ((string (match-string-no-properties 1)) |
(let ((string (match-string 1)) |
355 |
(pos 0)) |
(pos 0)) |
356 |
(while (string-match "[ \t\n\r]+" string pos) |
(replace-regexp-in-string "\\s-\\{2,\\}" " " string) |
|
(setq string (replace-match " " t nil string)) |
|
|
(setq pos (1+ (match-beginning 0)))) |
|
357 |
(push (cons name (xml-substitute-special string)) attlist)) |
(push (cons name (xml-substitute-special string)) attlist)) |
358 |
|
|
359 |
(goto-char start-pos) |
(goto-char start-pos) |
360 |
(if (looking-at "\"\\([^\"]*\\)\"") |
(forward-sexp) ; we have string syntax |
|
(goto-char (match-end 0)) |
|
|
(if (looking-at "'\\([^']*\\)'") |
|
|
(goto-char (match-end 0)))) |
|
361 |
|
|
362 |
(goto-char (- (re-search-forward "[^ \t\n\r]") 1)) |
(skip-syntax-forward " ")) |
|
(if (> (point) end) |
|
|
(error "XML: end of attribute list not found before end of region"))) |
|
363 |
(nreverse attlist))) |
(nreverse attlist))) |
364 |
|
|
365 |
;;******************************************************************* |
;;******************************************************************* |
370 |
;;** |
;;** |
371 |
;;******************************************************************* |
;;******************************************************************* |
372 |
|
|
373 |
(defun xml-skip-dtd (end) |
;; Fixme: This fails at least if the DTD contains conditional sections. |
374 |
"Skip the DTD that point is looking at. |
|
375 |
The DTD must end before the position END in the current buffer. |
(defun xml-skip-dtd () |
376 |
The point must be just before the starting tag of the DTD. |
"Skip the DTD at point. |
377 |
This follows the rule [28] in the XML specifications." |
This follows the rule [28] in the XML specifications." |
378 |
(forward-char (length "<!DOCTYPE")) |
(forward-char (length "<!DOCTYPE")) |
379 |
(if (looking-at "[ \t\n\r]*>") |
(if (looking-at "\\s-*>") |
380 |
(error "XML: invalid DTD (excepting name of the document)")) |
(error "XML: invalid DTD (excepting name of the document)")) |
381 |
(condition-case nil |
(condition-case nil |
382 |
(progn |
(progn |
383 |
(forward-word 1) |
(forward-sexp) |
384 |
(goto-char (- (re-search-forward "[ \t\n\r]") 1)) |
(skip-syntax-forward " ") |
|
(goto-char (- (re-search-forward "[^ \t\n\r]") 1)) |
|
385 |
(if (looking-at "\\[") |
(if (looking-at "\\[") |
386 |
(re-search-forward "\\][ \t\n\r]*>" end) |
(re-search-forward "]\\s-*>") |
387 |
(search-forward ">" end))) |
(search-forward ">"))) |
388 |
(error (error "XML: No end to the DTD")))) |
(error (error "XML: No end to the DTD")))) |
389 |
|
|
390 |
(defun xml-parse-dtd (end) |
(defun xml-parse-dtd () |
391 |
"Parse the DTD that point is looking at. |
"Parse the DTD at point." |
392 |
The DTD must end before the position END in the current buffer." |
(forward-char (eval-when-compile (length "<!DOCTYPE"))) |
393 |
(forward-char (length "<!DOCTYPE")) |
(skip-syntax-forward " ") |
|
(goto-char (- (re-search-forward "[^ \t\n\r]") 1)) |
|
394 |
(if (looking-at ">") |
(if (looking-at ">") |
395 |
(error "XML: invalid DTD (excepting name of the document)")) |
(error "XML: invalid DTD (excepting name of the document)")) |
396 |
|
|
397 |
;; Get the name of the document |
;; Get the name of the document |
398 |
(looking-at "\\sw+") |
(looking-at xml-name-regexp) |
399 |
(let ((dtd (list (match-string-no-properties 0) 'dtd)) |
(let ((dtd (list (match-string 0) 'dtd)) |
400 |
type element end-pos) |
type element end-pos) |
401 |
(goto-char (match-end 0)) |
(goto-char (match-end 0)) |
402 |
|
|
403 |
(goto-char (- (re-search-forward "[^ \t\n\r]") 1)) |
(skip-syntax-forward " ") |
404 |
|
;; XML [75] |
405 |
;; External DTDs => don't know how to handle them yet |
(cond ((looking-at "PUBLIC\\s-+") |
406 |
(if (looking-at "SYSTEM") |
(goto-char (match-end 0)) |
407 |
(error "XML: Don't know how to handle external DTDs")) |
(unless (or (re-search-forward |
408 |
|
"\\=\"\\([[:space:][:alnum:]-'()+,./:=?;!*#@$_%]*\\)\"" |
409 |
(if (not (= (char-after) ?\[)) |
nil t) |
410 |
(error "XML: Unknown declaration in the DTD")) |
(re-search-forward |
411 |
|
"\\='\\([[:space:][:alnum:]-()+,./:=?;!*#@$_%]*\\)'" |
412 |
;; Parse the rest of the DTD |
nil t)) |
413 |
(forward-char 1) |
(error "XML: missing public id")) |
414 |
(while (and (not (looking-at "[ \t\n\r]*\\]")) |
(let ((pubid (match-string 1))) |
415 |
(<= (point) end)) |
(unless (or (re-search-forward "\\='\\([^']*\\)'" nil t) |
416 |
(cond |
(re-search-forward "\\=\"\\([^\"]*\\)\"" nil t)) |
417 |
|
(error "XML: missing system id")) |
418 |
;; Translation of rule [45] of XML specifications |
(push (list pubid (match-string 1) 'public) dtd))) |
419 |
((looking-at |
((looking-at "SYSTEM\\s-+") |
420 |
"[ \t\n\r]*<!ELEMENT[ \t\n\r]+\\([a-zA-Z0-9.%;]+\\)[ \t\n\r]+\\([^>]+\\)>") |
(goto-char (match-end 0)) |
421 |
|
(unless (or (re-search-forward "\\='\\([^']*\\)'" nil t) |
422 |
(setq element (intern (match-string-no-properties 1)) |
(re-search-forward "\\=\"\\([^\"]*\\)\"" nil t)) |
423 |
type (match-string-no-properties 2)) |
(error "XML: missing system id")) |
424 |
(setq end-pos (match-end 0)) |
(push (list (match-string 1) 'system) dtd))) |
425 |
|
(skip-syntax-forward " ") |
426 |
;; Translation of rule [46] of XML specifications |
(if (eq ?> (char-after)) |
427 |
(cond |
(forward-char) |
428 |
((string-match "^EMPTY[ \t\n\r]*$" type) ;; empty declaration |
(skip-syntax-forward " ") |
429 |
(setq type 'empty)) |
(if (not (eq (char-after) ?\[)) |
430 |
((string-match "^ANY[ \t\n\r]*$" type) ;; any type of contents |
(error "XML: bad DTD") |
431 |
(setq type 'any)) |
(forward-char) |
432 |
((string-match "^(\\(.*\\))[ \t\n\r]*$" type) ;; children ([47]) |
;; Parse the rest of the DTD |
433 |
(setq type (xml-parse-elem-type (match-string-no-properties 1 type)))) |
;; Fixme: Deal with ENTITY, ATTLIST, NOTATION, PIs. |
434 |
((string-match "^%[^;]+;[ \t\n\r]*$" type) ;; substitution |
(while (not (looking-at "\\s-*\\]")) |
435 |
nil) |
(skip-syntax-forward " ") |
436 |
(t |
(cond |
437 |
(error "XML: Invalid element type in the DTD"))) |
|
438 |
|
;; Translation of rule [45] of XML specifications |
439 |
;; rule [45]: the element declaration must be unique |
((looking-at |
440 |
(if (assoc element dtd) |
"<!ELEMENT\\s-+\\([[:alnum:].%;]+\\)\\s-+\\([^>]+\\)>") |
441 |
(error "XML: elements declaration must be unique in a DTD (<%s>)" |
|
442 |
(symbol-name element))) |
(setq element (intern (match-string 1)) |
443 |
|
type (match-string-no-properties 2)) |
444 |
;; Store the element in the DTD |
(setq end-pos (match-end 0)) |
445 |
(push (list element type) dtd) |
|
446 |
(goto-char end-pos)) |
;; Translation of rule [46] of XML specifications |
447 |
|
(cond |
448 |
|
((string-match "^EMPTY[ \t\n\r]*$" type) ;; empty declaration |
449 |
|
(setq type 'empty)) |
450 |
|
((string-match "^ANY[ \t\n\r]*$" type) ;; any type of contents |
451 |
|
(setq type 'any)) |
452 |
|
((string-match "^(\\(.*\\))[ \t\n\r]*$" type) ;; children ([47]) |
453 |
|
(setq type (xml-parse-elem-type (match-string 1 type)))) |
454 |
|
((string-match "^%[^;]+;[ \t\n\r]*$" type) ;; substitution |
455 |
|
nil) |
456 |
|
(t |
457 |
|
(error "XML: Invalid element type in the DTD"))) |
458 |
|
|
459 |
|
;; rule [45]: the element declaration must be unique |
460 |
|
(if (assoc element dtd) |
461 |
|
(error "XML: element declarations must be unique in a DTD (<%s>)" |
462 |
|
(symbol-name element))) |
463 |
|
|
464 |
|
;; Store the element in the DTD |
465 |
|
(push (list element type) dtd) |
466 |
|
(goto-char end-pos)) |
467 |
|
((looking-at "<!--") |
468 |
|
(search-forward "-->")) |
469 |
|
|
470 |
|
(t |
471 |
|
(error "XML: Invalid DTD item"))) |
472 |
|
|
473 |
(t |
;; Skip the end of the DTD |
474 |
(error "XML: Invalid DTD item")) |
(search-forward ">")))) |
|
) |
|
|
) |
|
|
|
|
|
;; Skip the end of the DTD |
|
|
(search-forward ">" end) |
|
475 |
(nreverse dtd))) |
(nreverse dtd))) |
476 |
|
|
477 |
|
|
478 |
(defun xml-parse-elem-type (string) |
(defun xml-parse-elem-type (string) |
479 |
"Convert a STRING for an element type into an elisp structure." |
"Convert element type STRING into a Lisp structure." |
480 |
|
|
481 |
(let (elem modifier) |
(let (elem modifier) |
482 |
(if (string-match "(\\([^)]+\\))\\([+*?]?\\)" string) |
(if (string-match "(\\([^)]+\\))\\([+*?]?\\)" string) |
490 |
(if (string-match "," elem) |
(if (string-match "," elem) |
491 |
(setq elem (cons 'seq |
(setq elem (cons 'seq |
492 |
(mapcar 'xml-parse-elem-type |
(mapcar 'xml-parse-elem-type |
493 |
(split-string elem ",")))) |
(split-string elem ","))))))) |
|
))) |
|
494 |
(if (string-match "[ \t\n\r]*\\([^+*?]+\\)\\([+*?]?\\)" string) |
(if (string-match "[ \t\n\r]*\\([^+*?]+\\)\\([+*?]?\\)" string) |
495 |
(setq elem (match-string 1 string) |
(setq elem (match-string 1 string) |
496 |
modifier (match-string 2 string)))) |
modifier (match-string 2 string)))) |
510 |
|
|
511 |
;;******************************************************************* |
;;******************************************************************* |
512 |
;;** |
;;** |
513 |
;;** Converting code points to strings |
;;** Substituting special XML sequences |
514 |
;;** |
;;** |
515 |
;;******************************************************************* |
;;******************************************************************* |
516 |
|
|
517 |
(defun xml-ucs-to-string (codepoint) |
(eval-when-compile |
518 |
"Return a string representation of CODEPOINT. If it can't be |
(defvar str)) ; dynamic from replace-regexp-in-string |
|
converted, return '?'." |
|
|
(cond ((boundp 'decode-char) |
|
|
(char-to-string (decode-char 'ucs codepoint))) |
|
|
((and (< codepoint 128) |
|
|
(> codepoint 31)) |
|
|
(char-to-string codepoint)) |
|
|
(t "?"))) ; FIXME: There's gotta be a better way to |
|
|
; designate an unknown character. |
|
519 |
|
|
520 |
;;******************************************************************* |
;; Fixme: Take declared entities from the DTD when they're available. |
521 |
;;** |
(defun xml-substitute-entity (match) |
522 |
;;** Substituting special XML sequences |
"Subroutine of xml-substitute-special." |
523 |
;;** |
(save-match-data |
524 |
;;******************************************************************* |
(let ((match1 (match-string 1 str))) |
525 |
|
(cond ((string= match1 "lt") "<") |
526 |
|
((string= match1 "gt") ">") |
527 |
|
((string= match1 "apos") "'") |
528 |
|
((string= match1 "quot") "\"") |
529 |
|
((string= match1 "amp") "&") |
530 |
|
((and (string-match "#\\([0-9]+\\)" match1) |
531 |
|
(let ((c (decode-char |
532 |
|
'ucs |
533 |
|
(string-to-number (match-string 1 match1))))) |
534 |
|
(if c (string c))))) ; else unrepresentable |
535 |
|
((and (string-match "#x\\([[:xdigit:]]+\\)" match1) |
536 |
|
(let ((c (decode-char |
537 |
|
'ucs |
538 |
|
(string-to-number (match-string 1 match1) 16)))) |
539 |
|
(if c (string c))))) |
540 |
|
;; Default to asis. Arguably, unrepresentable code points |
541 |
|
;; might be best replaced with U+FFFD. |
542 |
|
(t match))))) |
543 |
|
|
544 |
(defun xml-substitute-special (string) |
(defun xml-substitute-special (string) |
545 |
"Return STRING, after subsituting special XML sequences." |
"Return STRING, after subsituting entity references." |
546 |
(while (string-match "<" string) |
;; This originally made repeated passes through the string from the |
547 |
(setq string (replace-match "<" t nil string))) |
;; beginning, which isn't correct, since then either "&amp;" or |
548 |
(while (string-match ">" string) |
;; "&amp;" won't DTRT. |
549 |
(setq string (replace-match ">" t nil string))) |
(replace-regexp-in-string "&\\([^;]+\\);" |
550 |
(while (string-match "'" string) |
#'xml-substitute-entity string t t)) |
|
(setq string (replace-match "'" t nil string))) |
|
|
(while (string-match """ string) |
|
|
(setq string (replace-match "\"" t nil string))) |
|
|
(while (string-match "&#\\([0-9]+\\);" string) |
|
|
(setq string (replace-match (xml-ucs-to-string |
|
|
(string-to-number |
|
|
(match-string-no-properties 1 string))) |
|
|
t nil string))) |
|
|
(while (string-match "&#x\\([0-9a-fA-F]+\\);" string) |
|
|
(setq string (replace-match (xml-ucs-to-string |
|
|
(string-to-number |
|
|
(match-string-no-properties 1 string) |
|
|
16)) |
|
|
t nil string))) |
|
|
|
|
|
;; This goes last so it doesn't confuse the matches above. |
|
|
(while (string-match "&" string) |
|
|
(setq string (replace-match "&" t nil string))) |
|
|
string) |
|
551 |
|
|
552 |
;;******************************************************************* |
;;******************************************************************* |
553 |
;;** |
;;** |
562 |
|
|
563 |
(defun xml-debug-print-internal (xml indent-string) |
(defun xml-debug-print-internal (xml indent-string) |
564 |
"Outputs the XML tree in the current buffer. |
"Outputs the XML tree in the current buffer. |
565 |
The first line indented with INDENT-STRING." |
The first line is indented with INDENT-STRING." |
566 |
(let ((tree xml) |
(let ((tree xml) |
567 |
attlist) |
attlist) |
568 |
(insert indent-string "<" (symbol-name (xml-node-name tree))) |
(insert indent-string ?< (symbol-name (xml-node-name tree))) |
569 |
|
|
570 |
;; output the attribute list |
;; output the attribute list |
571 |
(setq attlist (xml-node-attributes tree)) |
(setq attlist (xml-node-attributes tree)) |
572 |
(while attlist |
(while attlist |
573 |
(insert " ") |
(insert ?\ (symbol-name (caar attlist)) "=\"" (cdar attlist) ?\") |
|
(insert (symbol-name (caar attlist)) "=\"" (cdar attlist) "\"") |
|
574 |
(setq attlist (cdr attlist))) |
(setq attlist (cdr attlist))) |
575 |
|
|
576 |
(insert ">") |
(insert ?>) |
577 |
|
|
578 |
(setq tree (xml-node-children tree)) |
(setq tree (xml-node-children tree)) |
579 |
|
|
581 |
(dolist (node tree) |
(dolist (node tree) |
582 |
(cond |
(cond |
583 |
((listp node) |
((listp node) |
584 |
(insert "\n") |
(insert ?\n) |
585 |
(xml-debug-print-internal node (concat indent-string " "))) |
(xml-debug-print-internal node (concat indent-string " "))) |
586 |
((stringp node) (insert node)) |
((stringp node) (insert node)) |
587 |
(t |
(t |
588 |
(error "Invalid XML tree")))) |
(error "Invalid XML tree")))) |
589 |
|
|
590 |
(insert "\n" indent-string |
(insert ?\n indent-string |
591 |
"</" (symbol-name (xml-node-name xml)) ">"))) |
?< ?/ (symbol-name (xml-node-name xml)) ?>))) |
592 |
|
|
593 |
(provide 'xml) |
(provide 'xml) |
594 |
|
|