84 |
;;** |
;;** |
85 |
;;******************************************************************* |
;;******************************************************************* |
86 |
|
|
87 |
|
(defvar xml-entity-alist |
88 |
|
'(("lt" . "<") |
89 |
|
("gt" . ">") |
90 |
|
("apos" . "'") |
91 |
|
("quot" . "\"") |
92 |
|
("amp" . "&")) |
93 |
|
"The defined entities. Entities are added to this when the DTD is parsed.") |
94 |
|
|
95 |
|
(defvar xml-sub-parser nil |
96 |
|
"Dynamically set this to a non-nil value if you want to parse an XML fragment.") |
97 |
|
|
98 |
|
(defvar xml-validating-parser nil |
99 |
|
"Set to non-nil to get validity checking.") |
100 |
|
|
101 |
(defsubst xml-node-name (node) |
(defsubst xml-node-name (node) |
102 |
"Return the tag associated with NODE. |
"Return the tag associated with NODE. |
103 |
Without namespace-aware parsing, the tag is a symbol. |
Without namespace-aware parsing, the tag is a symbol. |
178 |
(kill-buffer (current-buffer))) |
(kill-buffer (current-buffer))) |
179 |
xml))) |
xml))) |
180 |
|
|
181 |
|
|
182 |
|
(let* ((start-chars (concat ":[:alpha:]_")) |
183 |
|
(name-chars (concat "-[:digit:]." start-chars)) |
184 |
|
;;[3] S ::= (#x20 | #x9 | #xD | #xA)+ |
185 |
|
(whitespace "[ \t\n\r]")) |
186 |
|
;;[4] NameStartChar ::= ":" | [A-Z] | "_" | [a-z] | [#xC0-#xD6] |
187 |
|
;; | [#xD8-#xF6] | [#xF8-#x2FF] | [#x370-#x37D] | [#x37F-#x1FFF] |
188 |
|
;; | [#x200C-#x200D] | [#x2070-#x218F] | [#x2C00-#x2FEF] | [#x3001-#xD7FF] |
189 |
|
;; | [#xF900-#xFDCF] | [#xFDF0-#xFFFD] | [#x10000-#xEFFFF] |
190 |
|
(defvar xml-name-start-char-re (concat "[" start-chars "]")) |
191 |
|
;;[4a] NameChar ::= NameStartChar | "-" | "." | [0-9] | #xB7 | [#x0300-#x036F] | [#x203F-#x2040] |
192 |
|
(defvar xml-name-char-re (concat "[" name-chars "]")) |
193 |
|
;;[5] Name ::= NameStartChar (NameChar)* |
194 |
|
(defvar xml-name-re (concat xml-name-start-char-re xml-name-char-re "*")) |
195 |
|
;;[6] Names ::= Name (#x20 Name)* |
196 |
|
(defvar xml-names-re (concat xml-name-re "\\(?: " xml-name-re "\\)*")) |
197 |
|
;;[7] Nmtoken ::= (NameChar)+ |
198 |
|
(defvar xml-nmtoken-re (concat xml-name-char-re "+")) |
199 |
|
;;[8] Nmtokens ::= Nmtoken (#x20 Nmtoken)* |
200 |
|
(defvar xml-nmtokens-re (concat xml-nmtoken-re "\\(?: " xml-name-re "\\)*")) |
201 |
|
;;[66] CharRef ::= '&#' [0-9]+ ';' | '&#x' [0-9a-fA-F]+ ';' |
202 |
|
(defvar xml-char-ref-re "\\(?:&#[0-9]+;\\|&#x[0-9a-fA-F]+;\\)") |
203 |
|
;;[68] EntityRef ::= '&' Name ';' |
204 |
|
(defvar xml-entity-ref (concat "&" xml-name-re ";")) |
205 |
|
;;[69] PEReference ::= '%' Name ';' |
206 |
|
(defvar xml-pe-reference-re (concat "%" xml-name-re ";")) |
207 |
|
;;[67] Reference ::= EntityRef | CharRef |
208 |
|
(defvar xml-reference-re (concat "\\(?:" xml-entity-ref "\\|" xml-char-ref-re "\\)")) |
209 |
|
;;[9] EntityValue ::= '"' ([^%&"] | PEReference | Reference)* '"' |
210 |
|
;; | "'" ([^%&'] | PEReference | Reference)* "'" |
211 |
|
(defvar xml-entity-value-re (concat "\\(?:\"\\(?:[^%&\"]\\|" xml-pe-reference-re |
212 |
|
"\\|" xml-reference-re "\\)*\"\\|'\\(?:[^%&']\\|" |
213 |
|
xml-pe-reference-re "\\|" xml-reference-re "\\)*'\\)"))) |
214 |
|
;;[75] ExternalID ::= 'SYSTEM' S SystemLiteral |
215 |
|
;; | 'PUBLIC' S PubidLiteral S SystemLiteral |
216 |
|
;;[76] NDataDecl ::= S 'NDATA' S |
217 |
|
;;[73] EntityDef ::= EntityValue| (ExternalID NDataDecl?) |
218 |
|
;;[71] GEDecl ::= '<!ENTITY' S Name S EntityDef S? '>' |
219 |
|
;;[74] PEDef ::= EntityValue | ExternalID |
220 |
|
;;[72] PEDecl ::= '<!ENTITY' S '%' S Name S PEDef S? '>' |
221 |
|
;;[70] EntityDecl ::= GEDecl | PEDecl |
222 |
|
|
223 |
;; Note that this is setup so that we can do whitespace-skipping with |
;; Note that this is setup so that we can do whitespace-skipping with |
224 |
;; `(skip-syntax-forward " ")', inter alia. Previously this was slow |
;; `(skip-syntax-forward " ")', inter alia. Previously this was slow |
225 |
;; compared with `re-search-forward', but that has been fixed. Also |
;; compared with `re-search-forward', but that has been fixed. Also |
285 |
(progn |
(progn |
286 |
(forward-char -1) |
(forward-char -1) |
287 |
(setq result (xml-parse-tag parse-dtd parse-ns)) |
(setq result (xml-parse-tag parse-dtd parse-ns)) |
288 |
(if (and xml result) |
(if (and xml result (not xml-sub-parser)) |
289 |
;; translation of rule [1] of XML specifications |
;; translation of rule [1] of XML specifications |
290 |
(error "XML files can have only one toplevel tag") |
(error "XML: (Not Well-Formed) Only one root tag allowed") |
291 |
(cond |
(cond |
292 |
((null result)) |
((null result)) |
293 |
((and (listp (car result)) |
((and (listp (car result)) |
321 |
;; matching cons in xml-ns. In which case we |
;; matching cons in xml-ns. In which case we |
322 |
(ns (or (cdr (assoc (if special "xmlns" prefix) |
(ns (or (cdr (assoc (if special "xmlns" prefix) |
323 |
xml-ns)) |
xml-ns)) |
324 |
:))) |
""))) |
325 |
(cons ns (if special "" lname))) |
(cons ns (if special "" lname))) |
326 |
(intern name))) |
(intern name))) |
327 |
|
|
328 |
|
(defun xml-parse-fragment (&optional parse-dtd parse-ns) |
329 |
|
"Parse xml-like fragments." |
330 |
|
(let ((xml-sub-parser t) |
331 |
|
children) |
332 |
|
(while (not (eobp)) |
333 |
|
(let ((bit (xml-parse-tag |
334 |
|
parse-dtd parse-ns))) |
335 |
|
(if children |
336 |
|
(setq children (append (list bit) children)) |
337 |
|
(if (stringp bit) |
338 |
|
(setq children (list bit)) |
339 |
|
(setq children bit))))) |
340 |
|
(reverse children))) |
341 |
|
|
342 |
(defun xml-parse-tag (&optional parse-dtd parse-ns) |
(defun xml-parse-tag (&optional parse-dtd parse-ns) |
343 |
"Parse the tag at point. |
"Parse the tag at point. |
344 |
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 |
348 |
- a list : the matching node |
- a list : the matching node |
349 |
- nil : the point is not looking at a tag. |
- nil : the point is not looking at a tag. |
350 |
- a pair : the first element is the DTD, the second is the node." |
- a pair : the first element is the DTD, the second is the node." |
351 |
(let ((xml-ns (if (consp parse-ns) |
(let ((xml-validating-parser (or parse-dtd xml-validating-parser)) |
352 |
|
(xml-ns (if (consp parse-ns) |
353 |
parse-ns |
parse-ns |
354 |
(if parse-ns |
(if parse-ns |
355 |
(list |
(list |
356 |
;; Default for empty prefix is no namespace |
;; Default for empty prefix is no namespace |
357 |
(cons "" :) |
(cons "" "") |
358 |
;; "xml" namespace |
;; "xml" namespace |
359 |
(cons "xml" :http://www.w3.org/XML/1998/namespace) |
(cons "xml" "http://www.w3.org/XML/1998/namespace") |
360 |
;; We need to seed the xmlns namespace |
;; We need to seed the xmlns namespace |
361 |
(cons "xmlns" :http://www.w3.org/2000/xmlns/)))))) |
(cons "xmlns" "http://www.w3.org/2000/xmlns/")))))) |
362 |
(cond |
(cond |
363 |
;; Processing instructions (like the <?xml version="1.0"?> tag at the |
;; Processing instructions (like the <?xml version="1.0"?> tag at the |
364 |
;; beginning of a document). |
;; beginning of a document). |
370 |
((looking-at "<!\\[CDATA\\[") |
((looking-at "<!\\[CDATA\\[") |
371 |
(let ((pos (match-end 0))) |
(let ((pos (match-end 0))) |
372 |
(unless (search-forward "]]>" nil t) |
(unless (search-forward "]]>" nil t) |
373 |
(error "CDATA section does not end anywhere in the document")) |
(error "XML: (Not Well Formed) CDATA section does not end anywhere in the document")) |
374 |
(buffer-substring pos (match-beginning 0)))) |
(buffer-substring pos (match-beginning 0)))) |
375 |
;; DTD for the document |
;; DTD for the document |
376 |
((looking-at "<!DOCTYPE") |
((looking-at "<!DOCTYPE") |
377 |
(let (dtd) |
(let ((dtd (xml-parse-dtd parse-ns))) |
378 |
(if parse-dtd |
(skip-syntax-forward " ") |
379 |
(setq dtd (xml-parse-dtd)) |
(if xml-validating-parser |
380 |
(xml-skip-dtd)) |
(cons dtd (xml-parse-tag nil xml-ns)) |
381 |
(skip-syntax-forward " ") |
(xml-parse-tag nil xml-ns)))) |
|
(if dtd |
|
|
(cons dtd (xml-parse-tag nil xml-ns)) |
|
|
(xml-parse-tag nil xml-ns)))) |
|
382 |
;; skip comments |
;; skip comments |
383 |
((looking-at "<!--") |
((looking-at "<!--") |
384 |
(search-forward "-->") |
(search-forward "-->") |
400 |
(when (consp xml-ns) |
(when (consp xml-ns) |
401 |
(dolist (attr attrs) |
(dolist (attr attrs) |
402 |
(when (and (consp (car attr)) |
(when (and (consp (car attr)) |
403 |
(eq :http://www.w3.org/2000/xmlns/ |
(equal "http://www.w3.org/2000/xmlns/" |
404 |
(caar attr))) |
(caar attr))) |
405 |
(push (cons (cdar attr) (intern (concat ":" (cdr attr)))) |
(push (cons (cdar attr) (cdr attr)) |
406 |
xml-ns)))) |
xml-ns)))) |
407 |
|
|
408 |
(setq children (list attrs (xml-maybe-do-ns node-name "" xml-ns))) |
(setq children (list attrs (xml-maybe-do-ns node-name "" xml-ns))) |
409 |
|
|
410 |
;; is this an empty element ? |
;; is this an empty element ? |
411 |
(if (looking-at "/>") |
(if (looking-at "/>") |
|
(progn |
|
|
(forward-char 2) |
|
|
(nreverse children)) |
|
|
|
|
|
;; is this a valid start tag ? |
|
|
(if (eq (char-after) ?>) |
|
412 |
(progn |
(progn |
413 |
(forward-char 1) |
(forward-char 2) |
|
;; Now check that we have the right end-tag. Note that this |
|
|
;; one might contain spaces after the tag name |
|
|
(let ((end (concat "</" node-name "\\s-*>"))) |
|
|
(while (not (looking-at end)) |
|
|
(cond |
|
|
((looking-at "</") |
|
|
(error "XML: Invalid end tag (expecting %s) at pos %d" |
|
|
node-name (point))) |
|
|
((= (char-after) ?<) |
|
|
(let ((tag (xml-parse-tag nil xml-ns))) |
|
|
(when tag |
|
|
(push tag children)))) |
|
|
(t |
|
|
(setq pos (point)) |
|
|
(search-forward "<") |
|
|
(forward-char -1) |
|
|
(let ((string (buffer-substring pos (point))) |
|
|
(pos 0)) |
|
|
|
|
|
;; 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)))))))) |
|
|
|
|
|
(goto-char (match-end 0)) |
|
414 |
(nreverse children)) |
(nreverse children)) |
415 |
;; This was an invalid start tag |
|
416 |
(error "XML: Invalid attribute list"))))) |
;; is this a valid start tag ? |
417 |
(t ;; This is not a tag. |
(if (eq (char-after) ?>) |
418 |
(error "XML: Invalid character"))))) |
(progn |
419 |
|
(forward-char 1) |
420 |
|
;; Now check that we have the right end-tag. Note that this |
421 |
|
;; one might contain spaces after the tag name |
422 |
|
(let ((end (concat "</" node-name "\\s-*>"))) |
423 |
|
(while (not (looking-at end)) |
424 |
|
(cond |
425 |
|
((looking-at "</") |
426 |
|
(error "XML: (Not Well-Formed) Invalid end tag (expecting %s) at pos %d" |
427 |
|
node-name (point))) |
428 |
|
((= (char-after) ?<) |
429 |
|
(let ((tag (xml-parse-tag nil xml-ns))) |
430 |
|
(when tag |
431 |
|
(push tag children)))) |
432 |
|
(t |
433 |
|
(let ((expansion (xml-parse-string))) |
434 |
|
(setq children |
435 |
|
(if (stringp expansion) |
436 |
|
(if (stringp (car children)) |
437 |
|
;; The two strings were separated by a comment. |
438 |
|
(setq children (append (concat (car children) expansion) |
439 |
|
(cdr children))) |
440 |
|
(setq children (append (list expansion) children))) |
441 |
|
(setq children (append expansion children)))))))) |
442 |
|
|
443 |
|
(goto-char (match-end 0)) |
444 |
|
(nreverse children))) |
445 |
|
;; This was an invalid start tag (Expected ">", but didn't see it.) |
446 |
|
(error "XML: (Well-Formed) Couldn't parse tag: %s" |
447 |
|
(buffer-substring (- (point) 10) (+ (point) 1))))))) |
448 |
|
(t ;; (Not one of PI, CDATA, Comment, End tag, or Start tag) |
449 |
|
(unless xml-sub-parser ; Usually, we error out. |
450 |
|
(error "XML: (Well-Formed) Invalid character")) |
451 |
|
|
452 |
|
;; However, if we're parsing incrementally, then we need to deal |
453 |
|
;; with stray CDATA. |
454 |
|
(xml-parse-string))))) |
455 |
|
|
456 |
|
(defun xml-parse-string () |
457 |
|
"Parse the next whatever. Could be a string, or an element." |
458 |
|
(let* ((pos (point)) |
459 |
|
(string (progn (if (search-forward "<" nil t) |
460 |
|
(forward-char -1) |
461 |
|
(goto-char (point-max))) |
462 |
|
(buffer-substring pos (point))))) |
463 |
|
;; Clean up the string. As per XML specifications, the XML |
464 |
|
;; processor should always pass the whole string to the |
465 |
|
;; application. But \r's should be replaced: |
466 |
|
;; http://www.w3.org/TR/2000/REC-xml-20001006#sec-line-ends |
467 |
|
(setq pos 0) |
468 |
|
(while (string-match "\r\n?" string pos) |
469 |
|
(setq string (replace-match "\n" t t string)) |
470 |
|
(setq pos (1+ (match-beginning 0)))) |
471 |
|
|
472 |
|
(xml-substitute-special string))) |
473 |
|
|
474 |
(defun xml-parse-attlist (&optional xml-ns) |
(defun xml-parse-attlist (&optional xml-ns) |
475 |
"Return the attribute-list after point. |
"Return the attribute-list after point. |
491 |
(setq end-pos (match-end 0)) |
(setq end-pos (match-end 0)) |
492 |
(if (looking-at "'\\([^']*\\)'") |
(if (looking-at "'\\([^']*\\)'") |
493 |
(setq end-pos (match-end 0)) |
(setq end-pos (match-end 0)) |
494 |
(error "XML: Attribute values must be given between quotes"))) |
(error "XML: (Not Well-Formed) Attribute values must be given between quotes"))) |
495 |
|
|
496 |
;; Each attribute must be unique within a given element |
;; Each attribute must be unique within a given element |
497 |
(if (assoc name attlist) |
(if (assoc name attlist) |
498 |
(error "XML: each attribute must be unique within an element")) |
(error "XML: (Not Well-Formed) Each attribute must be unique within an element")) |
499 |
|
|
500 |
;; Multiple whitespace characters should be replaced with a single one |
;; Multiple whitespace characters should be replaced with a single one |
501 |
;; in the attributes |
;; in the attributes |
502 |
(let ((string (match-string 1)) |
(let ((string (match-string 1)) |
503 |
(pos 0)) |
(pos 0)) |
504 |
(replace-regexp-in-string "\\s-\\{2,\\}" " " string) |
(replace-regexp-in-string "\\s-\\{2,\\}" " " string) |
505 |
(push (cons name (xml-substitute-special string)) attlist)) |
(let ((expansion (xml-substitute-special string))) |
506 |
|
(unless (stringp expansion) |
507 |
|
; We say this is the constraint. It is acctually that |
508 |
|
; external entities nor "<" can be in an attribute value. |
509 |
|
(error "XML: (Not Well-Formed) Entities in attributes cannot expand into elements")) |
510 |
|
(push (cons name expansion) attlist))) |
511 |
|
|
512 |
(goto-char end-pos) |
(goto-char end-pos) |
513 |
(skip-syntax-forward " ")) |
(skip-syntax-forward " ")) |
526 |
(defun xml-skip-dtd () |
(defun xml-skip-dtd () |
527 |
"Skip the DTD at point. |
"Skip the DTD at point. |
528 |
This follows the rule [28] in the XML specifications." |
This follows the rule [28] in the XML specifications." |
529 |
(forward-char (length "<!DOCTYPE")) |
(let ((xml-validating-parser nil)) |
530 |
(if (looking-at "\\s-*>") |
(xml-parse-dtd))) |
|
(error "XML: invalid DTD (excepting name of the document)")) |
|
|
(condition-case nil |
|
|
(progn |
|
|
(forward-sexp) |
|
|
(skip-syntax-forward " ") |
|
|
(if (looking-at "\\[") |
|
|
(re-search-forward "]\\s-*>") |
|
|
(search-forward ">"))) |
|
|
(error (error "XML: No end to the DTD")))) |
|
531 |
|
|
532 |
(defun xml-parse-dtd () |
(defun xml-parse-dtd (&optional parse-ns) |
533 |
"Parse the DTD at point." |
"Parse the DTD at point." |
534 |
(forward-char (eval-when-compile (length "<!DOCTYPE"))) |
(forward-char (eval-when-compile (length "<!DOCTYPE"))) |
535 |
(skip-syntax-forward " ") |
(skip-syntax-forward " ") |
536 |
(if (looking-at ">") |
(if (and (looking-at ">") |
537 |
(error "XML: invalid DTD (excepting name of the document)")) |
xml-validating-parser) |
538 |
|
(error "XML: (Validity) Invalid DTD (expecting name of the document)")) |
539 |
|
|
540 |
;; Get the name of the document |
;; Get the name of the document |
541 |
(looking-at xml-name-regexp) |
(looking-at xml-name-regexp) |
553 |
(re-search-forward |
(re-search-forward |
554 |
"\\='\\([[:space:][:alnum:]-()+,./:=?;!*#@$_%]*\\)'" |
"\\='\\([[:space:][:alnum:]-()+,./:=?;!*#@$_%]*\\)'" |
555 |
nil t)) |
nil t)) |
556 |
(error "XML: missing public id")) |
(error "XML: Missing Public ID")) |
557 |
(let ((pubid (match-string 1))) |
(let ((pubid (match-string 1))) |
558 |
|
(skip-syntax-forward " ") |
559 |
(unless (or (re-search-forward "\\='\\([^']*\\)'" nil t) |
(unless (or (re-search-forward "\\='\\([^']*\\)'" nil t) |
560 |
(re-search-forward "\\=\"\\([^\"]*\\)\"" nil t)) |
(re-search-forward "\\=\"\\([^\"]*\\)\"" nil t)) |
561 |
(error "XML: missing system id")) |
(error "XML: Missing System ID")) |
562 |
(push (list pubid (match-string 1) 'public) dtd))) |
(push (list pubid (match-string 1) 'public) dtd))) |
563 |
((looking-at "SYSTEM\\s-+") |
((looking-at "SYSTEM\\s-+") |
564 |
(goto-char (match-end 0)) |
(goto-char (match-end 0)) |
565 |
(unless (or (re-search-forward "\\='\\([^']*\\)'" nil t) |
(unless (or (re-search-forward "\\='\\([^']*\\)'" nil t) |
566 |
(re-search-forward "\\=\"\\([^\"]*\\)\"" nil t)) |
(re-search-forward "\\=\"\\([^\"]*\\)\"" nil t)) |
567 |
(error "XML: missing system id")) |
(error "XML: Missing System ID")) |
568 |
(push (list (match-string 1) 'system) dtd))) |
(push (list (match-string 1) 'system) dtd))) |
569 |
(skip-syntax-forward " ") |
(skip-syntax-forward " ") |
570 |
(if (eq ?> (char-after)) |
(if (eq ?> (char-after)) |
571 |
(forward-char) |
(forward-char) |
|
(skip-syntax-forward " ") |
|
572 |
(if (not (eq (char-after) ?\[)) |
(if (not (eq (char-after) ?\[)) |
573 |
(error "XML: bad DTD") |
(error "XML: Bad DTD") |
574 |
(forward-char) |
(forward-char) |
575 |
;; Parse the rest of the DTD |
;; Parse the rest of the DTD |
576 |
;; Fixme: Deal with ENTITY, ATTLIST, NOTATION, PIs. |
;; Fixme: Deal with ATTLIST, NOTATION, PIs. |
577 |
(while (not (looking-at "\\s-*\\]")) |
(while (not (looking-at "\\s-*\\]")) |
578 |
(skip-syntax-forward " ") |
(skip-syntax-forward " ") |
579 |
(cond |
(cond |
597 |
((string-match "^%[^;]+;[ \t\n\r]*$" type) ;; substitution |
((string-match "^%[^;]+;[ \t\n\r]*$" type) ;; substitution |
598 |
nil) |
nil) |
599 |
(t |
(t |
600 |
(error "XML: Invalid element type in the DTD"))) |
(if xml-validating-parser |
601 |
|
error "XML: (Validity) Invalid element type in the DTD"))) |
602 |
|
|
603 |
;; rule [45]: the element declaration must be unique |
;; rule [45]: the element declaration must be unique |
604 |
(if (assoc element dtd) |
(if (and (assoc element dtd) |
605 |
(error "XML: element declarations must be unique in a DTD (<%s>)" |
xml-validating-parser) |
606 |
|
(error "XML: (Validity) Element declarations must be unique in a DTD (<%s>)" |
607 |
element)) |
element)) |
608 |
|
|
609 |
;; Store the element in the DTD |
;; Store the element in the DTD |
611 |
(goto-char end-pos)) |
(goto-char end-pos)) |
612 |
((looking-at "<!--") |
((looking-at "<!--") |
613 |
(search-forward "-->")) |
(search-forward "-->")) |
614 |
|
((looking-at (concat "<!ENTITY[ \t\n\r]*\\(" xml-name-re |
615 |
|
"\\)[ \t\n\r]*\\(" xml-entity-value-re |
616 |
|
"\\)[ \t\n\r]*>")) |
617 |
|
(let ((name (buffer-substring (nth 2 (match-data)) |
618 |
|
(nth 3 (match-data)))) |
619 |
|
(value (buffer-substring (+ (nth 4 (match-data)) 1) |
620 |
|
(- (nth 5 (match-data)) 1)))) |
621 |
|
(goto-char (nth 1 (match-data))) |
622 |
|
(setq xml-entity-alist |
623 |
|
(append xml-entity-alist |
624 |
|
(list (cons name |
625 |
|
(with-temp-buffer |
626 |
|
(insert value) |
627 |
|
(goto-char (point-min)) |
628 |
|
(xml-parse-fragment |
629 |
|
xml-validating-parser |
630 |
|
parse-ns)))))))) |
631 |
|
((or (looking-at (concat "<!ENTITY[ \t\n\r]+\\(" xml-name-re |
632 |
|
"\\)[ \t\n\r]+SYSTEM[ \t\n\r]+" |
633 |
|
"\\(\"[^\"]*\"\\|'[^']*'\\)[ \t\n\r]*>")) |
634 |
|
(looking-at (concat "<!ENTITY[ \t\n\r]+\\(" xml-name-re |
635 |
|
"\\)[ \t\n\r]+PUBLIC[ \t\n\r]+" |
636 |
|
"\"[- \r\na-zA-Z0-9'()+,./:=?;!*#@$_%]*\"" |
637 |
|
"\\|'[- \r\na-zA-Z0-9()+,./:=?;!*#@$_%]*'" |
638 |
|
"[ \t\n\r]+\\(\"[^\"]*\"\\|'[^']*'\\)" |
639 |
|
"[ \t\n\r]*>"))) |
640 |
|
(let ((name (buffer-substring (nth 2 (match-data)) |
641 |
|
(nth 3 (match-data)))) |
642 |
|
(file (buffer-substring (+ (nth 4 (match-data)) 1) |
643 |
|
(- (nth 5 (match-data)) 1)))) |
644 |
|
(goto-char (nth 1 (match-data))) |
645 |
|
(setq xml-entity-alist |
646 |
|
(append xml-entity-alist |
647 |
|
(list (cons name (with-temp-buffer |
648 |
|
(insert-file-contents file) |
649 |
|
(goto-char (point-min)) |
650 |
|
(xml-parse-fragment |
651 |
|
xml-validating-parser |
652 |
|
parse-ns)))))))) |
653 |
(t |
(t |
654 |
(error "XML: Invalid DTD item"))) |
(error "XML: (Validity) Invalid DTD item"))))) |
655 |
|
(if (looking-at "\\s-*]>") |
656 |
;; Skip the end of the DTD |
(goto-char (nth 1 (match-data))))) |
|
(search-forward ">")))) |
|
657 |
(nreverse dtd))) |
(nreverse dtd))) |
658 |
|
|
659 |
(defun xml-parse-elem-type (string) |
(defun xml-parse-elem-type (string) |
695 |
;;** |
;;** |
696 |
;;******************************************************************* |
;;******************************************************************* |
697 |
|
|
|
(eval-when-compile |
|
|
(defvar str)) ; dynamic from replace-regexp-in-string |
|
|
|
|
|
;; Fixme: Take declared entities from the DTD when they're available. |
|
|
(defun xml-substitute-entity (match) |
|
|
"Subroutine of `xml-substitute-special'." |
|
|
(save-match-data |
|
|
(let ((match1 (match-string 1 str))) |
|
|
(cond ((string= match1 "lt") "<") |
|
|
((string= match1 "gt") ">") |
|
|
((string= match1 "apos") "'") |
|
|
((string= match1 "quot") "\"") |
|
|
((string= match1 "amp") "&") |
|
|
((and (string-match "#\\([0-9]+\\)" match1) |
|
|
(let ((c (decode-char |
|
|
'ucs |
|
|
(string-to-number (match-string 1 match1))))) |
|
|
(if c (string c))))) ; else unrepresentable |
|
|
((and (string-match "#x\\([[:xdigit:]]+\\)" match1) |
|
|
(let ((c (decode-char |
|
|
'ucs |
|
|
(string-to-number (match-string 1 match1) 16)))) |
|
|
(if c (string c))))) |
|
|
;; Default to asis. Arguably, unrepresentable code points |
|
|
;; might be best replaced with U+FFFD. |
|
|
(t match))))) |
|
|
|
|
698 |
(defun xml-substitute-special (string) |
(defun xml-substitute-special (string) |
699 |
"Return STRING, after subsituting entity references." |
"Return STRING, after subsituting entity references." |
700 |
;; This originally made repeated passes through the string from the |
;; This originally made repeated passes through the string from the |
701 |
;; beginning, which isn't correct, since then either "&amp;" or |
;; beginning, which isn't correct, since then either "&amp;" or |
702 |
;; "&amp;" won't DTRT. |
;; "&amp;" won't DTRT. |
|
(replace-regexp-in-string "&\\([^;]+\\);" |
|
|
#'xml-substitute-entity string t t)) |
|
703 |
|
|
704 |
|
(let ((point 0) |
705 |
|
children end-point) |
706 |
|
(while (string-match "&\\([^;]+\\);" string point) |
707 |
|
(setq end-point (match-end 0)) |
708 |
|
(let* ((this-part (match-string 1 string)) |
709 |
|
(prev-part (substring string point (match-beginning 0))) |
710 |
|
(entity (assoc this-part xml-entity-alist)) |
711 |
|
(expansion |
712 |
|
(cond ((string-match "#\\([0-9]+\\)" this-part) |
713 |
|
(let ((c (decode-char |
714 |
|
'ucs |
715 |
|
(string-to-number (match-string 1 this-part))))) |
716 |
|
(if c (string c)))) |
717 |
|
((string-match "#x\\([[:xdigit:]]+\\)" this-part) |
718 |
|
(let ((c (decode-char |
719 |
|
'ucs |
720 |
|
(string-to-number (match-string 1 this-part) 16)))) |
721 |
|
(if c (string c)))) |
722 |
|
(entity |
723 |
|
(cdr entity)) |
724 |
|
(t |
725 |
|
(if xml-validating-parser |
726 |
|
(error "XML: (Validity) Undefined entity `%s'" |
727 |
|
(match-string 1 this-part))))))) |
728 |
|
|
729 |
|
(cond ((null children) |
730 |
|
(if (stringp expansion) |
731 |
|
(setq children (concat prev-part expansion)) |
732 |
|
(if (stringp (car (last expansion))) |
733 |
|
(progn |
734 |
|
(setq children |
735 |
|
(list (concat prev-part (car expansion)) |
736 |
|
(cdr expansion)))) |
737 |
|
(setq children (append expansion prev-part))))) |
738 |
|
((stringp children) |
739 |
|
(if (stringp expansion) |
740 |
|
(setq children (concat children prev-part expansion)) |
741 |
|
(setq children (list expansion (concat prev-part children))))) |
742 |
|
((and (stringp expansion) |
743 |
|
(stringp (car children))) |
744 |
|
(setcar children (concat prev-part expansion (car children)))) |
745 |
|
((stringp expansion) |
746 |
|
(setq children (append (concat prev-part expansion) |
747 |
|
children))) |
748 |
|
((stringp (car children)) |
749 |
|
(setcar children (concat (car children) prev-part)) |
750 |
|
(setq children (append expansion children))) |
751 |
|
(t |
752 |
|
(setq children (list expansion |
753 |
|
prev-part |
754 |
|
children)))) |
755 |
|
(setq point end-point))) |
756 |
|
(cond ((stringp children) |
757 |
|
(concat children (substring string point))) |
758 |
|
((stringp (car (last children))) |
759 |
|
(concat (car children) (substring string point))) |
760 |
|
((null children) |
761 |
|
string) |
762 |
|
(t |
763 |
|
(nreverse children))))) |
764 |
;;******************************************************************* |
;;******************************************************************* |
765 |
;;** |
;;** |
766 |
;;** Printing a tree. |
;;** Printing a tree. |