73 |
;;** |
;;** |
74 |
;;******************************************************************* |
;;******************************************************************* |
75 |
|
|
76 |
(defmacro xml-node-name (node) |
(defsubst xml-node-name (node) |
77 |
"Return the tag associated with NODE. |
"Return the tag associated with NODE. |
78 |
The tag is a lower-case symbol." |
The tag is a lower-case symbol." |
79 |
(list 'car node)) |
(car node)) |
80 |
|
|
81 |
(defmacro xml-node-attributes (node) |
(defsubst xml-node-attributes (node) |
82 |
"Return the list of attributes of NODE. |
"Return the list of attributes of NODE. |
83 |
The list can be nil." |
The list can be nil." |
84 |
(list 'nth 1 node)) |
(nth 1 node)) |
85 |
|
|
86 |
(defmacro xml-node-children (node) |
(defsubst xml-node-children (node) |
87 |
"Return the list of children of NODE. |
"Return the list of children of NODE. |
88 |
This is a list of nodes, and it can be nil." |
This is a list of nodes, and it can be nil." |
89 |
(list 'cddr node)) |
(cddr node)) |
90 |
|
|
91 |
(defun xml-get-children (node child-name) |
(defun xml-get-children (node child-name) |
92 |
"Return the children of NODE whose tag is CHILD-NAME. |
"Return the children of NODE whose tag is CHILD-NAME. |
93 |
CHILD-NAME should be a lower case symbol." |
CHILD-NAME should be a lower case symbol." |
94 |
(let ((children (xml-node-children node)) |
(let ((match ())) |
95 |
match) |
(dolist (child (xml-node-children node)) |
96 |
(while children |
(if child |
97 |
(if (car children) |
(if (equal (xml-node-name child) child-name) |
98 |
(if (equal (xml-node-name (car children)) child-name) |
(push child match)))) |
99 |
(set 'match (append match (list (car children)))))) |
(nreverse match))) |
|
(set 'children (cdr children))) |
|
|
match)) |
|
100 |
|
|
101 |
(defun xml-get-attribute (node attribute) |
(defun xml-get-attribute (node attribute) |
102 |
"Get from NODE the value of ATTRIBUTE. |
"Get from NODE the value of ATTRIBUTE. |
153 |
(forward-char -1) |
(forward-char -1) |
154 |
(if (null xml) |
(if (null xml) |
155 |
(progn |
(progn |
156 |
(set 'result (xml-parse-tag end parse-dtd)) |
(setq result (xml-parse-tag end parse-dtd)) |
157 |
(cond |
(cond |
158 |
|
((null result)) |
159 |
((listp (car result)) |
((listp (car result)) |
160 |
(set 'dtd (car result)) |
(setq dtd (car result)) |
161 |
(add-to-list 'xml (cdr result))) |
(add-to-list 'xml (cdr result))) |
162 |
(t |
(t |
163 |
(add-to-list 'xml result)))) |
(add-to-list 'xml result)))) |
196 |
((looking-at "<!DOCTYPE") |
((looking-at "<!DOCTYPE") |
197 |
(let (dtd) |
(let (dtd) |
198 |
(if parse-dtd |
(if parse-dtd |
199 |
(set '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") |
(skip-chars-forward " \t\n") |
202 |
(if dtd |
(if dtd |
205 |
;; skip comments |
;; skip comments |
206 |
((looking-at "<!--") |
((looking-at "<!--") |
207 |
(search-forward "-->" end) |
(search-forward "-->" end) |
208 |
(skip-chars-forward " \t\n") |
nil) |
|
(xml-parse-tag end)) |
|
209 |
;; end tag |
;; end tag |
210 |
((looking-at "</") |
((looking-at "</") |
211 |
'()) |
'()) |
212 |
;; opening tag |
;; opening tag |
213 |
((looking-at "<\\([^/> \t\n]+\\)") |
((looking-at "<\\([^/> \t\n]+\\)") |
214 |
(let* ((node-name (match-string 1)) |
(goto-char (match-end 1)) |
215 |
(children (list (intern node-name))) |
(let* ((case-fold-search nil) ;; XML is case-sensitive. |
216 |
(case-fold-search nil) ;; XML is case-sensitive |
(node-name (match-string 1)) |
217 |
|
;; Parse the attribute list. |
218 |
|
(children (list (xml-parse-attlist end) (intern node-name))) |
219 |
pos) |
pos) |
|
(goto-char (match-end 1)) |
|
|
|
|
|
;; parses the attribute list |
|
|
(set 'children (append children (list (xml-parse-attlist end)))) |
|
220 |
|
|
221 |
;; is this an empty element ? |
;; is this an empty element ? |
222 |
(if (looking-at "/>") |
(if (looking-at "/>") |
223 |
(progn |
(progn |
224 |
(forward-char 2) |
(forward-char 2) |
225 |
(skip-chars-forward " \t\n") |
(nreverse (cons '("") children))) |
|
(append children '(""))) |
|
226 |
|
|
227 |
;; is this a valid start tag ? |
;; is this a valid start tag ? |
228 |
(if (eq (char-after) ?>) |
(if (eq (char-after) ?>) |
229 |
(progn |
(progn |
230 |
(forward-char 1) |
(forward-char 1) |
231 |
(skip-chars-forward " \t\n") |
;; Now check that we have the right end-tag. Note that this |
232 |
;; Now check that we have the right end-tag. Note that this one might |
;; one might contain spaces after the tag name |
|
;; 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]*>"))) |
234 |
(cond |
(cond |
235 |
((looking-at "</") |
((looking-at "</") |
238 |
node-name |
node-name |
239 |
") at pos " (number-to-string (point))))) |
") at pos " (number-to-string (point))))) |
240 |
((= (char-after) ?<) |
((= (char-after) ?<) |
241 |
(set 'children (append children (list (xml-parse-tag end))))) |
(let ((tag (xml-parse-tag end))) |
242 |
|
(when tag |
243 |
|
(push tag children)))) |
244 |
(t |
(t |
245 |
(set 'pos (point)) |
(setq pos (point)) |
246 |
(search-forward "<" end) |
(search-forward "<" end) |
247 |
(forward-char -1) |
(forward-char -1) |
248 |
(let ((string (buffer-substring-no-properties pos (point))) |
(let ((string (buffer-substring-no-properties pos (point))) |
252 |
;; Not done, since as per XML specifications, the XML processor |
;; Not done, since as per XML specifications, the XML processor |
253 |
;; should always pass the whole string to the application. |
;; should always pass the whole string to the application. |
254 |
;; (while (string-match "\\s +" string pos) |
;; (while (string-match "\\s +" string pos) |
255 |
;; (set 'string (replace-match " " t t string)) |
;; (setq string (replace-match " " t t string)) |
256 |
;; (set 'pos (1+ (match-beginning 0)))) |
;; (setq pos (1+ (match-beginning 0)))) |
257 |
|
|
258 |
(set 'children (append children |
(setq string (xml-substitute-special string)) |
259 |
(list (xml-substitute-special string)))))))) |
(setq children |
260 |
|
(if (stringp (car children)) |
261 |
|
;; The two strings were separated by a comment. |
262 |
|
(cons (concat (car children) string) |
263 |
|
(cdr children)) |
264 |
|
(cons string children))))))) |
265 |
(goto-char (match-end 0)) |
(goto-char (match-end 0)) |
|
(skip-chars-forward " \t\n") |
|
266 |
(if (> (point) end) |
(if (> (point) end) |
267 |
(error "XML: End tag for %s not found before end of region" |
(error "XML: End tag for %s not found before end of region" |
268 |
node-name)) |
node-name)) |
269 |
children |
(nreverse children)) |
|
) |
|
270 |
|
|
271 |
;; This was an invalid start tag |
;; This was an invalid start tag |
272 |
(error "XML: Invalid attribute list") |
(error "XML: Invalid attribute list") |
279 |
"Return the attribute-list that point is looking at. |
"Return the attribute-list that point is looking at. |
280 |
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. |
281 |
Leaves the point on the first non-blank character after the tag." |
Leaves the point on the first non-blank character after the tag." |
282 |
(let ((attlist '()) |
(let ((attlist ()) |
283 |
name) |
name) |
284 |
(skip-chars-forward " \t\n") |
(skip-chars-forward " \t\n") |
285 |
(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]*=[ \t\n]*") |
286 |
(set 'name (intern (match-string 1))) |
(setq name (intern (match-string 1))) |
287 |
(goto-char (match-end 0)) |
(goto-char (match-end 0)) |
288 |
|
|
289 |
;; Do we have a string between quotes (or double-quotes), |
;; Do we have a string between quotes (or double-quotes), |
296 |
(if (assoc name attlist) |
(if (assoc name attlist) |
297 |
(error "XML: each attribute must be unique within an element")) |
(error "XML: each attribute must be unique within an element")) |
298 |
|
|
299 |
(set 'attlist (append attlist |
(push (cons name (match-string-no-properties 1)) attlist) |
|
(list (cons name (match-string-no-properties 1))))) |
|
300 |
(goto-char (match-end 0)) |
(goto-char (match-end 0)) |
301 |
(skip-chars-forward " \t\n") |
(skip-chars-forward " \t\n") |
302 |
(if (> (point) end) |
(if (> (point) end) |
303 |
(error "XML: end of attribute list not found before end of region")) |
(error "XML: end of attribute list not found before end of region")) |
304 |
) |
) |
305 |
attlist |
(nreverse attlist))) |
|
)) |
|
306 |
|
|
307 |
;;******************************************************************* |
;;******************************************************************* |
308 |
;;** |
;;** |
332 |
(defun xml-parse-dtd (end) |
(defun xml-parse-dtd (end) |
333 |
"Parse the DTD that point is looking at. |
"Parse the DTD that point is looking at. |
334 |
The DTD must end before the position END in the current buffer." |
The DTD must end before the position END in the current buffer." |
335 |
(let (dtd type element end-pos) |
(forward-char (length "<!DOCTYPE")) |
336 |
(forward-char (length "<!DOCTYPE")) |
(skip-chars-forward " \t\n") |
337 |
(skip-chars-forward " \t\n") |
(if (looking-at ">") |
338 |
(if (looking-at ">") |
(error "XML: invalid DTD (excepting name of the document)")) |
339 |
(error "XML: invalid DTD (excepting name of the document)")) |
|
340 |
|
;; Get the name of the document |
341 |
;; Get the name of the document |
(looking-at "\\sw+") |
342 |
(looking-at "\\sw+") |
(let ((dtd (list (match-string-no-properties 0) 'dtd)) |
343 |
(set 'dtd (list 'dtd (match-string-no-properties 0))) |
type element end-pos) |
344 |
(goto-char (match-end 0)) |
(goto-char (match-end 0)) |
345 |
|
|
346 |
(skip-chars-forward " \t\n") |
(skip-chars-forward " \t\n") |
364 |
|
|
365 |
(setq element (intern (match-string-no-properties 1)) |
(setq element (intern (match-string-no-properties 1)) |
366 |
type (match-string-no-properties 2)) |
type (match-string-no-properties 2)) |
367 |
(set 'end-pos (match-end 0)) |
(setq end-pos (match-end 0)) |
368 |
|
|
369 |
;; Translation of rule [46] of XML specifications |
;; Translation of rule [46] of XML specifications |
370 |
(cond |
(cond |
371 |
((string-match "^EMPTY[ \t\n]*$" type) ;; empty declaration |
((string-match "^EMPTY[ \t\n]*$" type) ;; empty declaration |
372 |
(set 'type 'empty)) |
(setq type 'empty)) |
373 |
((string-match "^ANY[ \t\n]*$" type) ;; any type of contents |
((string-match "^ANY[ \t\n]*$" type) ;; any type of contents |
374 |
(set 'type 'any)) |
(setq type 'any)) |
375 |
((string-match "^(\\(.*\\))[ \t\n]*$" type) ;; children ([47]) |
((string-match "^(\\(.*\\))[ \t\n]*$" type) ;; children ([47]) |
376 |
(set 'type (xml-parse-elem-type (match-string-no-properties 1 type)))) |
(setq type (xml-parse-elem-type (match-string-no-properties 1 type)))) |
377 |
((string-match "^%[^;]+;[ \t\n]*$" type) ;; substitution |
((string-match "^%[^;]+;[ \t\n]*$" type) ;; substitution |
378 |
nil) |
nil) |
379 |
(t |
(t |
385 |
(symbol-name element))) |
(symbol-name element))) |
386 |
|
|
387 |
;; Store the element in the DTD |
;; Store the element in the DTD |
388 |
(set 'dtd (append dtd (list (list element type)))) |
(push (list element type) dtd) |
389 |
(goto-char end-pos) |
(goto-char end-pos)) |
|
) |
|
390 |
|
|
391 |
|
|
392 |
(t |
(t |
396 |
|
|
397 |
;; Skip the end of the DTD |
;; Skip the end of the DTD |
398 |
(search-forward ">" end) |
(search-forward ">" end) |
399 |
dtd |
(nreverse dtd))) |
|
)) |
|
400 |
|
|
401 |
|
|
402 |
(defun xml-parse-elem-type (string) |
(defun xml-parse-elem-type (string) |
408 |
(setq elem (match-string 1 string) |
(setq elem (match-string 1 string) |
409 |
modifier (match-string 2 string)) |
modifier (match-string 2 string)) |
410 |
(if (string-match "|" elem) |
(if (string-match "|" elem) |
411 |
(set 'elem (append '(choice) |
(setq elem (cons 'choice |
412 |
(mapcar 'xml-parse-elem-type |
(mapcar 'xml-parse-elem-type |
413 |
(split-string elem "|")))) |
(split-string elem "|")))) |
414 |
(if (string-match "," elem) |
(if (string-match "," elem) |
415 |
(set 'elem (append '(seq) |
(setq elem (cons 'seq |
416 |
(mapcar 'xml-parse-elem-type |
(mapcar 'xml-parse-elem-type |
417 |
(split-string elem ",")))) |
(split-string elem ",")))) |
418 |
))) |
))) |
420 |
(setq elem (match-string 1 string) |
(setq elem (match-string 1 string) |
421 |
modifier (match-string 2 string)))) |
modifier (match-string 2 string)))) |
422 |
|
|
423 |
(if (and (stringp elem) |
(if (and (stringp elem) (string= elem "#PCDATA")) |
424 |
(string= elem "#PCDATA")) |
(setq elem 'pcdata)) |
|
(set 'elem 'pcdata)) |
|
425 |
|
|
426 |
(cond |
(cond |
427 |
((string= modifier "+") |
((string= modifier "+") |
428 |
(list '+ elem)) |
(list '+ elem)) |
429 |
((string= modifier "*") |
((string= modifier "*") |
430 |
(list '* elem)) |
(list '* elem)) |
431 |
((string= modifier "?") |
((string= modifier "?") |
432 |
(list '? elem)) |
(list '? elem)) |
433 |
(t |
(t |
434 |
elem)))) |
elem)))) |
435 |
|
|
436 |
|
|
437 |
;;******************************************************************* |
;;******************************************************************* |
443 |
(defun xml-substitute-special (string) |
(defun xml-substitute-special (string) |
444 |
"Return STRING, after subsituting special XML sequences." |
"Return STRING, after subsituting special XML sequences." |
445 |
(while (string-match "&" string) |
(while (string-match "&" string) |
446 |
(set 'string (replace-match "&" t nil string))) |
(setq string (replace-match "&" t nil string))) |
447 |
(while (string-match "<" string) |
(while (string-match "<" string) |
448 |
(set 'string (replace-match "<" t nil string))) |
(setq string (replace-match "<" t nil string))) |
449 |
(while (string-match ">" string) |
(while (string-match ">" string) |
450 |
(set 'string (replace-match ">" t nil string))) |
(setq string (replace-match ">" t nil string))) |
451 |
(while (string-match "'" string) |
(while (string-match "'" string) |
452 |
(set 'string (replace-match "'" t nil string))) |
(setq string (replace-match "'" t nil string))) |
453 |
(while (string-match """ string) |
(while (string-match """ string) |
454 |
(set 'string (replace-match "\"" t nil string))) |
(setq string (replace-match "\"" t nil string))) |
455 |
string) |
string) |
456 |
|
|
457 |
;;******************************************************************* |
;;******************************************************************* |
462 |
;;******************************************************************* |
;;******************************************************************* |
463 |
|
|
464 |
(defun xml-debug-print (xml) |
(defun xml-debug-print (xml) |
465 |
(while xml |
(dolist (node xml) |
466 |
(xml-debug-print-internal (car xml) "") |
(xml-debug-print-internal node ""))) |
|
(set 'xml (cdr xml))) |
|
|
) |
|
467 |
|
|
468 |
(defun xml-debug-print-internal (xml &optional indent-string) |
(defun xml-debug-print-internal (xml indent-string) |
469 |
"Outputs the XML tree in the current buffer. |
"Outputs the XML tree in the current buffer. |
470 |
The first line indented with INDENT-STRING." |
The first line indented with INDENT-STRING." |
471 |
(let ((tree xml) |
(let ((tree xml) |
472 |
attlist) |
attlist) |
|
(unless indent-string |
|
|
(set 'indent-string "")) |
|
|
|
|
473 |
(insert indent-string "<" (symbol-name (xml-node-name tree))) |
(insert indent-string "<" (symbol-name (xml-node-name tree))) |
474 |
|
|
475 |
;; output the attribute list |
;; output the attribute list |
476 |
(set 'attlist (xml-node-attributes tree)) |
(setq attlist (xml-node-attributes tree)) |
477 |
(while attlist |
(while attlist |
478 |
(insert " ") |
(insert " ") |
479 |
(insert (symbol-name (caar attlist)) "=\"" (cdar attlist) "\"") |
(insert (symbol-name (caar attlist)) "=\"" (cdar attlist) "\"") |
480 |
(set 'attlist (cdr attlist))) |
(setq attlist (cdr attlist))) |
481 |
|
|
482 |
(insert ">") |
(insert ">") |
483 |
|
|
484 |
(set 'tree (xml-node-children tree)) |
(setq tree (xml-node-children tree)) |
485 |
|
|
486 |
;; output the children |
;; output the children |
487 |
(while tree |
(dolist (node tree) |
488 |
(cond |
(cond |
489 |
((listp (car tree)) |
((listp node) |
490 |
(insert "\n") |
(insert "\n") |
491 |
(xml-debug-print-internal (car tree) (concat indent-string " ")) |
(xml-debug-print-internal node (concat indent-string " "))) |
492 |
) |
((stringp node) (insert node)) |
|
((stringp (car tree)) |
|
|
(insert (car tree)) |
|
|
) |
|
493 |
(t |
(t |
494 |
(error "Invalid XML tree"))) |
(error "Invalid XML tree")))) |
|
(set 'tree (cdr tree)) |
|
|
) |
|
495 |
|
|
496 |
(insert "\n" indent-string |
(insert "\n" indent-string |
497 |
"</" (symbol-name (xml-node-name xml)) ">") |
"</" (symbol-name (xml-node-name xml)) ">"))) |
|
)) |
|
498 |
|
|
499 |
(provide 'xml) |
(provide 'xml) |
500 |
|
|