1 ;;; xmltok.el --- XML tokenization
3 ;; Copyright (C) 2003, 2007, 2008 Free Software Foundation, Inc.
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 3, or (at your option)
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
23 ;; Boston, MA 02110-1301, USA.
27 ;; This implements an XML 1.0 parser. It also implements the XML
28 ;; Namespaces Recommendation. It is designed to be conforming, but it
29 ;; works a bit differently from a normal XML parser. An XML document
30 ;; consists of the prolog and an instance. The prolog is parsed as a
31 ;; single unit using `xmltok-forward-prolog'. The instance is
32 ;; considered as a sequence of tokens, where a token is something like
33 ;; a start-tag, a comment, a chunk of data or a CDATA section. The
34 ;; tokenization of the instance is stateless: the tokenization of one
35 ;; part of the instance does not depend on tokenization of the
36 ;; preceding part of the instance. This allows the instance to be
37 ;; parsed incrementally. The main entry point is `xmltok-forward':
38 ;; this can be called at any point in the instance provided it is
39 ;; between tokens. The other entry point is `xmltok-forward-special'
40 ;; which skips over tokens other comments, processing instructions or
41 ;; CDATA sections (i.e. the constructs in an instance that can contain
42 ;; less than signs that don't start a token).
44 ;; This is a non-validating XML 1.0 processor. It does not resolve
45 ;; parameter entities (including the external DTD subset) and it does
46 ;; not resolve external general entities.
48 ;; It is non-conformant by design in the following respects.
50 ;; 1. It expects the client to detect aspects of well-formedness that
51 ;; are not internal to a single token, specifically checking that
52 ;; end-tags match start-tags and that the instance contains exactly
55 ;; 2. It expects the client to detect duplicate attributes. Detection
56 ;; of duplicate attributes after expansion of namespace prefixes
57 ;; requires the namespace processing state. Detection of duplicate
58 ;; attributes before expansion of namespace prefixes does not, but is
59 ;; redundant given that the client will do detection of duplicate
60 ;; attributes after expansion of namespace prefixes.
62 ;; 3. It allows the client to recover from well-formedness errors.
63 ;; This is essential for use in applications where the document is
64 ;; being parsed during the editing process.
66 ;; 4. It does not support documents that do not conform to the lexical
67 ;; requirements of the XML Namespaces Recommendation (e.g. a document
68 ;; with a colon in an entity name).
70 ;; There are also a number of things that have not yet been
71 ;; implemented that make it non-conformant.
73 ;; 1. It does not implement default attributes. ATTLIST declarations
74 ;; are parsed, but no checking is done on the content of attribute
75 ;; value literals specifying default attribute values, and default
76 ;; attribute values are not reported to the client.
78 ;; 2. It does not implement internal entities containing elements. If
79 ;; an internal entity is referenced and parsing its replacement text
80 ;; yields one or more tags, then it will skip the reference and
81 ;; report this to the client.
83 ;; 3. It does not check the syntax of public identifiers in the DTD.
85 ;; 4. It allows some non-ASCII characters in certain situations where
86 ;; it should not. For example, it only enforces XML 1.0's
87 ;; restrictions on name characters strictly for ASCII characters. The
88 ;; problem here is XML's character model is based squarely on Unicode,
89 ;; whereas Emacs's is not (as of version 21). It is not clear what
90 ;; the right thing to do is.
94 (defvar xmltok-type nil
)
95 (defvar xmltok-start nil
)
96 (defvar xmltok-name-colon nil
)
97 (defvar xmltok-name-end nil
)
98 (defvar xmltok-replacement nil
99 "String containing replacement for a character or entity reference.")
101 (defvar xmltok-attributes nil
102 "List containing attributes of last scanned element.
103 Each member of the list is a vector representing an attribute, which
104 can be accessed using the functions `xmltok-attribute-name-start',
105 `xmltok-attribute-name-colon', `xmltok-attribute-name-end',
106 `xmltok-attribute-value-start', `xmltok-attribute-value-end',
107 `xmltok-attribute-raw-normalized-value', `xmltok-attribute-refs'.")
109 (defvar xmltok-namespace-attributes nil
110 "List containing namespace declarations of last scanned element.
111 List has same format as `xmltok-attributes'.")
113 (defvar xmltok-dtd nil
114 "Information about the DTD used by `xmltok-forward'.
115 `xmltok-forward-prolog' sets this up.
117 It consists of an alist of general entity names vs definitions. The
118 first member of the alist is t if references to entities not in the
119 alist are well-formed \(e.g. because there's an external subset that
122 Each general entity name is a string. The definition is either nil, a
123 symbol, a string, a cons cell. If the definition is nil, then it
124 means that it's an internal entity but the result of parsing it is
125 unknown. If it is a symbol, then the symbol is either `unparsed',
126 meaning the entity is an unparsed entity, `external', meaning the
127 entity is or references an external entity, `element', meaning the
128 entity includes one or more elements, or `not-well-formed', meaning
129 the replacement text is not well-formed. If the definition is a
130 string, then the replacement text of the entity is that string; this
131 happens only during the parsing of the prolog. If the definition is a
132 cons cell \(ER . AR), then ER specifies the string that results from
133 referencing the entity in element content and AR is either nil,
134 meaning the replacement text included a <, or a string which is the
135 normalized attribute value.")
137 (defvar xmltok-dependent-regions nil
138 "List of descriptors of regions that a parsed token depends on.
140 A token depends on a region if the region occurs after the token and a
141 change in the region may require the token to be reparsed. This only
142 happens with markup that is not well-formed. For example, if a <?
143 occurs without a matching ?>, then the <? is returned as a
144 not-well-formed token. However, this token is dependent on region
145 from the end of the token to the end of the buffer: if this ever
146 contains ?> then the buffer must be reparsed from the <?.
148 A region descriptor is a list (FUN START END ARG ...), where FUN is a
149 function to be called when the region changes, START and END are
150 integers giving the start and end of the region, and ARG... are
151 additional arguments to be passed to FUN. FUN will be called with 5
152 arguments followed by the additional arguments if any: the position of
153 the start of the changed area in the region, the position of the end
154 of the changed area in the region, the length of the changed area
155 before the change, the position of the start of the region, the
156 position of the end of the region. FUN must return non-nil if the
157 region needs reparsing. FUN will be called in a save-excursion with
160 `xmltok-forward', `xmltok-forward-special' and `xmltok-forward-prolog'
161 may add entries to the beginning of this list, but will not clear it.
162 `xmltok-forward' and `xmltok-forward-special' will only add entries
163 when returning tokens of type not-well-formed.")
165 (defvar xmltok-errors nil
166 "List of errors detected by `xmltok-forward' and `xmltok-forward-prolog'.
167 When `xmltok-forward' and `xmltok-forward-prolog' detect a
168 well-formedness error, they will add an entry to the beginning of this
169 list. Each entry is a vector [MESSAGE START END], where MESSAGE is a
170 string giving the error message and START and END are integers
171 indicating the position of the error.")
173 (defmacro xmltok-save
(&rest body
)
180 xmltok-namespace-attributes
181 xmltok-dependent-regions
185 (put 'xmltok-save
'lisp-indent-function
0)
186 (def-edebug-spec xmltok-save t
)
188 (defsubst xmltok-attribute-name-start
(att)
191 (defsubst xmltok-attribute-name-colon
(att)
194 (defsubst xmltok-attribute-name-end
(att)
197 (defsubst xmltok-attribute-value-start
(att)
200 (defsubst xmltok-attribute-value-end
(att)
203 (defsubst xmltok-attribute-raw-normalized-value
(att)
204 "Return an object representing the normalized value of ATT.
205 This can t indicating that the normalized value is the same as the
206 buffer substring from the start to the end of the value or nil
207 indicating that the value is not well-formed or a string."
210 (defsubst xmltok-attribute-refs
(att)
211 "Return a list of the entity and character references in ATT.
212 Each member is a vector [TYPE START END] where TYPE is either char-ref
213 or entity-ref and START and END are integers giving the start and end
214 of the reference. Nested entity references are not included in the list."
217 (defun xmltok-attribute-prefix (att)
218 (let ((colon (xmltok-attribute-name-colon att
)))
220 (buffer-substring-no-properties (xmltok-attribute-name-start att
)
223 (defun xmltok-attribute-local-name (att)
224 (let ((colon (xmltok-attribute-name-colon att
)))
225 (buffer-substring-no-properties (if colon
227 (xmltok-attribute-name-start att
))
228 (xmltok-attribute-name-end att
))))
230 (defun xmltok-attribute-value (att)
231 (let ((rnv (xmltok-attribute-raw-normalized-value att
)))
235 (buffer-substring-no-properties (xmltok-attribute-value-start att
)
236 (xmltok-attribute-value-end att
))))))
238 (defun xmltok-start-tag-prefix ()
239 (and xmltok-name-colon
240 (buffer-substring-no-properties (1+ xmltok-start
)
243 (defun xmltok-start-tag-local-name ()
244 (buffer-substring-no-properties (1+ (or xmltok-name-colon
248 (defun xmltok-end-tag-prefix ()
249 (and xmltok-name-colon
250 (buffer-substring-no-properties (+ 2 xmltok-start
)
253 (defun xmltok-end-tag-local-name ()
254 (buffer-substring-no-properties (if xmltok-name-colon
255 (1+ xmltok-name-colon
)
259 (defun xmltok-start-tag-qname ()
260 (buffer-substring-no-properties (+ xmltok-start
1) xmltok-name-end
))
262 (defun xmltok-end-tag-qname ()
263 (buffer-substring-no-properties (+ xmltok-start
2) xmltok-name-end
))
265 (defsubst xmltok-make-attribute
(name-begin
271 raw-normalized-value
)
272 "Make an attribute. RAW-NORMALIZED-VALUE is nil if the value is
273 not well-formed, t if the normalized value is the string between
274 VALUE-BEGIN and VALUE-END, otherwise a STRING giving the value."
283 (defsubst xmltok-error-message
(err)
286 (defsubst xmltok-error-start
(err)
289 (defsubst xmltok-error-end
(err)
292 (defsubst xmltok-make-error
(message start end
)
293 (vector message start end
))
295 (defun xmltok-add-error (message &optional start end
)
297 (cons (xmltok-make-error message
298 (or start xmltok-start
)
302 (defun xmltok-add-dependent (fun &optional start end
&rest args
)
303 (setq xmltok-dependent-regions
305 (cons (or start xmltok-start
)
306 (cons (or end
(point-max))
308 xmltok-dependent-regions
)))
310 (defun xmltok-forward ()
311 (setq xmltok-start
(point))
312 (let* ((case-fold-search nil
)
313 (space-count (skip-chars-forward " \t\r\n"))
316 (cond ((> space-count
0)
317 (setq xmltok-type
'space
))
319 (goto-char (1+ (point)))
320 (xmltok-scan-after-lt))))
322 (cond ((> space-count
0)
323 (setq xmltok-type
'space
))
325 (goto-char (1+ (point)))
326 (xmltok-scan-after-amp
328 (xmltok-handle-entity start end
))))))
329 ((re-search-forward "[<&]\\|\\(]]>\\)" nil t
)
330 (cond ((not (match-beginning 1))
331 (goto-char (match-beginning 0))
332 ;; must have got a non-space char
333 (setq xmltok-type
'data
))
334 ((= (match-beginning 1) xmltok-start
)
335 (xmltok-add-error "Found `]]>' not closing a CDATA section")
336 (setq xmltok-type
'not-well-formed
))
338 (goto-char (match-beginning 0))
340 (if (= (point) (+ xmltok-start space-count
))
345 (if (> space-count
0)
349 (goto-char (point-max))
350 (setq xmltok-type
'data
)))))
352 (defun xmltok-forward-special (bound)
353 "Scan forward past the first special token starting at or after point.
354 Return nil if there is no special token that starts before BOUND.
355 CDATA sections, processing instructions and comments (and indeed
356 anything starting with < following by ? or !) count
357 as special. Return the type of the token."
358 (when (re-search-forward "<[?!]" (1+ bound
) t
)
359 (setq xmltok-start
(match-beginning 0))
360 (goto-char (1+ xmltok-start
))
361 (let ((case-fold-search nil
))
362 (xmltok-scan-after-lt))))
366 ;; A symbolic regexp is represented by a list whose CAR is the string
367 ;; containing the regexp and whose cdr is a list of symbolic names
368 ;; for the groups in the string.
370 ;; Construct a symbolic regexp from a regexp.
371 (defun xmltok-r (str)
374 ;; Concatenate zero of more regexps and symbolic regexps.
375 (defun xmltok+ (&rest args
)
378 (let ((arg (car args
)))
380 (setq strs
(cons arg strs
))
381 (setq strs
(cons (car arg
) strs
))
382 (setq names
(cons (cdr arg
) names
)))
383 (setq args
(cdr args
))))
384 (cons (apply 'concat
(nreverse strs
))
385 (apply 'append
(nreverse names
))))))
388 ;; Make a symbolic group named NAME from the regexp R.
389 ;; R may be a symbolic regexp or an ordinary regexp.
390 (defmacro xmltok-g
(name &rest r
)
391 (let ((sym (make-symbol "r")))
392 `(let ((,sym
(xmltok+ ,@r
)))
394 (cons (concat "\\(" ,sym
"\\)") (cons ',name nil
))
395 (cons (concat "\\(" (car ,sym
) "\\)") (cons ',name
(cdr ,sym
)))))))
397 (defun xmltok-p (&rest r
) (xmltok+ "\\(?:"
401 ;; Get the group index of ELEM in a LIST of symbols.
402 (defun xmltok-get-index (elem list
)
404 (error "Missing group name"))
408 (cond ((eq elem
(car list
))
413 (setq list
(cdr list
)))))
415 (error "Bad group name %s" elem
))))
417 ;; Define a macro SYM using a symbolic regexp R.
418 ;; SYM can be called in three ways:
420 ;; expands to the regexp in R
423 ;; (match-beginning N)
424 ;; where N is the group index of G in R.
428 ;; where N is the group index of G in R.
429 (defmacro xmltok-defregexp
(sym r
)
432 `(macro lambda
(action &optional group-name
)
433 (cond ((eq action
'regexp
)
435 ((or (eq action
'start
) (eq action
'beginning
))
436 (list 'match-beginning
(xmltok-get-index group-name
439 (list 'match-end
(xmltok-get-index group-name
443 (xmltok-get-index group-name
',(cdr r
))))
444 ((eq action
'string-no-properties
)
445 (list 'match-string-no-properties
446 (xmltok-get-index group-name
',(cdr r
))))
447 (t (error "Invalid action: %s" action
))))))))
455 (name-start-char "[_[:alpha:]]")
456 (name-continue-not-start-char "[-.[:digit:]]")
457 (name-continue-char "[-._[:alnum:]]")
465 (ncname (concat name-start-char name-continue-char
*))
467 (xmltok+ (xmltok-g entity-name ncname
)
468 (xmltok-g entity-ref-close
";") opt
))
470 (xmltok+ (xmltok-g decimal
"[0-9]" +)
471 (xmltok-g decimal-ref-close
";") opt
))
474 (xmltok-g hex
"[0-9a-fA-F]" +)
475 (xmltok-g hex-ref-close
";") opt
478 (xmltok+ (xmltok-g number-sign
"#")
479 open decimal-ref or hex-ref close opt
))
481 (xmltok+ open
(xmltok-g start-tag-close s
* ">")
482 or open
(xmltok-g empty-tag-slash s
* "/")
483 (xmltok-g empty-tag-close
">") opt close
484 or
(xmltok-g start-tag-s s
+)
487 (xmltok+ (xmltok-g start-tag-name
488 ncname
(xmltok-g start-tag-colon
":" ncname
) opt
)
489 start-tag-close opt
))
491 (xmltok+ (xmltok-g end-tag-slash
"/")
492 open
(xmltok-g end-tag-name
494 (xmltok-g end-tag-colon
":" ncname
) opt
)
495 (xmltok-g end-tag-close s
* ">") opt
498 (xmltok+ (xmltok-g markup-declaration
"!")
499 (xmltok-g comment-first-dash
"-"
500 (xmltok-g comment-open
"-") opt
) opt
))
503 (xmltok-g marked-section-open
"\\[")
509 (xmltok-g cdata-section-open
"\\[" ) opt
515 (processing-instruction
516 (xmltok-g processing-instruction-question question
)))
518 (xmltok-defregexp xmltok-ncname
(xmltok+ open ncname close
))
520 (xmltok-defregexp xmltok-after-amp
521 (xmltok+ entity-ref or char-ref
))
522 (xmltok-defregexp xmltok-after-lt
525 ;; cdata-section must come before comment
526 ;; because we treat <! as a comment
527 ;; and Emacs doesn't do fully greedy matching
531 or processing-instruction
))
537 (xmltok-g complex1
"[&\r\n\t][^<']*") opt
539 (lit2 (cons (replace-regexp-in-string "'" "\"" (car lit1
))
541 (literal (xmltok-g literal lit1 or lit2
))
542 (name (xmltok+ open
(xmltok-g xmlns
"xmlns") or ncname close
543 (xmltok-g colon
":" ncname
) opt
)))
544 (xmltok+ (xmltok-g name name
)
546 ;; If the literal isn't followed by what it should be,
547 ;; then the closing delimiter is probably really the
548 ;; opening delimiter of another literal, so don't
549 ;; absorb the literal in this case.
550 open s
* literal start-tag-close close opt
)))
552 xmltok-xml-declaration
553 (let* ((literal-content "[-._:a-zA-Z0-9]+")
555 (concat open
"\"" literal-content
"\""
556 or
"'" literal-content
"'" close
))
559 s
+ (xmltok-g version-name
"version")
561 s
* (xmltok-g version-value literal
)
565 s
+ (xmltok-g encoding-name
"encoding")
567 s
* (xmltok-g encoding-value literal
)
570 (concat open
"yes" or
"no" close
))
573 s
+ (xmltok-g standalone-name
"standalone")
575 s
* (xmltok-g standalone-value
576 "\"" yes-no
"\"" or
"'" yes-no
"'")
578 (xmltok+ "<" question
"xml"
585 (let* ((single-char (xmltok-g single-char
"[[|,(\"'>]"))
586 (internal-subset-close (xmltok-g internal-subset-close
588 (starts-with-close-paren
589 (xmltok-g close-paren
592 (xmltok-g close-paren-occur
"[+?]")
594 (xmltok-g close-paren-star
"\\*"))
598 "%" (xmltok-g param-entity-ref
600 (xmltok-g param-entity-ref-close
602 (starts-with-nmtoken-not-name
604 (xmltok-p name-continue-not-start-char or
":")
605 (xmltok-p name-continue-char or
":") *))
608 (xmltok-p name-continue-not-start-char or
":")
609 (xmltok-p name-continue-char or
":") *
614 (xmltok-p name-continue-char or
":") *))
616 (xmltok+ (xmltok-g ncname-nmtoken
617 ":" (xmltok-p nmtoken-after-colon
))
618 or
(xmltok-p (xmltok-g colon
":" ncname
)
619 (xmltok-g colon-name-occur
"[?+*]") opt
)
620 or
(xmltok-g ncname-occur
"[?+*]")
621 or
(xmltok-g ncname-colon
":")))
623 (xmltok-g name ncname
(xmltok-p after-ncname
) opt
))
626 "#" (xmltok-g hash-name ncname
)))
628 (xmltok-g markup-declaration
629 "!" (xmltok-p (xmltok-g comment-first-dash
"-"
630 (xmltok-g comment-open
"-") opt
)
631 or
(xmltok-g named-markup-declaration
634 (xmltok+ markup-declaration
635 or
(xmltok-g processing-instruction-question
637 or
(xmltok-g instance-start
639 (starts-with-lt (xmltok-g less-than
"<" (xmltok-p after-lt
) opt
)))
640 (xmltok+ starts-with-lt
642 or starts-with-close-paren
643 or starts-with-percent
645 or starts-with-nmtoken-not-name
647 or internal-subset-close
)))))
649 (defconst xmltok-ncname-regexp
(xmltok-ncname regexp
))
651 (defun xmltok-scan-after-lt ()
652 (cond ((not (looking-at (xmltok-after-lt regexp
)))
653 (xmltok-add-error "`<' that is not markup must be entered as `<'")
654 (setq xmltok-type
'not-well-formed
))
656 (goto-char (match-end 0))
657 (cond ((xmltok-after-lt start start-tag-close
)
658 (setq xmltok-name-end
659 (xmltok-after-lt end start-tag-name
))
660 (setq xmltok-name-colon
661 (xmltok-after-lt start start-tag-colon
))
662 (setq xmltok-attributes nil
)
663 (setq xmltok-namespace-attributes nil
)
664 (setq xmltok-type
'start-tag
))
665 ((xmltok-after-lt start end-tag-close
)
666 (setq xmltok-name-end
667 (xmltok-after-lt end end-tag-name
))
668 (setq xmltok-name-colon
669 (xmltok-after-lt start end-tag-colon
))
670 (setq xmltok-type
'end-tag
))
671 ((xmltok-after-lt start start-tag-s
)
672 (setq xmltok-name-end
673 (xmltok-after-lt end start-tag-name
))
674 (setq xmltok-name-colon
675 (xmltok-after-lt start start-tag-colon
))
676 (setq xmltok-namespace-attributes nil
)
677 (setq xmltok-attributes nil
)
678 (xmltok-scan-attributes)
680 ((xmltok-after-lt start empty-tag-close
)
681 (setq xmltok-name-end
682 (xmltok-after-lt end start-tag-name
))
683 (setq xmltok-name-colon
684 (xmltok-after-lt start start-tag-colon
))
685 (setq xmltok-attributes nil
)
686 (setq xmltok-namespace-attributes nil
)
687 (setq xmltok-type
'empty-element
))
688 ((xmltok-after-lt start cdata-section-open
)
690 (if (search-forward "]]>" nil t
)
692 (xmltok-add-error "No closing ]]>")
693 (xmltok-add-dependent 'xmltok-unclosed-reparse-p
698 ((xmltok-after-lt start processing-instruction-question
)
699 (xmltok-scan-after-processing-instruction-open))
700 ((xmltok-after-lt start comment-open
)
701 (xmltok-scan-after-comment-open))
702 ((xmltok-after-lt start empty-tag-slash
)
703 (setq xmltok-name-end
704 (xmltok-after-lt end start-tag-name
))
705 (setq xmltok-name-colon
706 (xmltok-after-lt start start-tag-colon
))
707 (setq xmltok-attributes nil
)
708 (setq xmltok-namespace-attributes nil
)
709 (xmltok-add-error "Expected `/>'" (1- (point)))
710 (setq xmltok-type
'partial-empty-element
))
711 ((xmltok-after-lt start start-tag-name
)
712 (xmltok-add-error "Missing `>'"
715 (setq xmltok-name-end
716 (xmltok-after-lt end start-tag-name
))
717 (setq xmltok-name-colon
718 (xmltok-after-lt start start-tag-colon
))
719 (setq xmltok-namespace-attributes nil
)
720 (setq xmltok-attributes nil
)
721 (setq xmltok-type
'partial-start-tag
))
722 ((xmltok-after-lt start end-tag-name
)
723 (setq xmltok-name-end
(xmltok-after-lt end end-tag-name
))
724 (setq xmltok-name-colon
725 (xmltok-after-lt start end-tag-colon
))
726 (cond ((and (not xmltok-name-colon
)
727 (eq (char-after) ?
:))
728 (goto-char (1+ (point)))
729 (xmltok-add-error "Expected name following `:'"
732 (xmltok-add-error "Missing `>'"
735 (setq xmltok-type
'partial-end-tag
))
736 ((xmltok-after-lt start end-tag-slash
)
737 (xmltok-add-error "Expected name following `</'")
738 (setq xmltok-name-end nil
)
739 (setq xmltok-name-colon nil
)
740 (setq xmltok-type
'partial-end-tag
))
741 ((xmltok-after-lt start marked-section-open
)
742 (xmltok-add-error "Expected `CDATA[' after `<!['"
745 (setq xmltok-type
'not-well-formed
))
746 ((xmltok-after-lt start comment-first-dash
)
747 (xmltok-add-error "Expected `-' after `<!-'"
750 (setq xmltok-type
'not-well-formed
))
751 ((xmltok-after-lt start markup-declaration
)
752 (xmltok-add-error "Expected `[CDATA[' or `--' after `<!'"
755 (setq xmltok-type
'not-well-formed
))
757 (xmltok-add-error "Not well-formed")
758 (setq xmltok-type
'not-well-formed
))))))
760 ;; XXX This should be unified with
761 ;; xmltok-scan-prolog-after-processing-instruction-open
762 ;; XXX maybe should include rest of line (up to any <,>) in unclosed PI
763 (defun xmltok-scan-after-processing-instruction-open ()
764 (cond ((not (search-forward "?>" nil t
))
765 (xmltok-add-error "No closing ?>"
768 (xmltok-add-dependent 'xmltok-unclosed-reparse-p
772 (setq xmltok-type
'not-well-formed
))
774 (cond ((not (save-excursion
775 (goto-char (+ 2 xmltok-start
))
776 (and (looking-at (xmltok-ncname regexp
))
777 (setq xmltok-name-end
(match-end 0)))))
778 (setq xmltok-name-end
(+ xmltok-start
2))
779 (xmltok-add-error "<? not followed by name"
782 ((not (or (memq (char-after xmltok-name-end
)
784 (= xmltok-name-end
(- (point) 2))))
785 (xmltok-add-error "Target not followed by whitespace"
787 (1+ xmltok-name-end
)))
788 ((and (= xmltok-name-end
(+ xmltok-start
5))
790 (goto-char (+ xmltok-start
2))
791 (let ((case-fold-search t
))
792 (looking-at "xml"))))
793 (xmltok-add-error "Processing instruction target is xml"
795 (+ xmltok-start
5))))
796 (setq xmltok-type
'processing-instruction
))))
798 (defun xmltok-scan-after-comment-open ()
800 (cond ((not (search-forward "--" nil t
))
801 (xmltok-add-error "No closing -->")
802 (xmltok-add-dependent 'xmltok-unclosed-reparse-p
807 ;; in comments in XML
810 ((eq (char-after) ?
>)
811 (goto-char (1+ (point)))
814 (xmltok-add-dependent
815 'xmltok-semi-closed-reparse-p
820 ;; just include the <!-- in the token
821 (goto-char (+ xmltok-start
4))
822 ;; Need do this after the goto-char because
823 ;; marked error should just apply to <!--
824 (xmltok-add-error "First following `--' not followed by `>'")
827 (defun xmltok-scan-attributes ()
828 (let ((recovering nil
)
829 (atts-needing-normalization nil
))
830 (while (cond ((or (looking-at (xmltok-attribute regexp
))
831 ;; use non-greedy group
832 (when (looking-at (concat "[^<>\n]+?"
833 (xmltok-attribute regexp
)))
835 (xmltok-add-error "Malformed attribute"
838 (goto-char (xmltok-attribute start
840 (skip-chars-backward "\r\n\t ")
843 (setq recovering nil
)
844 (goto-char (match-end 0))
845 (let ((att (xmltok-add-attribute)))
847 (setq atts-needing-normalization
848 (cons att atts-needing-normalization
))))
849 (cond ((xmltok-attribute start start-tag-s
) t
)
850 ((xmltok-attribute start start-tag-close
)
851 (setq xmltok-type
'start-tag
)
853 ((xmltok-attribute start empty-tag-close
)
854 (setq xmltok-type
'empty-element
)
856 ((xmltok-attribute start empty-tag-slash
)
857 (setq xmltok-type
'partial-empty-element
)
858 (xmltok-add-error "Expected `/>'"
861 ((looking-at "[ \t\r\n]*[\"']")
862 (goto-char (match-end 0))
863 (xmltok-add-error "Missing closing delimiter"
867 ((looking-at "[ \t]*\\([^ \t\r\n\"'=<>/]+\\)[ \t\r\n/>]")
868 (goto-char (match-end 1))
869 (xmltok-add-error "Attribute value not quoted"
874 (xmltok-add-error "Missing attribute value"
878 ((looking-at "[^<>\n]*/>")
879 (let ((start (point)))
880 (goto-char (match-end 0))
882 (xmltok-add-error "Malformed empty-element"
885 (setq xmltok-type
'empty-element
)
887 ((looking-at "[^<>\n]*>")
888 (let ((start (point)))
889 (goto-char (match-end 0))
891 (xmltok-add-error "Malformed start-tag"
894 (setq xmltok-type
'start-tag
)
898 (skip-chars-forward "^<>\n"))
899 (xmltok-add-error "Missing `>'"
902 (setq xmltok-type
'partial-start-tag
)
904 (while atts-needing-normalization
905 (xmltok-normalize-attribute (car atts-needing-normalization
))
906 (setq atts-needing-normalization
(cdr atts-needing-normalization
))))
907 (setq xmltok-attributes
908 (nreverse xmltok-attributes
))
909 (setq xmltok-namespace-attributes
910 (nreverse xmltok-namespace-attributes
)))
912 (defun xmltok-add-attribute ()
913 "Return the attribute if it needs normalizing, otherwise nil."
914 (let* ((needs-normalizing nil
)
916 (if (xmltok-attribute start literal
)
918 (setq needs-normalizing
919 (or (xmltok-attribute start complex1
)
920 (xmltok-attribute start complex2
)))
921 (xmltok-make-attribute (xmltok-attribute start name
)
922 (xmltok-attribute start colon
)
923 (xmltok-attribute end name
)
924 (1+ (xmltok-attribute start literal
))
925 (1- (xmltok-attribute end literal
))
926 (not needs-normalizing
)))
927 (xmltok-make-attribute (xmltok-attribute start name
)
928 (xmltok-attribute start colon
)
929 (xmltok-attribute end name
)))))
930 (if (xmltok-attribute start xmlns
)
931 (setq xmltok-namespace-attributes
932 (cons att xmltok-namespace-attributes
))
933 (setq xmltok-attributes
934 (cons att xmltok-attributes
)))
935 (and needs-normalizing
938 (defun xmltok-normalize-attribute (att)
939 (let ((end (xmltok-attribute-value-end att
))
944 (goto-char (xmltok-attribute-value-start att
))
946 (let ((n (skip-chars-forward "^\r\t\n&" end
)))
949 (cons (buffer-substring-no-properties (- (point) n
)
952 (when (< (point) end
)
953 (goto-char (1+ (point)))
954 (cond ((eq (char-before) ?\
&)
955 (let ((xmltok-start (1- (point)))
956 xmltok-type xmltok-replacement
)
957 (xmltok-scan-after-amp
959 (xmltok-handle-entity start end t
)))
960 (cond ((or (eq xmltok-type
'char-ref
)
961 (eq xmltok-type
'entity-ref
))
963 (cons (vector xmltok-type
967 (if xmltok-replacement
969 (cons xmltok-replacement
971 (setq well-formed nil
)))
972 (t (setq well-formed nil
)))))
974 (cons " " value-parts
)))))
977 (aset att
5 (apply 'concat
(nreverse value-parts
))))
978 (aset att
6 (nreverse refs
))))
980 (defun xmltok-scan-after-amp (entity-handler)
981 (cond ((not (looking-at (xmltok-after-amp regexp
)))
982 (xmltok-add-error "`&' that is not markup must be entered as `&'")
983 (setq xmltok-type
'not-well-formed
))
985 (goto-char (match-end 0))
986 (cond ((xmltok-after-amp start entity-ref-close
)
987 (funcall entity-handler
988 (xmltok-after-amp start entity-name
)
989 (xmltok-after-amp end entity-name
))
990 (setq xmltok-type
'entity-ref
))
991 ((xmltok-after-amp start decimal-ref-close
)
992 (xmltok-scan-char-ref (xmltok-after-amp start decimal
)
993 (xmltok-after-amp end decimal
)
995 ((xmltok-after-amp start hex-ref-close
)
996 (xmltok-scan-char-ref (xmltok-after-amp start hex
)
997 (xmltok-after-amp end hex
)
999 ((xmltok-after-amp start number-sign
)
1000 (xmltok-add-error "Missing character number")
1001 (setq xmltok-type
'not-well-formed
))
1003 (xmltok-add-error "Missing closing `;'")
1004 (setq xmltok-type
'not-well-formed
))))))
1006 (defconst xmltok-entity-error-messages
1007 '((unparsed .
"Referenced entity is unparsed")
1008 (not-well-formed .
"Referenced entity is not well-formed")
1009 (external nil .
"Referenced entity is external")
1010 (element nil .
"Referenced entity contains <")))
1012 (defun xmltok-handle-entity (start end
&optional attributep
)
1013 (let* ((name (buffer-substring-no-properties start end
))
1014 (name-def (assoc name xmltok-dtd
))
1015 (def (cdr name-def
)))
1016 (cond ((setq xmltok-replacement
(and (consp def
)
1021 (unless (eq (car xmltok-dtd
) t
)
1022 (xmltok-add-error "Referenced entity has not been defined"
1025 ((and attributep
(consp def
))
1026 (xmltok-add-error "Referenced entity contains <"
1030 (let ((err (cdr (assq def xmltok-entity-error-messages
))))
1032 (setq err
(if attributep
(cdr err
) (car err
))))
1034 (xmltok-add-error err start end
)))))))
1036 (defun xmltok-scan-char-ref (start end base
)
1037 (setq xmltok-replacement
1038 (let ((n (string-to-number (buffer-substring-no-properties start end
)
1040 (cond ((and (integerp n
) (xmltok-valid-char-p n
))
1041 (setq n
(xmltok-unicode-to-char n
))
1044 (xmltok-add-error "Invalid character code" start end
)
1046 (setq xmltok-type
'char-ref
))
1048 (defun xmltok-char-number (start end
)
1049 (let* ((base (if (eq (char-after (+ start
2)) ?x
)
1052 (n (string-to-number
1053 (buffer-substring-no-properties (+ start
(if (= base
16) 3 2))
1057 (xmltok-valid-char-p n
)
1060 (defun xmltok-unclosed-reparse-p (change-start
1066 (let ((len-1 (1- (length delimiter
))))
1067 (goto-char (max start
(- change-start len-1
)))
1068 (search-forward delimiter
(min end
(+ change-end len-1
)) t
)))
1070 ;; Handles a <!-- with the next -- not followed by >
1072 (defun xmltok-semi-closed-reparse-p (change-start
1079 (or (<= (- end delimiter-length
) change-end
)
1080 (xmltok-unclosed-reparse-p change-start
1087 (defun xmltok-valid-char-p (n)
1088 "Return non-nil if n is the Unicode code of a valid XML character."
1089 (cond ((< n
#x20
) (memq n
'(#xA
#xD
#x9
)))
1093 (t (and (> n
#xFFFF
)
1096 (defun xmltok-unicode-to-char (n)
1097 "Return the character corresponding to Unicode scalar value N.
1098 Return nil if unsupported in Emacs."
1099 (decode-char 'ucs n
))
1103 (defvar xmltok-contains-doctype nil
)
1104 (defvar xmltok-doctype-external-subset-flag nil
)
1105 (defvar xmltok-internal-subset-start nil
)
1106 (defvar xmltok-had-param-entity-ref nil
)
1107 (defvar xmltok-prolog-regions nil
)
1108 (defvar xmltok-standalone nil
1109 "Non-nil if there was an XML declaration specifying standalone=\"yes\",")
1110 (defvar xmltok-markup-declaration-doctype-flag nil
)
1112 (defconst xmltok-predefined-entity-alist
1117 ("quot" "\"" .
"\"")))
1119 (defun xmltok-forward-prolog ()
1120 "Move forward to the end of the XML prolog.
1122 Returns a list of vectors [TYPE START END] where TYPE is a symbol and
1123 START and END are integers giving the start and end of the region of
1124 that type. TYPE can be one of xml-declaration,
1125 xml-declaration-attribute-name, xml-declaration-attribute-value,
1126 comment, processing-instruction-left, processing-instruction-right,
1127 markup-declaration-open. markup-declaration-close,
1128 internal-subset-open, internal-subset-close, hash-name, keyword,
1129 literal, encoding-name.
1130 Adds to `xmltok-errors' and `xmltok-dependent-regions' as appropriate."
1131 (let ((case-fold-search nil
)
1134 xmltok-prolog-regions
1135 xmltok-contains-doctype
1136 xmltok-internal-subset-start
1137 xmltok-had-param-entity-ref
1139 xmltok-doctype-external-subset-flag
1140 xmltok-markup-declaration-doctype-flag
)
1141 (setq xmltok-dtd xmltok-predefined-entity-alist
)
1142 (xmltok-scan-xml-declaration)
1143 (xmltok-next-prolog-token)
1144 (while (condition-case err
1145 (when (xmltok-parse-prolog-item)
1146 (xmltok-next-prolog-token))
1147 (xmltok-markup-declaration-parse-error
1148 (xmltok-skip-markup-declaration))))
1149 (when xmltok-internal-subset-start
1150 (xmltok-add-error "No closing ]"
1151 (1- xmltok-internal-subset-start
)
1152 xmltok-internal-subset-start
))
1153 (xmltok-parse-entities)
1154 ;; XXX prune dependent-regions for those entirely in prolog
1155 (nreverse xmltok-prolog-regions
)))
1157 (defconst xmltok-bad-xml-decl-regexp
1158 "[ \t\r\n]*<\\?xml\\(?:[ \t\r\n]\\|\\?>\\)")
1161 (defun xmltok-get-declared-encoding-position (&optional limit
)
1162 "Return the position of the encoding in the XML declaration at point.
1163 If there is a well-formed XML declaration starting at point and it
1164 contains an encoding declaration, then return (START . END)
1165 where START and END are the positions of the start and the end
1166 of the encoding name; if there is no encoding declaration return
1167 the position where and encoding declaration could be inserted.
1168 If there is XML that is not well-formed that looks like an XML declaration,
1169 return nil. Otherwise, return t.
1170 If LIMIT is non-nil, then do not consider characters beyond LIMIT."
1171 (cond ((let ((case-fold-search nil
))
1172 (and (looking-at (xmltok-xml-declaration regexp
))
1173 (or (not limit
) (<= (match-end 0) limit
))))
1174 (let ((end (xmltok-xml-declaration end encoding-value
)))
1176 (cons (1+ (xmltok-xml-declaration start encoding-value
))
1178 (or (xmltok-xml-declaration end version-value
)
1180 ((not (let ((case-fold-search t
))
1181 (looking-at xmltok-bad-xml-decl-regexp
))))))
1183 (defun xmltok-scan-xml-declaration ()
1184 (when (looking-at (xmltok-xml-declaration regexp
))
1185 (xmltok-add-prolog-region 'xml-declaration
(point) (match-end 0))
1186 (goto-char (match-end 0))
1187 (when (xmltok-xml-declaration start version-name
)
1188 (xmltok-add-prolog-region 'xml-declaration-attribute-name
1189 (xmltok-xml-declaration start version-name
)
1190 (xmltok-xml-declaration end version-name
))
1191 (let ((start (xmltok-xml-declaration start version-value
))
1192 (end (xmltok-xml-declaration end version-value
)))
1193 (xmltok-add-prolog-region 'xml-declaration-attribute-value
1196 ;; XXX need to check encoding name
1197 ;; Should start with letter, not contain colon
1198 (when (xmltok-xml-declaration start encoding-name
)
1199 (xmltok-add-prolog-region 'xml-declaration-attribute-name
1200 (xmltok-xml-declaration start encoding-name
)
1201 (xmltok-xml-declaration end encoding-name
))
1202 (let ((start (xmltok-xml-declaration start encoding-value
))
1203 (end (xmltok-xml-declaration end encoding-value
)))
1204 (xmltok-add-prolog-region 'encoding-name
1207 (xmltok-add-prolog-region 'xml-declaration-attribute-value
1210 (when (xmltok-xml-declaration start standalone-name
)
1211 (xmltok-add-prolog-region 'xml-declaration-attribute-name
1212 (xmltok-xml-declaration start standalone-name
)
1213 (xmltok-xml-declaration end standalone-name
))
1214 (let ((start (xmltok-xml-declaration start standalone-value
))
1215 (end (xmltok-xml-declaration end standalone-value
)))
1216 (xmltok-add-prolog-region 'xml-declaration-attribute-value
1219 (setq xmltok-standalone
1220 (string= (buffer-substring-no-properties (1+ start
) (1- end
))
1224 (defconst xmltok-markup-declaration-alist
1225 '(("ELEMENT" . xmltok-parse-element-declaration
)
1226 ("ATTLIST" . xmltok-parse-attlist-declaration
)
1227 ("ENTITY" . xmltok-parse-entity-declaration
)
1228 ("NOTATION" . xmltok-parse-notation-declaration
)))
1230 (defun xmltok-parse-prolog-item ()
1231 (cond ((eq xmltok-type
'comment
)
1232 (xmltok-add-prolog-region 'comment
1236 ((eq xmltok-type
'processing-instruction
))
1237 ((eq xmltok-type
'named-markup-declaration
)
1238 (setq xmltok-markup-declaration-doctype-flag nil
)
1239 (xmltok-add-prolog-region 'markup-declaration-open
1242 (let* ((name (buffer-substring-no-properties
1245 (fun (cdr (assoc name xmltok-markup-declaration-alist
))))
1247 (unless xmltok-internal-subset-start
1249 "Declaration allowed only in internal subset"))
1251 ((string= name
"DOCTYPE")
1252 (xmltok-parse-doctype))
1254 (xmltok-add-error "Unknown markup declaration"
1256 (xmltok-next-prolog-token)
1257 (xmltok-markup-declaration-parse-error))))
1259 ((or (eq xmltok-type
'end-prolog
)
1262 ((eq xmltok-type
'internal-subset-close
)
1263 (xmltok-add-prolog-region 'internal-subset-close
1266 (xmltok-add-prolog-region 'markup-declaration-close
1269 (if xmltok-internal-subset-start
1270 (setq xmltok-internal-subset-start nil
)
1271 (xmltok-add-error "]> outside internal subset"))
1273 ((eq xmltok-type
'param-entity-ref
)
1274 (if xmltok-internal-subset-start
1275 (setq xmltok-had-param-entity-ref t
)
1276 (xmltok-add-error "Parameter entity reference outside document type declaration"))
1278 ;; If we don't do this, we can get thousands of errors when
1279 ;; a plain text file is parsed.
1280 ((not xmltok-internal-subset-start
)
1281 (when (let ((err (car xmltok-errors
)))
1283 (<= (xmltok-error-end err
) xmltok-start
)))
1284 (goto-char xmltok-start
))
1286 ((eq xmltok-type
'not-well-formed
) t
)
1288 (xmltok-add-error "Token allowed only inside markup declaration")
1291 (defun xmltok-parse-doctype ()
1292 (setq xmltok-markup-declaration-doctype-flag t
)
1293 (xmltok-next-prolog-token)
1294 (when xmltok-internal-subset-start
1295 (xmltok-add-error "DOCTYPE declaration not allowed in internal subset")
1296 (xmltok-markup-declaration-parse-error))
1297 (when xmltok-contains-doctype
1298 (xmltok-add-error "Duplicate DOCTYPE declaration")
1299 (xmltok-markup-declaration-parse-error))
1300 (setq xmltok-contains-doctype t
)
1301 (xmltok-require-token 'name
'prefixed-name
)
1302 (xmltok-require-next-token "SYSTEM" "PUBLIC" ?\
[ ?
>)
1303 (cond ((eq xmltok-type ?\
[)
1304 (setq xmltok-internal-subset-start
(point)))
1305 ((eq xmltok-type ?
>))
1307 (setq xmltok-doctype-external-subset-flag t
)
1308 (xmltok-parse-external-id)
1309 (xmltok-require-token ?\
[ ?
>)
1310 (when (eq xmltok-type ?\
[)
1311 (setq xmltok-internal-subset-start
(point))))))
1313 (defun xmltok-parse-attlist-declaration ()
1314 (xmltok-require-next-token 'prefixed-name
'name
)
1316 (xmltok-require-next-token ?
> 'name
'prefixed-name
)
1317 (if (eq xmltok-type ?
>)
1319 (xmltok-require-next-token ?\
(
1329 (cond ((eq xmltok-type ?\
()
1330 (xmltok-parse-nmtoken-group))
1331 ((string= (xmltok-current-token-string)
1333 (xmltok-require-next-token ?\
()
1334 (xmltok-parse-nmtoken-group)))
1335 (xmltok-require-next-token "#IMPLIED"
1339 (when (string= (xmltok-current-token-string) "#FIXED")
1340 (xmltok-require-next-token 'literal
))
1343 (defun xmltok-parse-nmtoken-group ()
1345 (xmltok-require-next-token 'nmtoken
'prefixed-name
'name
)
1346 (xmltok-require-next-token ?| ?\
))
1347 (eq xmltok-type ?|
))))
1349 (defun xmltok-parse-element-declaration ()
1350 (xmltok-require-next-token 'name
'prefixed-name
)
1351 (xmltok-require-next-token "EMPTY" "ANY" ?\
()
1352 (when (eq xmltok-type ?\
()
1353 (xmltok-require-next-token "#PCDATA"
1358 (cond ((eq xmltok-type
'hash-name
)
1359 (xmltok-require-next-token ?| ?\
) 'close-paren-star
)
1360 (while (eq xmltok-type ?|
)
1361 (xmltok-require-next-token 'name
'prefixed-name
)
1362 (xmltok-require-next-token 'close-paren-star ?|
)))
1363 (t (xmltok-parse-model-group))))
1364 (xmltok-require-next-token ?
>))
1366 (defun xmltok-parse-model-group ()
1367 (xmltok-parse-model-group-member)
1368 (xmltok-require-next-token ?|
1373 (when (memq xmltok-type
'(?
, ?|
))
1374 (let ((connector xmltok-type
))
1376 (xmltok-next-prolog-token)
1377 (xmltok-parse-model-group-member)
1378 (xmltok-require-next-token connector
1382 (eq xmltok-type connector
))))))
1384 (defun xmltok-parse-model-group-member ()
1385 (xmltok-require-token 'name
1389 (when (eq xmltok-type ?\
()
1390 (xmltok-next-prolog-token)
1391 (xmltok-parse-model-group)))
1393 (defun xmltok-parse-entity-declaration ()
1395 (xmltok-require-next-token 'name ?%
)
1396 (when (eq xmltok-type ?%
)
1398 (xmltok-require-next-token 'name
))
1399 (setq name
(xmltok-current-token-string))
1400 (xmltok-require-next-token 'literal
"SYSTEM" "PUBLIC")
1401 (cond ((eq xmltok-type
'literal
)
1402 (let ((replacement (xmltok-parse-entity-value)))
1404 (xmltok-define-entity name replacement
)))
1405 (xmltok-require-next-token ?
>))
1407 (xmltok-parse-external-id)
1409 (xmltok-require-token ?
>)
1410 (xmltok-require-token ?
> "NDATA")
1411 (if (eq xmltok-type ?
>)
1412 (xmltok-define-entity name
'external
)
1413 (xmltok-require-next-token 'name
)
1414 (xmltok-require-next-token ?
>)
1415 (xmltok-define-entity name
'unparsed
)))))))
1417 (defun xmltok-define-entity (name value
)
1418 (when (and (or (not xmltok-had-param-entity-ref
)
1420 (not (assoc name xmltok-dtd
)))
1422 (cons (cons name value
) xmltok-dtd
))))
1424 (defun xmltok-parse-entity-value ()
1425 (let ((lim (1- (point)))
1430 (goto-char (1+ xmltok-start
))
1431 (setq start
(point))
1433 (skip-chars-forward "^%&" lim
)
1434 (when (< (point) lim
)
1435 (goto-char (1+ (point)))
1436 (cond ((eq (char-before) ?%
)
1437 (xmltok-add-error "Parameter entity references are not allowed in the internal subset"
1440 (setq well-formed nil
))
1442 (let ((xmltok-start (1- (point)))
1443 xmltok-type xmltok-replacement
)
1444 (xmltok-scan-after-amp (lambda (start end
)))
1445 (cond ((eq xmltok-type
'char-ref
)
1447 (cons (buffer-substring-no-properties
1452 (cons xmltok-replacement
1454 (setq start
(point)))
1455 ((eq xmltok-type
'not-well-formed
)
1456 (setq well-formed nil
))))))
1458 (if (not well-formed
)
1461 (nreverse (cons (buffer-substring-no-properties start lim
)
1464 (defun xmltok-parse-notation-declaration ()
1465 (xmltok-require-next-token 'name
)
1466 (xmltok-require-next-token "SYSTEM" "PUBLIC")
1467 (let ((publicp (string= (xmltok-current-token-string) "PUBLIC")))
1468 (xmltok-require-next-token 'literal
)
1470 (xmltok-require-next-token 'literal ?
>)
1471 (unless (eq xmltok-type ?
>)
1472 (xmltok-require-next-token ?
>)))
1473 (t (xmltok-require-next-token ?
>)))))
1475 (defun xmltok-parse-external-id ()
1476 (xmltok-require-token "SYSTEM" "PUBLIC")
1477 (let ((publicp (string= (xmltok-current-token-string) "PUBLIC")))
1478 (xmltok-require-next-token 'literal
)
1480 (xmltok-require-next-token 'literal
)))
1481 (xmltok-next-prolog-token))
1483 (defun xmltok-require-next-token (&rest types
)
1484 (xmltok-next-prolog-token)
1485 (apply 'xmltok-require-token types
))
1487 (defun xmltok-require-token (&rest types
)
1488 ;; XXX Generate a more helpful error message
1489 (while (and (not (let ((type (car types
)))
1490 (if (stringp (car types
))
1491 (string= (xmltok-current-token-string) type
)
1492 (eq type xmltok-type
))))
1493 (setq types
(cdr types
))))
1495 (when (and xmltok-type
1496 (not (eq xmltok-type
'not-well-formed
)))
1497 (xmltok-add-error "Unexpected token"))
1498 (xmltok-markup-declaration-parse-error))
1499 (let ((region-type (xmltok-prolog-region-type (car types
))))
1501 (xmltok-add-prolog-region region-type
1505 (defun xmltok-current-token-string ()
1506 (buffer-substring-no-properties xmltok-start
(point)))
1508 (put 'xmltok-markup-declaration-parse-error
1510 '(error xmltok-markup-declaration-parse-error
))
1512 (put 'xmltok-markup-declaration-parse-error
1514 "Syntax error in markup declaration")
1516 (defun xmltok-markup-declaration-parse-error ()
1517 (signal 'xmltok-markup-declaration-parse-error nil
))
1519 (defun xmltok-skip-markup-declaration ()
1520 (while (cond ((eq xmltok-type ?
>)
1521 (xmltok-next-prolog-token)
1523 ((and xmltok-markup-declaration-doctype-flag
1524 (eq xmltok-type ?\
[))
1525 (setq xmltok-internal-subset-start
(point))
1526 (xmltok-next-prolog-token)
1528 ((memq xmltok-type
'(nil
1530 named-markup-declaration
1532 processing-instruction
))
1534 ((and xmltok-internal-subset-start
1535 (eq xmltok-type
'internal-subset-close
))
1537 (t (xmltok-next-prolog-token) t
)))
1540 (defun xmltok-prolog-region-type (required)
1541 (cond ((cdr (assq xmltok-type
1542 '((literal . literal
)
1543 (?
> . markup-declaration-close
)
1544 (?\
[ . internal-subset-open
)
1545 (hash-name . hash-name
)))))
1546 ((and (stringp required
) (eq xmltok-type
'name
))
1549 ;; Return new token type.
1551 (defun xmltok-next-prolog-token ()
1552 (skip-chars-forward " \t\r\n")
1553 (setq xmltok-start
(point))
1554 (cond ((not (and (looking-at (xmltok-prolog regexp
))
1555 (goto-char (match-end 0))))
1556 (let ((ch (char-after)))
1558 (goto-char (1+ (point)))
1559 (xmltok-add-error "Illegal char in prolog")
1560 (setq xmltok-type
'not-well-formed
))
1561 (t (setq xmltok-type nil
)))))
1562 ((or (xmltok-prolog start ncname-occur
)
1563 (xmltok-prolog start colon-name-occur
))
1564 (setq xmltok-name-end
(1- (point)))
1565 (setq xmltok-name-colon
(xmltok-prolog start colon
))
1566 (setq xmltok-type
'name-occur
))
1567 ((xmltok-prolog start colon
)
1568 (setq xmltok-name-end
(point))
1569 (setq xmltok-name-colon
(xmltok-prolog start colon
))
1570 (unless (looking-at "[ \t\r\n>),|[%]")
1571 (xmltok-add-error "Missing space after name"))
1572 (setq xmltok-type
'prefixed-name
))
1573 ((or (xmltok-prolog start ncname-nmtoken
)
1574 (xmltok-prolog start ncname-colon
))
1575 (unless (looking-at "[ \t\r\n>),|[%]")
1576 (xmltok-add-error "Missing space after name token"))
1577 (setq xmltok-type
'nmtoken
))
1578 ((xmltok-prolog start name
)
1579 (setq xmltok-name-end
(point))
1580 (setq xmltok-name-colon nil
)
1581 (unless (looking-at "[ \t\r\n>),|[%]")
1582 (xmltok-add-error "Missing space after name"))
1583 (setq xmltok-type
'name
))
1584 ((xmltok-prolog start hash-name
)
1585 (setq xmltok-name-end
(point))
1586 (unless (looking-at "[ \t\r\n>)|%]")
1587 (xmltok-add-error "Missing space after name"))
1588 (setq xmltok-type
'hash-name
))
1589 ((xmltok-prolog start processing-instruction-question
)
1590 (xmltok-scan-prolog-after-processing-instruction-open))
1591 ((xmltok-prolog start comment-open
)
1592 ;; XXX if not-well-formed, ignore some stuff
1593 (xmltok-scan-after-comment-open))
1594 ((xmltok-prolog start named-markup-declaration
)
1595 (setq xmltok-type
'named-markup-declaration
))
1596 ((xmltok-prolog start instance-start
)
1597 (goto-char xmltok-start
)
1598 (setq xmltok-type
'end-prolog
))
1599 ((xmltok-prolog start close-paren-star
)
1600 (setq xmltok-type
'close-paren-star
))
1601 ((xmltok-prolog start close-paren-occur
)
1602 (setq xmltok-type
'close-paren-occur
))
1603 ((xmltok-prolog start close-paren
)
1604 (unless (looking-at "[ \t\r\n>,|)]")
1605 (xmltok-add-error "Missing space after )"))
1606 (setq xmltok-type ?\
)))
1607 ((xmltok-prolog start single-char
)
1608 (let ((ch (char-before)))
1609 (cond ((memq ch
'(?
\" ?
\'))
1610 (xmltok-scan-prolog-literal))
1611 (t (setq xmltok-type ch
)))))
1612 ((xmltok-prolog start percent
)
1613 (cond ((xmltok-prolog start param-entity-ref-close
)
1614 (setq xmltok-name-end
(1- (point)))
1615 (setq xmltok-type
'param-entity-ref
))
1616 ((xmltok-prolog start param-entity-ref
)
1617 (xmltok-add-error "Missing ;")
1618 (setq xmltok-name-end
(point))
1619 (setq xmltok-type
'param-entity-ref
))
1620 ((looking-at "[ \t\r\n%]")
1621 (setq xmltok-type ?%
))
1623 (xmltok-add-error "Expected name after %")
1624 (setq xmltok-type
'not-well-formed
))))
1625 ((xmltok-prolog start nmtoken
)
1626 (unless (looking-at "[ \t\r\n>),|[%]")
1627 (xmltok-add-error "Missing space after name token"))
1628 (setq xmltok-type
'nmtoken
))
1629 ((xmltok-prolog start internal-subset-close
)
1630 (setq xmltok-type
'internal-subset-close
))
1631 ((xmltok-prolog start pound
)
1632 (xmltok-add-error "Expected name after #")
1633 (setq xmltok-type
'not-well-formed
))
1634 ((xmltok-prolog start markup-declaration
)
1635 (xmltok-add-error "Expected name or -- after <!")
1636 (setq xmltok-type
'not-well-formed
))
1637 ((xmltok-prolog start comment-first-dash
)
1638 (xmltok-add-error "Expected <!--")
1639 (setq xmltok-type
'not-well-formed
))
1640 ((xmltok-prolog start less-than
)
1641 (xmltok-add-error "Incomplete markup")
1642 (setq xmltok-type
'not-well-formed
))
1643 (t (error "Unhandled token in prolog %s"
1644 (match-string-no-properties 0)))))
1646 (defun xmltok-scan-prolog-literal ()
1647 (let* ((delim (string (char-before)))
1648 (safe-end (save-excursion
1649 (skip-chars-forward (concat "^<>[]" delim
))
1651 (end (save-excursion
1652 (goto-char safe-end
)
1653 (search-forward delim nil t
))))
1654 (or (cond ((not end
)
1655 (xmltok-add-dependent 'xmltok-unclosed-reparse-p
1662 (looking-at "[ \t\r\n>%[]"))
1664 (setq xmltok-type
'literal
))
1665 ((eq (1+ safe-end
) end
)
1667 (xmltok-add-error (format "Missing space after %s" delim
)
1669 (setq xmltok-type
'literal
))
1671 (xmltok-add-dependent 'xmltok-semi-closed-reparse-p
1678 (xmltok-add-error (format "Missing closing %s" delim
))
1679 (goto-char safe-end
)
1680 (skip-chars-backward " \t\r\n")
1681 (setq xmltok-type
'not-well-formed
)))))
1683 (defun xmltok-scan-prolog-after-processing-instruction-open ()
1684 (cond ((not (search-forward "?>" nil t
))
1685 (xmltok-add-error "No closing ?>"
1688 (xmltok-add-dependent 'xmltok-unclosed-reparse-p
1692 (setq xmltok-type
'not-well-formed
))
1694 (let* ((end (point))
1697 (goto-char (+ xmltok-start
2))
1698 (and (looking-at (xmltok-ncname regexp
))
1699 (or (memq (char-after (match-end 0))
1701 (= (match-end 0) (- end
2)))
1702 (match-string-no-properties 0)))))
1704 (xmltok-add-error "\
1705 Processing instruction does not start with a name"
1707 (+ xmltok-start
3)))
1708 ((not (and (= (length target
) 3)
1709 (let ((case-fold-search t
))
1710 (string-match "xml" target
)))))
1712 (xmltok-add-error "Invalid XML declaration"
1716 (goto-char xmltok-start
)
1717 (looking-at (xmltok-xml-declaration regexp
)))
1718 (xmltok-add-error "XML declaration not at beginning of file"
1722 (xmltok-add-error "Processing instruction has target of xml"
1724 (+ xmltok-start
5))))
1725 (xmltok-add-prolog-region 'processing-instruction-left
1732 (xmltok-add-prolog-region 'processing-instruction-right
1735 (goto-char (+ xmltok-start
1738 (skip-chars-forward " \t\r\n")
1742 (setq xmltok-type
'processing-instruction
))))
1744 (defun xmltok-parse-entities ()
1745 (let ((todo xmltok-dtd
))
1746 (when (and (or xmltok-had-param-entity-ref
1747 xmltok-doctype-external-subset-flag
)
1748 (not xmltok-standalone
))
1749 (setq xmltok-dtd
(cons t xmltok-dtd
)))
1751 (xmltok-parse-entity (car todo
))
1752 (setq todo
(cdr todo
)))))
1754 (defun xmltok-parse-entity (name-def)
1755 (let ((def (cdr name-def
))
1756 ;; in case its value is buffer local
1757 (xmltok-dtd xmltok-dtd
)
1760 (if (string-match "\\`[^&<\t\r\n]*\\'" def
)
1761 (setcdr name-def
(cons def def
))
1762 (setcdr name-def
'not-well-formed
) ; avoid infinite expansion loops
1763 (setq buf
(get-buffer-create
1764 (format " *Entity %s*" (car name-def
))))
1769 (goto-char (point-min))
1771 (xmltok-parse-entity-replacement)))
1772 (kill-buffer buf
)))))
1774 (defun xmltok-parse-entity-replacement ()
1775 (let ((def (cons "" "")))
1776 (while (let* ((start (point))
1777 (found (re-search-forward "[<&\t\r\n]\\|]]>" nil t
))
1778 (ch (and found
(char-before)))
1779 (str (buffer-substring-no-properties
1785 (xmltok-append-entity-def def
1787 (cond ((not found
) nil
)
1789 (setq def
'not-well-formed
)
1793 (setq xmltok-start
(1- (point)))
1794 (xmltok-scan-after-lt)
1796 (xmltok-append-entity-def
1798 (cond ((memq xmltok-type
1805 processing-instruction
))
1809 (cons (buffer-substring-no-properties
1813 (t 'not-well-formed
)))))
1816 (let ((xmltok-start (1- (point)))
1820 (xmltok-scan-after-amp 'xmltok-handle-nested-entity
)
1821 (cond ((eq xmltok-type
'entity-ref
)
1823 (xmltok-append-entity-def
1825 xmltok-replacement
)))
1826 ((eq xmltok-type
'char-ref
)
1828 (xmltok-append-entity-def
1830 (if xmltok-replacement
1831 (cons xmltok-replacement
1833 (and xmltok-errors
'not-well-formed
)))))
1835 (setq def
'not-well-formed
))))
1839 (xmltok-append-entity-def
1841 (cons (match-string-no-properties 0)
1846 (defun xmltok-handle-nested-entity (start end
)
1847 (let* ((name-def (assoc (buffer-substring-no-properties start end
)
1849 (def (cdr name-def
)))
1851 (xmltok-parse-entity name-def
)
1852 (setq def
(cdr name-def
)))
1853 (setq xmltok-replacement
1854 (cond ((null name-def
)
1855 (if (eq (car xmltok-dtd
) t
)
1858 ((eq def
'unparsed
) 'not-well-formed
)
1861 (defun xmltok-append-entity-def (d1 d2
)
1864 (cons (concat (car d1
) (car d2
))
1867 (concat (cdr d1
) (cdr d2
))))
1871 (let ((defs '(not-well-formed external element
)))
1872 (while (not (or (eq (car defs
) d1
)
1873 (eq (car defs
) d2
)))
1874 (setq defs
(cdr defs
)))
1877 (defun xmltok-add-prolog-region (type start end
)
1878 (setq xmltok-prolog-regions
1879 (cons (vector type start end
)
1880 xmltok-prolog-regions
)))
1882 (defun xmltok-merge-attributes ()
1883 "Return a list merging `xmltok-attributes' and 'xmltok-namespace-attributes'.
1884 The members of the merged list are in order of occurrence in the
1885 document. The list may share list structure with `xmltok-attributes'
1886 and `xmltok-namespace-attributes'."
1887 (cond ((not xmltok-namespace-attributes
)
1889 ((not xmltok-attributes
)
1890 xmltok-namespace-attributes
)
1892 (let ((atts1 xmltok-attributes
)
1893 (atts2 xmltok-namespace-attributes
)
1895 (while (and atts1 atts2
)
1896 (cond ((< (xmltok-attribute-name-start (car atts1
))
1897 (xmltok-attribute-name-start (car atts2
)))
1898 (setq merged
(cons (car atts1
) merged
))
1899 (setq atts1
(cdr atts1
)))
1901 (setq merged
(cons (car atts2
) merged
))
1902 (setq atts2
(cdr atts2
)))))
1903 (setq merged
(nreverse merged
))
1904 (cond (atts1 (setq merged
(nconc merged atts1
)))
1905 (atts2 (setq merged
(nconc merged atts2
))))
1910 (defun xmltok-forward-test ()
1912 (if (xmltok-forward)
1913 (message "Scanned %s" xmltok-type
)
1914 (message "Scanned nothing")))
1916 (defun xmltok-next-prolog-token-test ()
1918 (if (xmltok-next-prolog-token)
1919 (message "Scanned %s"
1920 (if (integerp xmltok-type
)
1921 (string xmltok-type
)
1923 (message "Scanned end of file")))
1927 ;; arch-tag: 747e5f3a-6fc3-4f8d-bd96-89f05aa99f5e
1928 ;;; xmltok.el ends here