125 |
(set-buffer (get-file-buffer file)) |
(set-buffer (get-file-buffer file)) |
126 |
(setq keep (point))) |
(setq keep (point))) |
127 |
(find-file file)) |
(find-file file)) |
128 |
|
|
129 |
(let ((xml (xml-parse-region (point-min) |
(let ((xml (xml-parse-region (point-min) |
130 |
(point-max) |
(point-max) |
131 |
(current-buffer) |
(current-buffer) |
184 |
;; beginning of a document) |
;; beginning of a document) |
185 |
((looking-at "<\\?") |
((looking-at "<\\?") |
186 |
(search-forward "?>" end) |
(search-forward "?>" end) |
187 |
(skip-chars-forward " \t\n") |
(goto-char (- (re-search-forward "[^ \t\n\r]") 1)) |
188 |
(xml-parse-tag end)) |
(xml-parse-tag end)) |
189 |
;; Character data (CDATA) sections, in which no tag should be interpreted |
;; Character data (CDATA) sections, in which no tag should be interpreted |
190 |
((looking-at "<!\\[CDATA\\[") |
((looking-at "<!\\[CDATA\\[") |
198 |
(if parse-dtd |
(if parse-dtd |
199 |
(setq dtd (xml-parse-dtd end)) |
(setq dtd (xml-parse-dtd end)) |
200 |
(xml-skip-dtd end)) |
(xml-skip-dtd end)) |
201 |
(skip-chars-forward " \t\n") |
(goto-char (- (re-search-forward "[^ \t\n\r]") 1)) |
202 |
(if dtd |
(if dtd |
203 |
(cons dtd (xml-parse-tag end)) |
(cons dtd (xml-parse-tag end)) |
204 |
(xml-parse-tag end)))) |
(xml-parse-tag end)))) |
210 |
((looking-at "</") |
((looking-at "</") |
211 |
'()) |
'()) |
212 |
;; opening tag |
;; opening tag |
213 |
((looking-at "<\\([^/> \t\n]+\\)") |
((looking-at "<\\([^/> \t\n\r]+\\)") |
214 |
(goto-char (match-end 1)) |
(goto-char (match-end 1)) |
215 |
(let* ((case-fold-search nil) ;; XML is case-sensitive. |
(let* ((case-fold-search nil) ;; XML is case-sensitive. |
216 |
(node-name (match-string 1)) |
(node-name (match-string 1)) |
219 |
pos) |
pos) |
220 |
|
|
221 |
;; is this an empty element ? |
;; is this an empty element ? |
222 |
(if (looking-at "/>") |
(if (looking-at "/[ \t\n\r]*>") |
223 |
(progn |
(progn |
224 |
(forward-char 2) |
(forward-char 2) |
225 |
(nreverse (cons '("") children))) |
(nreverse (cons '("") children))) |
230 |
(forward-char 1) |
(forward-char 1) |
231 |
;; Now check that we have the right end-tag. Note that this |
;; Now check that we have the right end-tag. Note that this |
232 |
;; one might contain spaces after the tag name |
;; one might contain spaces after the tag name |
233 |
(while (not (looking-at (concat "</" node-name "[ \t\n]*>"))) |
(while (not (looking-at (concat "</" node-name "[ \t\n\r]*>"))) |
234 |
(cond |
(cond |
235 |
((looking-at "</") |
((looking-at "</") |
236 |
(error (concat |
(error (concat |
247 |
(forward-char -1) |
(forward-char -1) |
248 |
(let ((string (buffer-substring-no-properties pos (point))) |
(let ((string (buffer-substring-no-properties pos (point))) |
249 |
(pos 0)) |
(pos 0)) |
250 |
|
|
251 |
;; Clean up the string (no newline characters) |
;; Clean up the string. As per XML |
252 |
;; Not done, since as per XML specifications, the XML processor |
;; specifications, the XML processor should |
253 |
;; should always pass the whole string to the application. |
;; always pass the whole string to the |
254 |
;; (while (string-match "\\s +" string pos) |
;; application. But \r's should be replaced: |
255 |
;; (setq string (replace-match " " t t string)) |
;; http://www.w3.org/TR/2000/REC-xml-20001006#sec-line-ends |
256 |
;; (setq pos (1+ (match-beginning 0)))) |
(while (string-match "\r\n?" string pos) |
257 |
|
(setq string (replace-match "\n" t t string)) |
258 |
|
(setq pos (1+ (match-beginning 0)))) |
259 |
|
|
260 |
(setq string (xml-substitute-special string)) |
(setq string (xml-substitute-special string)) |
261 |
(setq children |
(setq children |
282 |
The search for attributes end at the position END in the current buffer. |
The search for attributes end at the position END in the current buffer. |
283 |
Leaves the point on the first non-blank character after the tag." |
Leaves the point on the first non-blank character after the tag." |
284 |
(let ((attlist ()) |
(let ((attlist ()) |
285 |
name) |
start-pos name) |
286 |
(skip-chars-forward " \t\n") |
(goto-char (- (re-search-forward "[^ \t\n\r]") 1)) |
287 |
(while (looking-at "\\([a-zA-Z_:][-a-zA-Z0-9._:]*\\)[ \t\n]*=[ \t\n]*") |
(while (looking-at "\\([a-zA-Z_:][-a-zA-Z0-9._:]*\\)[ \t\n\r]*=[ \t\n\r]*") |
288 |
(setq name (intern (match-string 1))) |
(setq name (intern (match-string 1))) |
289 |
(goto-char (match-end 0)) |
(goto-char (match-end 0)) |
290 |
|
|
291 |
|
;; See also: http://www.w3.org/TR/2000/REC-xml-20001006#AVNormalize |
292 |
|
|
293 |
;; Do we have a string between quotes (or double-quotes), |
;; Do we have a string between quotes (or double-quotes), |
294 |
;; or a simple word ? |
;; or a simple word ? |
295 |
(unless (looking-at "\"\\([^\"]*\\)\"") |
(if (looking-at "\"\\([^\"]*\\)\"") |
296 |
(unless (looking-at "'\\([^']*\\)'") |
(setq start-pos (match-beginning 0)) |
297 |
|
(if (looking-at "'\\([^']*\\)'") |
298 |
|
(setq start-pos (match-beginning 0)) |
299 |
(error "XML: Attribute values must be given between quotes"))) |
(error "XML: Attribute values must be given between quotes"))) |
300 |
|
|
301 |
;; Each attribute must be unique within a given element |
;; Each attribute must be unique within a given element |
302 |
(if (assoc name attlist) |
(if (assoc name attlist) |
303 |
(error "XML: each attribute must be unique within an element")) |
(error "XML: each attribute must be unique within an element")) |
304 |
|
|
305 |
(push (cons name (match-string-no-properties 1)) attlist) |
;; Multiple whitespace characters should be replaced with a single one |
306 |
(goto-char (match-end 0)) |
;; in the attributes |
307 |
(skip-chars-forward " \t\n") |
(let ((string (match-string-no-properties 1)) |
308 |
|
(pos 0)) |
309 |
|
(while (string-match "[ \t\n\r]+" string pos) |
310 |
|
(setq string (replace-match " " t nil string)) |
311 |
|
(setq pos (1+ (match-beginning 0)))) |
312 |
|
(push (cons name (xml-substitute-special string)) attlist)) |
313 |
|
|
314 |
|
(goto-char start-pos) |
315 |
|
(if (looking-at "\"\\([^\"]*\\)\"") |
316 |
|
(goto-char (match-end 0)) |
317 |
|
(if (looking-at "'\\([^']*\\)'") |
318 |
|
(goto-char (match-end 0)))) |
319 |
|
|
320 |
|
(goto-char (- (re-search-forward "[^ \t\n\r]") 1)) |
321 |
(if (> (point) end) |
(if (> (point) end) |
322 |
(error "XML: end of attribute list not found before end of region")) |
(error "XML: end of attribute list not found before end of region"))) |
|
) |
|
323 |
(nreverse attlist))) |
(nreverse attlist))) |
324 |
|
|
325 |
;;******************************************************************* |
;;******************************************************************* |
336 |
The point must be just before the starting tag of the DTD. |
The point must be just before the starting tag of the DTD. |
337 |
This follows the rule [28] in the XML specifications." |
This follows the rule [28] in the XML specifications." |
338 |
(forward-char (length "<!DOCTYPE")) |
(forward-char (length "<!DOCTYPE")) |
339 |
(if (looking-at "[ \t\n]*>") |
(if (looking-at "[ \t\n\r]*>") |
340 |
(error "XML: invalid DTD (excepting name of the document)")) |
(error "XML: invalid DTD (excepting name of the document)")) |
341 |
(condition-case nil |
(condition-case nil |
342 |
(progn |
(progn |
343 |
(forward-word 1) ;; name of the document |
(forward-word 1) |
344 |
(skip-chars-forward " \t\n") |
(goto-char (- (re-search-forward "[ \t\n\r]") 1)) |
345 |
|
(goto-char (- (re-search-forward "[^ \t\n\r]") 1)) |
346 |
(if (looking-at "\\[") |
(if (looking-at "\\[") |
347 |
(re-search-forward "\\][ \t\n]*>" end) |
(re-search-forward "\\][ \t\n\r]*>" end) |
348 |
(search-forward ">" end))) |
(search-forward ">" end))) |
349 |
(error (error "XML: No end to the DTD")))) |
(error (error "XML: No end to the DTD")))) |
350 |
|
|
352 |
"Parse the DTD that point is looking at. |
"Parse the DTD that point is looking at. |
353 |
The DTD must end before the position END in the current buffer." |
The DTD must end before the position END in the current buffer." |
354 |
(forward-char (length "<!DOCTYPE")) |
(forward-char (length "<!DOCTYPE")) |
355 |
(skip-chars-forward " \t\n") |
(goto-char (- (re-search-forward "[^ \t\n\r]") 1)) |
356 |
(if (looking-at ">") |
(if (looking-at ">") |
357 |
(error "XML: invalid DTD (excepting name of the document)")) |
(error "XML: invalid DTD (excepting name of the document)")) |
358 |
|
|
359 |
;; Get the name of the document |
;; Get the name of the document |
360 |
(looking-at "\\sw+") |
(looking-at "\\sw+") |
361 |
(let ((dtd (list (match-string-no-properties 0) 'dtd)) |
(let ((dtd (list (match-string-no-properties 0) 'dtd)) |
362 |
type element end-pos) |
type element end-pos) |
363 |
(goto-char (match-end 0)) |
(goto-char (match-end 0)) |
364 |
|
|
365 |
(skip-chars-forward " \t\n") |
(goto-char (- (re-search-forward "[^ \t\n\r]") 1)) |
366 |
|
|
367 |
;; External DTDs => don't know how to handle them yet |
;; External DTDs => don't know how to handle them yet |
368 |
(if (looking-at "SYSTEM") |
(if (looking-at "SYSTEM") |
369 |
(error "XML: Don't know how to handle external DTDs")) |
(error "XML: Don't know how to handle external DTDs")) |
370 |
|
|
371 |
(if (not (= (char-after) ?\[)) |
(if (not (= (char-after) ?\[)) |
372 |
(error "XML: Unknown declaration in the DTD")) |
(error "XML: Unknown declaration in the DTD")) |
373 |
|
|
374 |
;; Parse the rest of the DTD |
;; Parse the rest of the DTD |
375 |
(forward-char 1) |
(forward-char 1) |
376 |
(while (and (not (looking-at "[ \t\n]*\\]")) |
(while (and (not (looking-at "[ \t\n\r]*\\]")) |
377 |
(<= (point) end)) |
(<= (point) end)) |
378 |
(cond |
(cond |
379 |
|
|
380 |
;; Translation of rule [45] of XML specifications |
;; Translation of rule [45] of XML specifications |
381 |
((looking-at |
((looking-at |
382 |
"[\t \n]*<!ELEMENT[ \t\n]+\\([a-zA-Z0-9.%;]+\\)[ \t\n]+\\([^>]+\\)>") |
"[ \t\n\r]*<!ELEMENT[ \t\n\r]+\\([a-zA-Z0-9.%;]+\\)[ \t\n\r]+\\([^>]+\\)>") |
383 |
|
|
384 |
(setq element (intern (match-string-no-properties 1)) |
(setq element (intern (match-string-no-properties 1)) |
385 |
type (match-string-no-properties 2)) |
type (match-string-no-properties 2)) |
386 |
(setq end-pos (match-end 0)) |
(setq end-pos (match-end 0)) |
387 |
|
|
388 |
;; Translation of rule [46] of XML specifications |
;; Translation of rule [46] of XML specifications |
389 |
(cond |
(cond |
390 |
((string-match "^EMPTY[ \t\n]*$" type) ;; empty declaration |
((string-match "^EMPTY[ \t\n\r]*$" type) ;; empty declaration |
391 |
(setq type 'empty)) |
(setq type 'empty)) |
392 |
((string-match "^ANY[ \t\n]*$" type) ;; any type of contents |
((string-match "^ANY[ \t\n\r]*$" type) ;; any type of contents |
393 |
(setq type 'any)) |
(setq type 'any)) |
394 |
((string-match "^(\\(.*\\))[ \t\n]*$" type) ;; children ([47]) |
((string-match "^(\\(.*\\))[ \t\n\r]*$" type) ;; children ([47]) |
395 |
(setq type (xml-parse-elem-type (match-string-no-properties 1 type)))) |
(setq type (xml-parse-elem-type (match-string-no-properties 1 type)))) |
396 |
((string-match "^%[^;]+;[ \t\n]*$" type) ;; substitution |
((string-match "^%[^;]+;[ \t\n\r]*$" type) ;; substitution |
397 |
nil) |
nil) |
398 |
(t |
(t |
399 |
(error "XML: Invalid element type in the DTD"))) |
(error "XML: Invalid element type in the DTD"))) |
402 |
(if (assoc element dtd) |
(if (assoc element dtd) |
403 |
(error "XML: elements declaration must be unique in a DTD (<%s>)" |
(error "XML: elements declaration must be unique in a DTD (<%s>)" |
404 |
(symbol-name element))) |
(symbol-name element))) |
405 |
|
|
406 |
;; Store the element in the DTD |
;; Store the element in the DTD |
407 |
(push (list element type) dtd) |
(push (list element type) dtd) |
408 |
(goto-char end-pos)) |
(goto-char end-pos)) |
435 |
(mapcar 'xml-parse-elem-type |
(mapcar 'xml-parse-elem-type |
436 |
(split-string elem ",")))) |
(split-string elem ",")))) |
437 |
))) |
))) |
438 |
(if (string-match "[ \t\n]*\\([^+*?]+\\)\\([+*?]?\\)" string) |
(if (string-match "[ \t\n\r]*\\([^+*?]+\\)\\([+*?]?\\)" string) |
439 |
(setq elem (match-string 1 string) |
(setq elem (match-string 1 string) |
440 |
modifier (match-string 2 string)))) |
modifier (match-string 2 string)))) |
441 |
|
|
442 |
(if (and (stringp elem) (string= elem "#PCDATA")) |
(if (and (stringp elem) (string= elem "#PCDATA")) |
443 |
(setq elem 'pcdata)) |
(setq elem 'pcdata)) |
444 |
|
|
445 |
(cond |
(cond |
446 |
((string= modifier "+") |
((string= modifier "+") |
447 |
(list '+ elem)) |
(list '+ elem)) |
448 |
((string= modifier "*") |
((string= modifier "*") |
449 |
(list '* elem)) |
(list '* elem)) |
450 |
((string= modifier "?") |
((string= modifier "?") |
451 |
(list '? elem)) |
(list '\? elem)) |
452 |
(t |
(t |
453 |
elem)))) |
elem)))) |
454 |
|
|
455 |
|
;;******************************************************************* |
456 |
|
;;** |
457 |
|
;;** Converting code points to strings |
458 |
|
;;** |
459 |
|
;;******************************************************************* |
460 |
|
|
461 |
|
(defun xml-ucs-to-string (codepoint) |
462 |
|
"Return a string representation of CODEPOINT. If it can't be |
463 |
|
converted, return '?'." |
464 |
|
(cond ((boundp 'decode-char) |
465 |
|
(char-to-string (decode-char 'ucs codepoint))) |
466 |
|
((and (< codepoint 128) |
467 |
|
(> codepoint 31)) |
468 |
|
(char-to-string codepoint)) |
469 |
|
(t "?"))) ; FIXME: There's gotta be a better way to |
470 |
|
; designate an unknown character. |
471 |
|
|
472 |
;;******************************************************************* |
;;******************************************************************* |
473 |
;;** |
;;** |
477 |
|
|
478 |
(defun xml-substitute-special (string) |
(defun xml-substitute-special (string) |
479 |
"Return STRING, after subsituting special XML sequences." |
"Return STRING, after subsituting special XML sequences." |
|
(while (string-match "&" string) |
|
|
(setq string (replace-match "&" t nil string))) |
|
480 |
(while (string-match "<" string) |
(while (string-match "<" string) |
481 |
(setq string (replace-match "<" t nil string))) |
(setq string (replace-match "<" t nil string))) |
482 |
(while (string-match ">" string) |
(while (string-match ">" string) |
485 |
(setq string (replace-match "'" t nil string))) |
(setq string (replace-match "'" t nil string))) |
486 |
(while (string-match """ string) |
(while (string-match """ string) |
487 |
(setq string (replace-match "\"" t nil string))) |
(setq string (replace-match "\"" t nil string))) |
488 |
|
(while (string-match "&#\\([0-9]+\\);" string) |
489 |
|
(setq string (replace-match (xml-ucs-to-string |
490 |
|
(string-to-number |
491 |
|
(match-string-no-properties 1 string))) |
492 |
|
t nil string))) |
493 |
|
(while (string-match "&#x\\([0-9a-fA-F]+\\);" string) |
494 |
|
(setq string (replace-match (xml-ucs-to-string |
495 |
|
(string-to-number |
496 |
|
(match-string-no-properties 1 string) |
497 |
|
16)) |
498 |
|
t nil string))) |
499 |
|
|
500 |
|
;; This goes last so it doesn't confuse the matches above. |
501 |
|
(while (string-match "&" string) |
502 |
|
(setq string (replace-match "&" t nil string))) |
503 |
string) |
string) |
504 |
|
|
505 |
;;******************************************************************* |
;;******************************************************************* |
519 |
(let ((tree xml) |
(let ((tree xml) |
520 |
attlist) |
attlist) |
521 |
(insert indent-string "<" (symbol-name (xml-node-name tree))) |
(insert indent-string "<" (symbol-name (xml-node-name tree))) |
522 |
|
|
523 |
;; output the attribute list |
;; output the attribute list |
524 |
(setq attlist (xml-node-attributes tree)) |
(setq attlist (xml-node-attributes tree)) |
525 |
(while attlist |
(while attlist |
526 |
(insert " ") |
(insert " ") |
527 |
(insert (symbol-name (caar attlist)) "=\"" (cdar attlist) "\"") |
(insert (symbol-name (caar attlist)) "=\"" (cdar attlist) "\"") |
528 |
(setq attlist (cdr attlist))) |
(setq attlist (cdr attlist))) |
529 |
|
|
530 |
(insert ">") |
(insert ">") |
531 |
|
|
532 |
(setq tree (xml-node-children tree)) |
(setq tree (xml-node-children tree)) |
533 |
|
|
534 |
;; output the children |
;; output the children |