208 |
(if (search-forward "<" nil t) |
(if (search-forward "<" nil t) |
209 |
(progn |
(progn |
210 |
(forward-char -1) |
(forward-char -1) |
211 |
(if xml |
(setq result (xml-parse-tag parse-dtd parse-ns)) |
212 |
|
(if (and xml result) |
213 |
;; translation of rule [1] of XML specifications |
;; translation of rule [1] of XML specifications |
214 |
(error "XML files can have only one toplevel tag") |
(error "XML files can have only one toplevel tag") |
|
(setq result (xml-parse-tag parse-dtd parse-ns)) |
|
215 |
(cond |
(cond |
216 |
((null result)) |
((null result)) |
217 |
((listp (car result)) |
((and (listp (car result)) |
218 |
|
parse-dtd) |
219 |
(setq dtd (car result)) |
(setq dtd (car result)) |
220 |
(if (cdr result) ; possible leading comment |
(if (cdr result) ; possible leading comment |
221 |
(add-to-list 'xml (cdr result)))) |
(add-to-list 'xml (cdr result)))) |
226 |
(cons dtd (nreverse xml)) |
(cons dtd (nreverse xml)) |
227 |
(nreverse xml))))))) |
(nreverse xml))))))) |
228 |
|
|
229 |
|
(defun xml-ns-parse-ns-attrs (attr-list &optional xml-ns) |
230 |
|
"Parse the namespace attributes and return a list of cons in the form: |
231 |
|
\(namespace . prefix)" |
232 |
|
|
233 |
|
(mapcar |
234 |
|
(lambda (attr) |
235 |
|
(let* ((splitup (split-string (car attr) ":")) |
236 |
|
(prefix (nth 0 splitup)) |
237 |
|
(lname (nth 1 splitup))) |
238 |
|
(when (string= "xmlns" prefix) |
239 |
|
(push (cons (if lname |
240 |
|
lname |
241 |
|
"") |
242 |
|
(cdr attr)) |
243 |
|
xml-ns)))) attr-list) |
244 |
|
xml-ns) |
245 |
|
|
246 |
|
;; expand element names |
247 |
|
(defun xml-ns-expand-el (el xml-ns) |
248 |
|
"Expand the XML elements from \"prefix:local-name\" to a cons in the form |
249 |
|
\"(namespace . local-name)\"." |
250 |
|
|
251 |
|
(let* ((splitup (split-string el ":")) |
252 |
|
(lname (or (nth 1 splitup) |
253 |
|
(nth 0 splitup))) |
254 |
|
(prefix (if (nth 1 splitup) |
255 |
|
(nth 0 splitup) |
256 |
|
(if (string= lname "xmlns") |
257 |
|
"xmlns" |
258 |
|
""))) |
259 |
|
(ns (cdr (assoc-string prefix xml-ns)))) |
260 |
|
(if (string= "" ns) |
261 |
|
lname |
262 |
|
(cons (intern (concat ":" ns)) |
263 |
|
lname)))) |
264 |
|
|
265 |
|
;; expand attribute names |
266 |
|
(defun xml-ns-expand-attr (attr-list xml-ns) |
267 |
|
"Expand the attribute list for a particular element from the form |
268 |
|
\"prefix:local-name\" to the form \"{namespace}:local-name\"." |
269 |
|
|
270 |
|
(mapcar |
271 |
|
(lambda (attr) |
272 |
|
(let* ((splitup (split-string (car attr) ":")) |
273 |
|
(lname (or (nth 1 splitup) |
274 |
|
(nth 0 splitup))) |
275 |
|
(prefix (if (nth 1 splitup) |
276 |
|
(nth 0 splitup) |
277 |
|
(if (string= (car attr) "xmlns") |
278 |
|
"xmlns" |
279 |
|
""))) |
280 |
|
(ns (cdr (assoc-string prefix xml-ns)))) |
281 |
|
(setcar attr |
282 |
|
(if (string= "" ns) |
283 |
|
lname |
284 |
|
(cons (intern (concat ":" ns)) |
285 |
|
lname))))) |
286 |
|
attr-list) |
287 |
|
attr-list) |
288 |
|
|
289 |
|
|
290 |
|
(defun xml-intern-attrlist (attr-list) |
291 |
|
"Convert attribute names to symbols for backward compatibility." |
292 |
|
(mapcar (lambda (attr) |
293 |
|
(setcar attr (intern (car attr)))) |
294 |
|
attr-list) |
295 |
|
attr-list) |
296 |
|
|
297 |
(defun xml-parse-tag (&optional parse-dtd parse-ns) |
(defun xml-parse-tag (&optional parse-dtd parse-ns) |
298 |
"Parse the tag at point. |
"Parse the tag at point. |
344 |
;; opening tag |
;; opening tag |
345 |
((looking-at "<\\([^/>[:space:]]+\\)") |
((looking-at "<\\([^/>[:space:]]+\\)") |
346 |
(goto-char (match-end 1)) |
(goto-char (match-end 1)) |
347 |
|
|
348 |
|
;; Parse this node |
349 |
(let* ((node-name (match-string 1)) |
(let* ((node-name (match-string 1)) |
350 |
;; Parse the attribute list. |
(attr-list (xml-parse-attlist)) |
351 |
(children (list (xml-parse-attlist) (intern node-name))) |
(children (if (consp xml-ns) ;; take care of namespace parsing |
352 |
|
(progn |
353 |
|
(setq xml-ns (xml-ns-parse-ns-attrs |
354 |
|
attr-list xml-ns)) |
355 |
|
(list (xml-ns-expand-attr |
356 |
|
attr-list xml-ns) |
357 |
|
(xml-ns-expand-el |
358 |
|
node-name xml-ns))) |
359 |
|
(list (xml-intern-attrlist attr-list) |
360 |
|
(intern node-name)))) |
361 |
pos) |
pos) |
362 |
|
|
|
;; add the xmlns:* attrs to our cache |
|
|
(when (consp xml-ns) |
|
|
(mapcar |
|
|
(lambda (attr) |
|
|
(let* ((splitup (split-string (symbol-name (car attr)) ":")) |
|
|
(prefix (nth 0 splitup)) |
|
|
(lname (nth 1 splitup))) |
|
|
(when (string= "xmlns" prefix) |
|
|
(setq xml-ns (append (list (cons (if lname |
|
|
lname |
|
|
"") |
|
|
(cdr attr))) |
|
|
xml-ns))))) |
|
|
(car children)) |
|
|
|
|
|
;; expand element names |
|
|
(let* ((splitup (split-string (symbol-name (cadr children)) ":")) |
|
|
(lname (or (nth 1 splitup) |
|
|
(nth 0 splitup))) |
|
|
(prefix (if (nth 1 splitup) |
|
|
(nth 0 splitup) |
|
|
""))) |
|
|
(setcdr children (list |
|
|
(intern (concat "{" |
|
|
(cdr (assoc-string prefix xml-ns)) |
|
|
"}" lname))))) |
|
|
|
|
|
;; expand attribute names |
|
|
(mapcar |
|
|
(lambda (attr) |
|
|
(let* ((splitup (split-string (symbol-name (car attr)) ":")) |
|
|
(lname (or (nth 1 splitup) |
|
|
(nth 0 splitup))) |
|
|
(prefix (if (nth 1 splitup) |
|
|
(nth 0 splitup) |
|
|
(caar xml-ns)))) |
|
|
|
|
|
(setcar attr (intern (concat "{" |
|
|
(cdr (assoc-string prefix xml-ns)) |
|
|
"}" lname))))) |
|
|
(car children))) |
|
|
|
|
363 |
;; is this an empty element ? |
;; is this an empty element ? |
364 |
(if (looking-at "/>") |
(if (looking-at "/>") |
365 |
(progn |
(progn |
414 |
(error "XML: Invalid character"))))) |
(error "XML: Invalid character"))))) |
415 |
|
|
416 |
(defun xml-parse-attlist () |
(defun xml-parse-attlist () |
417 |
"Return the attribute-list after point.Leave point at the first non-blank character after the tag." |
"Return the attribute-list after point. Leave point at the |
418 |
|
first non-blank character after the tag." |
419 |
(let ((attlist ()) |
(let ((attlist ()) |
420 |
start-pos name) |
end-pos name) |
421 |
(skip-syntax-forward " ") |
(skip-syntax-forward " ") |
422 |
(while (looking-at (eval-when-compile |
(while (looking-at (eval-when-compile |
423 |
(concat "\\(" xml-name-regexp "\\)\\s-*=\\s-*"))) |
(concat "\\(" xml-name-regexp "\\)\\s-*=\\s-*"))) |
424 |
(setq name (intern (match-string 1))) |
(setq name (match-string 1)) |
425 |
(goto-char (match-end 0)) |
(goto-char (match-end 0)) |
426 |
|
|
427 |
;; See also: http://www.w3.org/TR/2000/REC-xml-20001006#AVNormalize |
;; See also: http://www.w3.org/TR/2000/REC-xml-20001006#AVNormalize |
429 |
;; Do we have a string between quotes (or double-quotes), |
;; Do we have a string between quotes (or double-quotes), |
430 |
;; or a simple word ? |
;; or a simple word ? |
431 |
(if (looking-at "\"\\([^\"]*\\)\"") |
(if (looking-at "\"\\([^\"]*\\)\"") |
432 |
(setq start-pos (match-beginning 0)) |
(setq end-pos (match-end 0)) |
433 |
(if (looking-at "'\\([^']*\\)'") |
(if (looking-at "'\\([^']*\\)'") |
434 |
(setq start-pos (match-beginning 0)) |
(setq end-pos (match-end 0)) |
435 |
(error "XML: Attribute values must be given between quotes"))) |
(error "XML: Attribute values must be given between quotes"))) |
436 |
|
|
437 |
;; Each attribute must be unique within a given element |
;; Each attribute must be unique within a given element |
445 |
(replace-regexp-in-string "\\s-\\{2,\\}" " " string) |
(replace-regexp-in-string "\\s-\\{2,\\}" " " string) |
446 |
(push (cons name (xml-substitute-special string)) attlist)) |
(push (cons name (xml-substitute-special string)) attlist)) |
447 |
|
|
448 |
(goto-char start-pos) |
(goto-char end-pos) |
|
(forward-sexp) ; we have string syntax |
|
|
|
|
449 |
(skip-syntax-forward " ")) |
(skip-syntax-forward " ")) |
450 |
(nreverse attlist))) |
(nreverse attlist))) |
451 |
|
|
526 |
((looking-at |
((looking-at |
527 |
"<!ELEMENT\\s-+\\([[:alnum:].%;]+\\)\\s-+\\([^>]+\\)>") |
"<!ELEMENT\\s-+\\([[:alnum:].%;]+\\)\\s-+\\([^>]+\\)>") |
528 |
|
|
529 |
(setq element (intern (match-string 1)) |
(setq element (match-string 1) |
530 |
type (match-string-no-properties 2)) |
type (match-string-no-properties 2)) |
531 |
(setq end-pos (match-end 0)) |
(setq end-pos (match-end 0)) |
532 |
|
|
546 |
;; rule [45]: the element declaration must be unique |
;; rule [45]: the element declaration must be unique |
547 |
(if (assoc element dtd) |
(if (assoc element dtd) |
548 |
(error "XML: element declarations must be unique in a DTD (<%s>)" |
(error "XML: element declarations must be unique in a DTD (<%s>)" |
549 |
(symbol-name element))) |
element)) |
550 |
|
|
551 |
;; Store the element in the DTD |
;; Store the element in the DTD |
552 |
(push (list element type) dtd) |
(push (list element type) dtd) |
561 |
(search-forward ">")))) |
(search-forward ">")))) |
562 |
(nreverse dtd))) |
(nreverse dtd))) |
563 |
|
|
|
|
|
564 |
(defun xml-parse-elem-type (string) |
(defun xml-parse-elem-type (string) |
565 |
"Convert element type STRING into a Lisp structure." |
"Convert element type STRING into a Lisp structure." |
566 |
|
|