Avoid segfaults when some display vector is an empty string
[emacs.git] / lisp / nxml / xmltok.el
blob69dc541bc512caa0f1cf6b8b7d12f3b4e5bc2d7c
1 ;;; xmltok.el --- XML tokenization -*- lexical-binding:t -*-
3 ;; Copyright (C) 2003, 2007-2017 Free Software Foundation, Inc.
5 ;; Author: James Clark
6 ;; Keywords: wp, hypermedia, languages, XML
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 of the License, or
13 ;; (at your option) any later version.
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. If not, see <http://www.gnu.org/licenses/>.
23 ;;; Commentary:
25 ;; This implements an XML 1.0 parser. It also implements the XML
26 ;; Namespaces Recommendation. It is designed to be conforming, but it
27 ;; works a bit differently from a normal XML parser. An XML document
28 ;; consists of the prolog and an instance. The prolog is parsed as a
29 ;; single unit using `xmltok-forward-prolog'. The instance is
30 ;; considered as a sequence of tokens, where a token is something like
31 ;; a start-tag, a comment, a chunk of data or a CDATA section. The
32 ;; tokenization of the instance is stateless: the tokenization of one
33 ;; part of the instance does not depend on tokenization of the
34 ;; preceding part of the instance. This allows the instance to be
35 ;; parsed incrementally. The main entry point is `xmltok-forward':
36 ;; this can be called at any point in the instance provided it is
37 ;; between tokens.
39 ;; This is a non-validating XML 1.0 processor. It does not resolve
40 ;; parameter entities (including the external DTD subset) and it does
41 ;; not resolve external general entities.
43 ;; It is non-conformant by design in the following respects.
45 ;; 1. It expects the client to detect aspects of well-formedness that
46 ;; are not internal to a single token, specifically checking that
47 ;; end-tags match start-tags and that the instance contains exactly
48 ;; one element.
50 ;; 2. It expects the client to detect duplicate attributes. Detection
51 ;; of duplicate attributes after expansion of namespace prefixes
52 ;; requires the namespace processing state. Detection of duplicate
53 ;; attributes before expansion of namespace prefixes does not, but is
54 ;; redundant given that the client will do detection of duplicate
55 ;; attributes after expansion of namespace prefixes.
57 ;; 3. It allows the client to recover from well-formedness errors.
58 ;; This is essential for use in applications where the document is
59 ;; being parsed during the editing process.
61 ;; 4. It does not support documents that do not conform to the lexical
62 ;; requirements of the XML Namespaces Recommendation (e.g. a document
63 ;; with a colon in an entity name).
65 ;; There are also a number of things that have not yet been
66 ;; implemented that make it non-conformant.
68 ;; 1. It does not implement default attributes. ATTLIST declarations
69 ;; are parsed, but no checking is done on the content of attribute
70 ;; value literals specifying default attribute values, and default
71 ;; attribute values are not reported to the client.
73 ;; 2. It does not implement internal entities containing elements. If
74 ;; an internal entity is referenced and parsing its replacement text
75 ;; yields one or more tags, then it will skip the reference and
76 ;; report this to the client.
78 ;; 3. It does not check the syntax of public identifiers in the DTD.
80 ;; 4. It allows some non-ASCII characters in certain situations where
81 ;; it should not. For example, it only enforces XML 1.0's
82 ;; restrictions on name characters strictly for ASCII characters. The
83 ;; problem here is XML's character model is based squarely on Unicode,
84 ;; whereas Emacs's is not (as of version 21). It is not clear what
85 ;; the right thing to do is.
87 ;;; Code:
89 (defvar xmltok-type nil)
90 (defvar xmltok-start nil)
91 (defvar xmltok-name-colon nil)
92 (defvar xmltok-name-end nil)
93 (defvar xmltok-replacement nil
94 "String containing replacement for a character or entity reference.")
96 (defvar xmltok-attributes nil
97 "List containing attributes of last scanned element.
98 Each member of the list is a vector representing an attribute, which
99 can be accessed using the functions `xmltok-attribute-name-start',
100 `xmltok-attribute-name-colon', `xmltok-attribute-name-end',
101 `xmltok-attribute-value-start', `xmltok-attribute-value-end',
102 `xmltok-attribute-raw-normalized-value', `xmltok-attribute-refs'.")
104 (defvar xmltok-namespace-attributes nil
105 "List containing namespace declarations of last scanned element.
106 List has same format as `xmltok-attributes'.")
108 (defvar xmltok-dtd nil
109 "Information about the DTD used by `xmltok-forward'.
110 `xmltok-forward-prolog' sets this up.
112 It consists of an alist of general entity names vs definitions. The
113 first member of the alist is t if references to entities not in the
114 alist are well-formed \(e.g. because there's an external subset that
115 wasn't parsed).
117 Each general entity name is a string. The definition is either nil,
118 a symbol, a string, a cons cell. If the definition is nil, then it
119 means that it's an internal entity but the result of parsing it is
120 unknown. If it is a symbol, then the symbol is either `unparsed',
121 meaning the entity is an unparsed entity, `external', meaning the
122 entity is or references an external entity, `element', meaning the
123 entity includes one or more elements, or `not-well-formed', meaning
124 the replacement text is not well-formed. If the definition is a
125 string, then the replacement text of the entity is that string; this
126 happens only during the parsing of the prolog. If the definition is
127 a cons cell \(ER . AR), then ER specifies the string that results
128 from referencing the entity in element content and AR is either nil,
129 meaning the replacement text included a <, or a string which is the
130 normalized attribute value.")
133 (defvar xmltok-errors nil
134 "List of errors detected by `xmltok-forward' and `xmltok-forward-prolog'.
135 When `xmltok-forward' and `xmltok-forward-prolog' detect a
136 well-formedness error, they will add an entry to the beginning of this
137 list. Each entry is a vector [MESSAGE START END], where MESSAGE is a
138 string giving the error message and START and END are integers
139 indicating the position of the error.")
141 (defmacro xmltok-save (&rest body)
142 (declare (indent 0) (debug t))
143 `(let (xmltok-type
144 xmltok-start
145 xmltok-name-colon
146 xmltok-name-end
147 xmltok-replacement
148 xmltok-attributes
149 xmltok-namespace-attributes
150 xmltok-errors)
151 ,@body))
153 (defsubst xmltok-attribute-name-start (att)
154 (aref att 0))
156 (defsubst xmltok-attribute-name-colon (att)
157 (aref att 1))
159 (defsubst xmltok-attribute-name-end (att)
160 (aref att 2))
162 (defsubst xmltok-attribute-value-start (att)
163 (aref att 3))
165 (defsubst xmltok-attribute-value-end (att)
166 (aref att 4))
168 (defsubst xmltok-attribute-raw-normalized-value (att)
169 "Return an object representing the normalized value of ATT.
170 This can be t indicating that the normalized value is the same as
171 the buffer substring from the start to the end of the value, or nil
172 indicating that the value is not well-formed or a string."
173 (aref att 5))
175 (defsubst xmltok-attribute-refs (att)
176 "Return a list of the entity and character references in ATT.
177 Each member is a vector [TYPE START END] where TYPE is either char-ref
178 or entity-ref and START and END are integers giving the start and end of
179 the reference. Nested entity references are not included in the list."
180 (aref att 6))
182 (defun xmltok-attribute-prefix (att)
183 (let ((colon (xmltok-attribute-name-colon att)))
184 (and colon
185 (buffer-substring-no-properties (xmltok-attribute-name-start att)
186 colon))))
188 (defun xmltok-attribute-local-name (att)
189 (let ((colon (xmltok-attribute-name-colon att)))
190 (buffer-substring-no-properties (if colon
191 (1+ colon)
192 (xmltok-attribute-name-start att))
193 (xmltok-attribute-name-end att))))
195 (defun xmltok-attribute-value (att)
196 (let ((rnv (xmltok-attribute-raw-normalized-value att)))
197 (and rnv
198 (if (stringp rnv)
200 (buffer-substring-no-properties (xmltok-attribute-value-start att)
201 (xmltok-attribute-value-end att))))))
203 (defun xmltok-start-tag-prefix ()
204 (and xmltok-name-colon
205 (buffer-substring-no-properties (1+ xmltok-start)
206 xmltok-name-colon)))
208 (defun xmltok-start-tag-local-name ()
209 (buffer-substring-no-properties (1+ (or xmltok-name-colon
210 xmltok-start))
211 xmltok-name-end))
213 (defun xmltok-end-tag-prefix ()
214 (and xmltok-name-colon
215 (buffer-substring-no-properties (+ 2 xmltok-start)
216 xmltok-name-colon)))
218 (defun xmltok-end-tag-local-name ()
219 (buffer-substring-no-properties (if xmltok-name-colon
220 (1+ xmltok-name-colon)
221 (+ 2 xmltok-start))
222 xmltok-name-end))
224 (defun xmltok-start-tag-qname ()
225 (buffer-substring-no-properties (+ xmltok-start 1) xmltok-name-end))
227 (defun xmltok-end-tag-qname ()
228 (buffer-substring-no-properties (+ xmltok-start 2) xmltok-name-end))
230 (defsubst xmltok-make-attribute (name-begin
231 name-colon
232 name-end
233 &optional
234 value-begin
235 value-end
236 raw-normalized-value)
237 "Make an attribute.
238 RAW-NORMALIZED-VALUE is nil if the value is not well-formed,
239 t if the normalized value is the string between VALUE-BEGIN
240 and VALUE-END, otherwise a STRING giving the value."
241 (vector name-begin
242 name-colon
243 name-end
244 value-begin
245 value-end
246 raw-normalized-value
247 nil))
249 (defsubst xmltok-error-message (err)
250 (aref err 0))
252 (defsubst xmltok-error-start (err)
253 (aref err 1))
255 (defsubst xmltok-error-end (err)
256 (aref err 2))
258 (defsubst xmltok-make-error (message start end)
259 (vector message start end))
261 (defun xmltok-add-error (message &optional start end)
262 (push (xmltok-make-error message
263 (or start xmltok-start)
264 (or end (point)))
265 xmltok-errors))
267 (defun xmltok-forward ()
268 (setq xmltok-start (point))
269 (let* ((case-fold-search nil)
270 (space-count (skip-chars-forward " \t\r\n"))
271 (ch (char-after)))
272 (cond ((eq ch ?\<)
273 (cond ((> space-count 0)
274 (setq xmltok-type 'space))
276 (forward-char 1)
277 (xmltok-scan-after-lt))))
278 ((eq ch ?\&)
279 (cond ((> space-count 0)
280 (setq xmltok-type 'space))
282 (forward-char 1)
283 (xmltok-scan-after-amp 'xmltok-handle-entity))))
284 ((re-search-forward "[<&]\\|\\(]]>\\)" nil t)
285 (cond ((not (match-beginning 1))
286 (goto-char (match-beginning 0))
287 ;; must have got a non-space char
288 (setq xmltok-type 'data))
289 ((= (match-beginning 1) xmltok-start)
290 (xmltok-add-error "Found `]]>' not closing a CDATA section")
291 (setq xmltok-type 'not-well-formed))
293 (goto-char (match-beginning 0))
294 (setq xmltok-type
295 (if (= (point) (+ xmltok-start space-count))
296 'space
297 'data)))))
298 ((eq ch nil)
299 (setq xmltok-type
300 (if (> space-count 0)
301 'space
302 nil)))
304 (goto-char (point-max))
305 (setq xmltok-type 'data)))))
307 (eval-when-compile
309 ;; A symbolic regexp is represented by a list whose CAR is the string
310 ;; containing the regexp and whose cdr is a list of symbolic names
311 ;; for the groups in the string.
313 ;; Construct a symbolic regexp from a regexp.
314 (defun xmltok-r (str)
315 (cons str nil))
317 ;; Concatenate zero of more regexps and symbolic regexps.
318 (defun xmltok+ (&rest args)
319 (let (strs names)
320 (while args
321 (let ((arg (car args)))
322 (if (stringp arg)
323 (setq strs (cons arg strs))
324 (setq strs (cons (car arg) strs))
325 (setq names (cons (cdr arg) names)))
326 (setq args (cdr args))))
327 (cons (apply 'concat (nreverse strs))
328 (apply 'append (nreverse names))))))
330 (eval-when-compile
331 ;; Make a symbolic group named NAME from the regexp R.
332 ;; R may be a symbolic regexp or an ordinary regexp.
333 (defmacro xmltok-g (name &rest r)
334 (let ((sym (make-symbol "r")))
335 `(let ((,sym (xmltok+ ,@r)))
336 (if (stringp ,sym)
337 (cons (concat "\\(" ,sym "\\)") (cons ',name nil))
338 (cons (concat "\\(" (car ,sym) "\\)") (cons ',name (cdr ,sym)))))))
340 (defun xmltok-p (&rest r) (xmltok+ "\\(?:"
341 (apply 'xmltok+ r)
342 "\\)"))
344 ;; Get the group index of ELEM in a LIST of symbols.
345 (defun xmltok-get-index (elem list)
346 (or elem
347 (error "Missing group name"))
348 (let ((found nil)
349 (i 1))
350 (while list
351 (cond ((eq elem (car list))
352 (setq found i)
353 (setq list nil))
355 (setq i (1+ i))
356 (setq list (cdr list)))))
357 (or found
358 (error "Bad group name %s" elem))))
360 ;; Define a macro SYM using a symbolic regexp R.
361 ;; SYM can be called in three ways:
362 ;; (SYM regexp)
363 ;; expands to the regexp in R
364 ;; (SYM start G)
365 ;; expands to
366 ;; (match-beginning N)
367 ;; where N is the group index of G in R.
368 ;; (SYM end G)
369 ;; expands to
370 ;; (match-end N)
371 ;; where N is the group index of G in R.
372 (defmacro xmltok-defregexp (sym r)
373 `(defalias ',sym
374 (let ((r ,r))
375 `(macro lambda (action &optional group-name)
376 (cond ((eq action 'regexp)
377 ,(car r))
378 ((or (eq action 'start) (eq action 'beginning))
379 (list 'match-beginning (xmltok-get-index group-name
380 ',(cdr r))))
381 ((eq action 'end)
382 (list 'match-end (xmltok-get-index group-name
383 ',(cdr r))))
384 ((eq action 'string)
385 (list 'match-string
386 (xmltok-get-index group-name ',(cdr r))))
387 ((eq action 'string-no-properties)
388 (list 'match-string-no-properties
389 (xmltok-get-index group-name ',(cdr r))))
390 (t (error "Invalid action: %s" action))))))))
393 (eval-when-compile
394 (let* ((or "\\|")
395 (open "\\(?:")
396 (close "\\)")
397 (name-start-char "[_[:alpha:]]")
398 (name-continue-not-start-char "[-.[:digit:]]")
399 (name-continue-char "[-._[:alnum:]]")
400 (* "*")
401 (+ "+")
402 (opt "?")
403 (question "\\?")
404 (s "[ \r\t\n]")
405 (s+ (concat s +))
406 (s* (concat s *))
407 (ncname (concat name-start-char name-continue-char *))
408 (entity-ref
409 (xmltok+ (xmltok-g entity-name ncname)
410 (xmltok-g entity-ref-close ";") opt))
411 (decimal-ref
412 (xmltok+ (xmltok-g decimal "[0-9]" +)
413 (xmltok-g decimal-ref-close ";") opt))
414 (hex-ref
415 (xmltok+ "x" open
416 (xmltok-g hex "[0-9a-fA-F]" +)
417 (xmltok-g hex-ref-close ";") opt
418 close opt))
419 (char-ref
420 (xmltok+ (xmltok-g number-sign "#")
421 open decimal-ref or hex-ref close opt))
422 (start-tag-close
423 (xmltok+ open (xmltok-g start-tag-close s* ">")
424 or open (xmltok-g empty-tag-slash s* "/")
425 (xmltok-g empty-tag-close ">") opt close
426 or (xmltok-g start-tag-s s+)
427 close))
428 (start-tag
429 (xmltok+ (xmltok-g start-tag-name
430 ncname (xmltok-g start-tag-colon ":" ncname) opt)
431 start-tag-close opt))
432 (end-tag
433 (xmltok+ (xmltok-g end-tag-slash "/")
434 open (xmltok-g end-tag-name
435 ncname
436 (xmltok-g end-tag-colon ":" ncname) opt)
437 (xmltok-g end-tag-close s* ">") opt
438 close opt))
439 (comment
440 (xmltok+ (xmltok-g markup-declaration "!")
441 (xmltok-g comment-first-dash "-"
442 (xmltok-g comment-open "-") opt) opt))
443 (cdata-section
444 (xmltok+ "!"
445 (xmltok-g marked-section-open "\\[")
446 open "C"
447 open "D"
448 open "A"
449 open "T"
450 open "A"
451 (xmltok-g cdata-section-open "\\[" ) opt
452 close opt ; A
453 close opt ; T
454 close opt ; A
455 close opt ; D
456 close opt)) ; C
457 (processing-instruction
458 (xmltok-g processing-instruction-question question)))
460 (xmltok-defregexp xmltok-ncname (xmltok+ open ncname close))
462 (xmltok-defregexp xmltok-after-amp
463 (xmltok+ entity-ref or char-ref))
464 (xmltok-defregexp xmltok-after-lt
465 (xmltok+ start-tag
466 or end-tag
467 ;; cdata-section must come before comment
468 ;; because we treat <! as a comment
469 ;; and Emacs doesn't do fully greedy matching
470 ;; by default
471 or cdata-section
472 or comment
473 or processing-instruction))
474 (xmltok-defregexp
475 xmltok-attribute
476 (let* ((lit1
477 (xmltok+ "'"
478 "[^<'&\r\n\t]*"
479 (xmltok-g complex1 "[&\r\n\t][^<']*") opt
480 "'"))
481 (lit2 (cons (replace-regexp-in-string "'" "\"" (car lit1))
482 '(complex2)))
483 (literal (xmltok-g literal lit1 or lit2))
484 (name (xmltok+ open (xmltok-g xmlns "xmlns") or ncname close
485 (xmltok-g colon ":" ncname) opt)))
486 (xmltok+ (xmltok-g name name)
487 s* "="
488 ;; If the literal isn't followed by what it should be,
489 ;; then the closing delimiter is probably really the
490 ;; opening delimiter of another literal, so don't
491 ;; absorb the literal in this case.
492 open s* literal start-tag-close close opt)))
493 (xmltok-defregexp
494 xmltok-xml-declaration
495 (let* ((literal-content "[-._:a-zA-Z0-9]+")
496 (literal
497 (concat open "\"" literal-content "\""
498 or "'" literal-content "'" close))
499 (version-att
500 (xmltok+ open
501 s+ (xmltok-g version-name "version")
502 s* "="
503 s* (xmltok-g version-value literal)
504 close opt))
505 (encoding-att
506 (xmltok+ open
507 s+ (xmltok-g encoding-name "encoding")
508 s* "="
509 s* (xmltok-g encoding-value literal)
510 close opt))
511 (yes-no
512 (concat open "yes" or "no" close))
513 (standalone-att
514 (xmltok+ open
515 s+ (xmltok-g standalone-name "standalone")
516 s* "="
517 s* (xmltok-g standalone-value
518 "\"" yes-no "\"" or "'" yes-no "'")
519 close opt)))
520 (xmltok+ "<" question "xml"
521 version-att
522 encoding-att
523 standalone-att
524 s* question ">")))
525 (xmltok-defregexp
526 xmltok-prolog
527 (let* ((single-char (xmltok-g single-char "[[|,(\"'>]"))
528 (internal-subset-close (xmltok-g internal-subset-close
529 "][ \t\r\n]*>"))
530 (starts-with-close-paren
531 (xmltok-g close-paren
533 (xmltok-p
534 (xmltok-g close-paren-occur "[+?]")
536 (xmltok-g close-paren-star "\\*"))
537 opt))
538 (starts-with-percent
539 (xmltok-g percent
540 "%" (xmltok-g param-entity-ref
541 ncname
542 (xmltok-g param-entity-ref-close
543 ";") opt) opt))
544 (starts-with-nmtoken-not-name
545 (xmltok-g nmtoken
546 (xmltok-p name-continue-not-start-char or ":")
547 (xmltok-p name-continue-char or ":") *))
548 (nmtoken-after-colon
549 (xmltok+
550 (xmltok-p name-continue-not-start-char or ":")
551 (xmltok-p name-continue-char or ":") *
553 name-start-char
554 name-continue-char *
556 (xmltok-p name-continue-char or ":") *))
557 (after-ncname
558 (xmltok+ (xmltok-g ncname-nmtoken
559 ":" (xmltok-p nmtoken-after-colon))
560 or (xmltok-p (xmltok-g colon ":" ncname)
561 (xmltok-g colon-name-occur "[?+*]") opt)
562 or (xmltok-g ncname-occur "[?+*]")
563 or (xmltok-g ncname-colon ":")))
564 (starts-with-name
565 (xmltok-g name ncname (xmltok-p after-ncname) opt))
566 (starts-with-hash
567 (xmltok-g pound
568 "#" (xmltok-g hash-name ncname)))
569 (markup-declaration
570 (xmltok-g markup-declaration
571 "!" (xmltok-p (xmltok-g comment-first-dash "-"
572 (xmltok-g comment-open "-") opt)
573 or (xmltok-g named-markup-declaration
574 ncname)) opt))
575 (after-lt
576 (xmltok+ markup-declaration
577 or (xmltok-g processing-instruction-question
578 question)
579 or (xmltok-g instance-start
580 ncname)))
581 (starts-with-lt (xmltok-g less-than "<" (xmltok-p after-lt) opt)))
582 (xmltok+ starts-with-lt
583 or single-char
584 or starts-with-close-paren
585 or starts-with-percent
586 or starts-with-name
587 or starts-with-nmtoken-not-name
588 or starts-with-hash
589 or internal-subset-close)))))
591 (defconst xmltok-ncname-regexp (xmltok-ncname regexp))
593 (defun xmltok-scan-after-lt ()
594 (cond ((not (looking-at (xmltok-after-lt regexp)))
595 (xmltok-add-error "`<' that is not markup must be entered as `&lt;'")
596 (setq xmltok-type 'not-well-formed))
598 (goto-char (match-end 0))
599 (cond ((xmltok-after-lt start start-tag-close)
600 (setq xmltok-name-end
601 (xmltok-after-lt end start-tag-name))
602 (setq xmltok-name-colon
603 (xmltok-after-lt start start-tag-colon))
604 (setq xmltok-attributes nil)
605 (setq xmltok-namespace-attributes nil)
606 (setq xmltok-type 'start-tag))
607 ((xmltok-after-lt start end-tag-close)
608 (setq xmltok-name-end
609 (xmltok-after-lt end end-tag-name))
610 (setq xmltok-name-colon
611 (xmltok-after-lt start end-tag-colon))
612 (setq xmltok-type 'end-tag))
613 ((xmltok-after-lt start start-tag-s)
614 (setq xmltok-name-end
615 (xmltok-after-lt end start-tag-name))
616 (setq xmltok-name-colon
617 (xmltok-after-lt start start-tag-colon))
618 (setq xmltok-namespace-attributes nil)
619 (setq xmltok-attributes nil)
620 (xmltok-scan-attributes)
621 xmltok-type)
622 ((xmltok-after-lt start empty-tag-close)
623 (setq xmltok-name-end
624 (xmltok-after-lt end start-tag-name))
625 (setq xmltok-name-colon
626 (xmltok-after-lt start start-tag-colon))
627 (setq xmltok-attributes nil)
628 (setq xmltok-namespace-attributes nil)
629 (setq xmltok-type 'empty-element))
630 ((xmltok-after-lt start cdata-section-open)
631 (setq xmltok-type
632 (progn (search-forward "]]>" nil 'move)
633 'cdata-section)))
634 ((xmltok-after-lt start processing-instruction-question)
635 (xmltok-scan-after-processing-instruction-open))
636 ((xmltok-after-lt start comment-open)
637 (xmltok-scan-after-comment-open))
638 ((xmltok-after-lt start empty-tag-slash)
639 (setq xmltok-name-end
640 (xmltok-after-lt end start-tag-name))
641 (setq xmltok-name-colon
642 (xmltok-after-lt start start-tag-colon))
643 (setq xmltok-attributes nil)
644 (setq xmltok-namespace-attributes nil)
645 (xmltok-add-error "Expected `/>'" (1- (point)))
646 (setq xmltok-type 'partial-empty-element))
647 ((xmltok-after-lt start start-tag-name)
648 (xmltok-add-error "Missing `>'"
650 (1+ xmltok-start))
651 (setq xmltok-name-end
652 (xmltok-after-lt end start-tag-name))
653 (setq xmltok-name-colon
654 (xmltok-after-lt start start-tag-colon))
655 (setq xmltok-namespace-attributes nil)
656 (setq xmltok-attributes nil)
657 (setq xmltok-type 'partial-start-tag))
658 ((xmltok-after-lt start end-tag-name)
659 (setq xmltok-name-end (xmltok-after-lt end end-tag-name))
660 (setq xmltok-name-colon
661 (xmltok-after-lt start end-tag-colon))
662 (cond ((and (not xmltok-name-colon)
663 (eq (char-after) ?:))
664 (goto-char (1+ (point)))
665 (xmltok-add-error "Expected name following `:'"
666 (1- (point))))
668 (xmltok-add-error "Missing `>'"
670 (1+ xmltok-start))))
671 (setq xmltok-type 'partial-end-tag))
672 ((xmltok-after-lt start end-tag-slash)
673 (xmltok-add-error "Expected name following `</'")
674 (setq xmltok-name-end nil)
675 (setq xmltok-name-colon nil)
676 (setq xmltok-type 'partial-end-tag))
677 ((xmltok-after-lt start marked-section-open)
678 (xmltok-add-error "Expected `CDATA[' after `<!['"
679 xmltok-start
680 (+ 3 xmltok-start))
681 (setq xmltok-type 'not-well-formed))
682 ((xmltok-after-lt start comment-first-dash)
683 (xmltok-add-error "Expected `-' after `<!-'"
684 xmltok-start
685 (+ 3 xmltok-start))
686 (setq xmltok-type 'not-well-formed))
687 ((xmltok-after-lt start markup-declaration)
688 (xmltok-add-error "Expected `[CDATA[' or `--' after `<!'"
689 xmltok-start
690 (+ 2 xmltok-start))
691 (setq xmltok-type 'not-well-formed))
693 (xmltok-add-error "Not well-formed")
694 (setq xmltok-type 'not-well-formed))))))
696 ;; XXX This should be unified with
697 ;; xmltok-scan-prolog-after-processing-instruction-open
698 ;; XXX maybe should include rest of line (up to any <,>) in unclosed PI
699 (defun xmltok-scan-after-processing-instruction-open ()
700 (search-forward "?>" nil 'move)
701 (cond ((not (save-excursion
702 (goto-char (+ 2 xmltok-start))
703 (and (looking-at (xmltok-ncname regexp))
704 (setq xmltok-name-end (match-end 0)))))
705 (setq xmltok-name-end (+ xmltok-start 2))
706 (xmltok-add-error "<? not followed by name"
707 (+ xmltok-start 2)
708 (+ xmltok-start 3)))
709 ((not (or (memq (char-after xmltok-name-end)
710 '(?\n ?\t ?\r ? ))
711 (= xmltok-name-end (- (point) 2))))
712 (xmltok-add-error "Target not followed by whitespace"
713 xmltok-name-end
714 (1+ xmltok-name-end)))
715 ((and (= xmltok-name-end (+ xmltok-start 5))
716 (save-excursion
717 (goto-char (+ xmltok-start 2))
718 (let ((case-fold-search t))
719 (looking-at "xml"))))
720 (xmltok-add-error "Processing instruction target is xml"
721 (+ xmltok-start 2)
722 (+ xmltok-start 5))))
723 (setq xmltok-type 'processing-instruction))
725 (defun xmltok-scan-after-comment-open ()
726 (while (and (re-search-forward "--\\(>\\)?" nil 'move)
727 (not (match-end 1)))
728 (xmltok-add-error "`--' not followed by `>'" (match-beginning 0)))
729 (setq xmltok-type 'comment))
731 (defun xmltok-scan-attributes ()
732 (let ((recovering nil)
733 (atts-needing-normalization nil))
734 (while (cond ((or (looking-at (xmltok-attribute regexp))
735 ;; use non-greedy group
736 (when (looking-at (concat "[^<>\n]+?"
737 (xmltok-attribute regexp)))
738 (unless recovering
739 (xmltok-add-error "Malformed attribute"
740 (point)
741 (save-excursion
742 (goto-char (xmltok-attribute start
743 name))
744 (skip-chars-backward "\r\n\t ")
745 (point))))
747 (setq recovering nil)
748 (goto-char (match-end 0))
749 (let ((att (xmltok-add-attribute)))
750 (when att
751 (setq atts-needing-normalization
752 (cons att atts-needing-normalization))))
753 (cond ((xmltok-attribute start start-tag-s) t)
754 ((xmltok-attribute start start-tag-close)
755 (setq xmltok-type 'start-tag)
756 nil)
757 ((xmltok-attribute start empty-tag-close)
758 (setq xmltok-type 'empty-element)
759 nil)
760 ((xmltok-attribute start empty-tag-slash)
761 (setq xmltok-type 'partial-empty-element)
762 (xmltok-add-error "Expected `/>'"
763 (1- (point)))
764 nil)
765 ((looking-at "[ \t\r\n]*[\"']")
766 (goto-char (match-end 0))
767 (xmltok-add-error "Missing closing delimiter"
768 (1- (point)))
769 (setq recovering t)
771 ((looking-at "[ \t]*\\([^ \t\r\n\"'=<>/]+\\)[ \t\r\n/>]")
772 (goto-char (match-end 1))
773 (xmltok-add-error "Attribute value not quoted"
774 (match-beginning 1))
775 (setq recovering t)
778 (xmltok-add-error "Missing attribute value"
779 (1- (point)))
780 (setq recovering t)
781 t)))
782 ((looking-at "[^<>\n]*/>")
783 (let ((start (point)))
784 (goto-char (match-end 0))
785 (unless recovering
786 (xmltok-add-error "Malformed empty-element"
787 start
788 (- (point) 2))))
789 (setq xmltok-type 'empty-element)
790 nil)
791 ((looking-at "[^<>\n]*>")
792 (let ((start (point)))
793 (goto-char (match-end 0))
794 (unless recovering
795 (xmltok-add-error "Malformed start-tag"
796 start
797 (1- (point)))))
798 (setq xmltok-type 'start-tag)
799 nil)
801 (when recovering
802 (skip-chars-forward "^<>\n"))
803 (xmltok-add-error "Missing `>'"
804 xmltok-start
805 (1+ xmltok-start))
806 (setq xmltok-type 'partial-start-tag)
807 nil)))
808 (while atts-needing-normalization
809 (xmltok-normalize-attribute (car atts-needing-normalization))
810 (setq atts-needing-normalization (cdr atts-needing-normalization))))
811 (setq xmltok-attributes
812 (nreverse xmltok-attributes))
813 (setq xmltok-namespace-attributes
814 (nreverse xmltok-namespace-attributes)))
816 (defun xmltok-add-attribute ()
817 "Return the attribute if it needs normalizing, otherwise nil."
818 (let* ((needs-normalizing nil)
819 (att
820 (if (xmltok-attribute start literal)
821 (progn
822 (setq needs-normalizing
823 (or (xmltok-attribute start complex1)
824 (xmltok-attribute start complex2)))
825 (xmltok-make-attribute (xmltok-attribute start name)
826 (xmltok-attribute start colon)
827 (xmltok-attribute end name)
828 (1+ (xmltok-attribute start literal))
829 (1- (xmltok-attribute end literal))
830 (not needs-normalizing)))
831 (xmltok-make-attribute (xmltok-attribute start name)
832 (xmltok-attribute start colon)
833 (xmltok-attribute end name)))))
834 (if (xmltok-attribute start xmlns)
835 (setq xmltok-namespace-attributes
836 (cons att xmltok-namespace-attributes))
837 (setq xmltok-attributes
838 (cons att xmltok-attributes)))
839 (and needs-normalizing
840 att)))
842 (defun xmltok-normalize-attribute (att)
843 (let ((end (xmltok-attribute-value-end att))
844 (well-formed t)
845 (value-parts nil)
846 (refs nil))
847 (save-excursion
848 (goto-char (xmltok-attribute-value-start att))
849 (while (progn
850 (let ((n (skip-chars-forward "^\r\t\n&" end)))
851 (when (> n 0)
852 (setq value-parts
853 (cons (buffer-substring-no-properties (- (point) n)
854 (point))
855 value-parts))))
856 (when (< (point) end)
857 (goto-char (1+ (point)))
858 (cond ((eq (char-before) ?\&)
859 (let ((xmltok-start (1- (point)))
860 xmltok-type xmltok-replacement)
861 (xmltok-scan-after-amp
862 (lambda (start end)
863 (xmltok-handle-entity start end t)))
864 (cond ((or (eq xmltok-type 'char-ref)
865 (eq xmltok-type 'entity-ref))
866 (setq refs
867 (cons (vector xmltok-type
868 xmltok-start
869 (point))
870 refs))
871 (if xmltok-replacement
872 (setq value-parts
873 (cons xmltok-replacement
874 value-parts))
875 (setq well-formed nil)))
876 (t (setq well-formed nil)))))
877 (t (setq value-parts
878 (cons " " value-parts)))))
879 (< (point) end))))
880 (when well-formed
881 (aset att 5 (apply 'concat (nreverse value-parts))))
882 (aset att 6 (nreverse refs))))
884 (defun xmltok-scan-after-amp (entity-handler)
885 (cond ((not (looking-at (xmltok-after-amp regexp)))
886 (xmltok-add-error "`&' that is not markup must be entered as `&amp;'")
887 (setq xmltok-type 'not-well-formed))
889 (goto-char (match-end 0))
890 (cond ((xmltok-after-amp start entity-ref-close)
891 (funcall entity-handler
892 (xmltok-after-amp start entity-name)
893 (xmltok-after-amp end entity-name))
894 (setq xmltok-type 'entity-ref))
895 ((xmltok-after-amp start decimal-ref-close)
896 (xmltok-scan-char-ref (xmltok-after-amp start decimal)
897 (xmltok-after-amp end decimal)
898 10))
899 ((xmltok-after-amp start hex-ref-close)
900 (xmltok-scan-char-ref (xmltok-after-amp start hex)
901 (xmltok-after-amp end hex)
902 16))
903 ((xmltok-after-amp start number-sign)
904 (xmltok-add-error "Missing character number")
905 (setq xmltok-type 'not-well-formed))
907 (xmltok-add-error "Missing closing `;'")
908 (setq xmltok-type 'not-well-formed))))))
910 (defconst xmltok-entity-error-messages
911 '((unparsed . "Referenced entity is unparsed")
912 (not-well-formed . "Referenced entity is not well-formed")
913 (external nil . "Referenced entity is external")
914 (element nil . "Referenced entity contains <")))
916 (defun xmltok-handle-entity (start end &optional attributep)
917 (let* ((name (buffer-substring-no-properties start end))
918 (name-def (assoc name xmltok-dtd))
919 (def (cdr name-def)))
920 (cond ((setq xmltok-replacement (and (consp def)
921 (if attributep
922 (cdr def)
923 (car def)))))
924 ((null name-def)
925 (unless (eq (car xmltok-dtd) t)
926 (xmltok-add-error "Referenced entity has not been defined"
927 start
928 end)))
929 ((and attributep (consp def))
930 (xmltok-add-error "Referenced entity contains <"
931 start
932 end))
934 (let ((err (cdr (assq def xmltok-entity-error-messages))))
935 (when (consp err)
936 (setq err (if attributep (cdr err) (car err))))
937 (when err
938 (xmltok-add-error err start end)))))))
940 (defun xmltok-scan-char-ref (start end base)
941 (setq xmltok-replacement
942 (let ((n (string-to-number (buffer-substring-no-properties start end)
943 base)))
944 (cond ((and (integerp n) (xmltok-valid-char-p n))
945 (setq n (xmltok-unicode-to-char n))
946 (and n (string n)))
948 (xmltok-add-error "Invalid character code" start end)
949 nil))))
950 (setq xmltok-type 'char-ref))
952 (defun xmltok-char-number (start end)
953 (let* ((base (if (eq (char-after (+ start 2)) ?x)
955 10))
956 (n (string-to-number
957 (buffer-substring-no-properties (+ start (if (= base 16) 3 2))
958 (1- end))
959 base)))
960 (and (integerp n)
961 (xmltok-valid-char-p n)
962 n)))
964 (defun xmltok-valid-char-p (n)
965 "Return non-nil if N is the Unicode code of a valid XML character."
966 (cond ((< n #x20) (memq n '(#xA #xD #x9)))
967 ((< n #xD800) t)
968 ((< n #xE000) nil)
969 ((< n #xFFFE) t)
970 (t (and (> n #xFFFF)
971 (< n #x110000)))))
973 (defun xmltok-unicode-to-char (n)
974 "Return the character corresponding to Unicode scalar value N.
975 Return nil if unsupported in Emacs."
976 (decode-char 'ucs n))
978 ;;; Prolog parsing
980 (defvar xmltok-contains-doctype nil)
981 (defvar xmltok-doctype-external-subset-flag nil)
982 (defvar xmltok-internal-subset-start nil)
983 (defvar xmltok-had-param-entity-ref nil)
984 (defvar xmltok-prolog-regions nil)
985 (defvar xmltok-standalone nil
986 "Non-nil if there was an XML declaration specifying standalone=\"yes\".")
987 (defvar xmltok-markup-declaration-doctype-flag nil)
989 (defconst xmltok-predefined-entity-alist
990 '(("lt" "<" . "<")
991 ("gt" ">" . ">")
992 ("amp" "&" . "&")
993 ("apos" "'" . "'")
994 ("quot" "\"" . "\"")))
996 (defun xmltok-forward-prolog ()
997 "Move forward to the end of the XML prolog.
999 Returns a list of vectors [TYPE START END] where TYPE is a symbol and
1000 START and END are integers giving the start and end of the region of
1001 that type. TYPE can be one of xml-declaration,
1002 xml-declaration-attribute-name, xml-declaration-attribute-value,
1003 comment, processing-instruction-left, processing-instruction-right,
1004 markup-declaration-open, markup-declaration-close,
1005 internal-subset-open, internal-subset-close, hash-name, keyword,
1006 literal, encoding-name.
1007 Adds to `xmltok-errors' as appropriate."
1008 (let ((case-fold-search nil)
1009 xmltok-start
1010 xmltok-type
1011 xmltok-prolog-regions
1012 xmltok-contains-doctype
1013 xmltok-internal-subset-start
1014 xmltok-had-param-entity-ref
1015 xmltok-standalone
1016 xmltok-doctype-external-subset-flag
1017 xmltok-markup-declaration-doctype-flag)
1018 (setq xmltok-dtd xmltok-predefined-entity-alist)
1019 (xmltok-scan-xml-declaration)
1020 (xmltok-next-prolog-token)
1021 (while (condition-case nil
1022 (when (xmltok-parse-prolog-item)
1023 (xmltok-next-prolog-token))
1024 (xmltok-markup-declaration-parse-error
1025 (xmltok-skip-markup-declaration))))
1026 (when xmltok-internal-subset-start
1027 (xmltok-add-error "No closing ]"
1028 (1- xmltok-internal-subset-start)
1029 xmltok-internal-subset-start))
1030 (xmltok-parse-entities)
1031 (nreverse xmltok-prolog-regions)))
1033 (defconst xmltok-bad-xml-decl-regexp
1034 "[ \t\r\n]*<\\?xml\\(?:[ \t\r\n]\\|\\?>\\)")
1036 ;;;###autoload
1037 (defun xmltok-get-declared-encoding-position (&optional limit)
1038 "Return the position of the encoding in the XML declaration at point.
1039 If there is a well-formed XML declaration starting at point and it
1040 contains an encoding declaration, then return (START . END)
1041 where START and END are the positions of the start and the end
1042 of the encoding name; if there is no encoding declaration return
1043 the position where and encoding declaration could be inserted.
1044 If there is XML that is not well-formed that looks like an XML
1045 declaration, return nil. Otherwise, return t.
1046 If LIMIT is non-nil, then do not consider characters beyond LIMIT."
1047 (cond ((let ((case-fold-search nil))
1048 (and (looking-at (xmltok-xml-declaration regexp))
1049 (or (not limit) (<= (match-end 0) limit))))
1050 (let ((end (xmltok-xml-declaration end encoding-value)))
1051 (if end
1052 (cons (1+ (xmltok-xml-declaration start encoding-value))
1053 (1- end))
1054 (or (xmltok-xml-declaration end version-value)
1055 (+ (point) 5)))))
1056 ((not (let ((case-fold-search t))
1057 (looking-at xmltok-bad-xml-decl-regexp))))))
1059 (defun xmltok-scan-xml-declaration ()
1060 (when (looking-at (xmltok-xml-declaration regexp))
1061 (xmltok-add-prolog-region 'xml-declaration (point) (match-end 0))
1062 (goto-char (match-end 0))
1063 (when (xmltok-xml-declaration start version-name)
1064 (xmltok-add-prolog-region 'xml-declaration-attribute-name
1065 (xmltok-xml-declaration start version-name)
1066 (xmltok-xml-declaration end version-name))
1067 (let ((start (xmltok-xml-declaration start version-value))
1068 (end (xmltok-xml-declaration end version-value)))
1069 (xmltok-add-prolog-region 'xml-declaration-attribute-value
1070 start
1071 end)))
1072 ;; XXX need to check encoding name
1073 ;; Should start with letter, not contain colon
1074 (when (xmltok-xml-declaration start encoding-name)
1075 (xmltok-add-prolog-region 'xml-declaration-attribute-name
1076 (xmltok-xml-declaration start encoding-name)
1077 (xmltok-xml-declaration end encoding-name))
1078 (let ((start (xmltok-xml-declaration start encoding-value))
1079 (end (xmltok-xml-declaration end encoding-value)))
1080 (xmltok-add-prolog-region 'encoding-name
1081 (1+ start)
1082 (1- end))
1083 (xmltok-add-prolog-region 'xml-declaration-attribute-value
1084 start
1085 end)))
1086 (when (xmltok-xml-declaration start standalone-name)
1087 (xmltok-add-prolog-region 'xml-declaration-attribute-name
1088 (xmltok-xml-declaration start standalone-name)
1089 (xmltok-xml-declaration end standalone-name))
1090 (let ((start (xmltok-xml-declaration start standalone-value))
1091 (end (xmltok-xml-declaration end standalone-value)))
1092 (xmltok-add-prolog-region 'xml-declaration-attribute-value
1093 start
1094 end)
1095 (setq xmltok-standalone
1096 (string= (buffer-substring-no-properties (1+ start) (1- end))
1097 "yes"))))
1100 (defconst xmltok-markup-declaration-alist
1101 '(("ELEMENT" . xmltok-parse-element-declaration)
1102 ("ATTLIST" . xmltok-parse-attlist-declaration)
1103 ("ENTITY" . xmltok-parse-entity-declaration)
1104 ("NOTATION" . xmltok-parse-notation-declaration)))
1106 (defun xmltok-parse-prolog-item ()
1107 (cond ((eq xmltok-type 'comment)
1108 (xmltok-add-prolog-region 'comment
1109 xmltok-start
1110 (point))
1112 ((eq xmltok-type 'processing-instruction))
1113 ((eq xmltok-type 'named-markup-declaration)
1114 (setq xmltok-markup-declaration-doctype-flag nil)
1115 (xmltok-add-prolog-region 'markup-declaration-open
1116 xmltok-start
1117 (point))
1118 (let* ((name (buffer-substring-no-properties
1119 (+ xmltok-start 2)
1120 (point)))
1121 (fun (cdr (assoc name xmltok-markup-declaration-alist))))
1122 (cond (fun
1123 (unless xmltok-internal-subset-start
1124 (xmltok-add-error
1125 "Declaration allowed only in internal subset"))
1126 (funcall fun))
1127 ((string= name "DOCTYPE")
1128 (xmltok-parse-doctype))
1130 (xmltok-add-error "Unknown markup declaration"
1131 (+ xmltok-start 2))
1132 (xmltok-next-prolog-token)
1133 (xmltok-markup-declaration-parse-error))))
1135 ((or (eq xmltok-type 'end-prolog)
1136 (not xmltok-type))
1137 nil)
1138 ((eq xmltok-type 'internal-subset-close)
1139 (xmltok-add-prolog-region 'internal-subset-close
1140 xmltok-start
1141 (1+ xmltok-start))
1142 (xmltok-add-prolog-region 'markup-declaration-close
1143 (1- (point))
1144 (point))
1145 (if xmltok-internal-subset-start
1146 (setq xmltok-internal-subset-start nil)
1147 (xmltok-add-error "]> outside internal subset"))
1149 ((eq xmltok-type 'param-entity-ref)
1150 (if xmltok-internal-subset-start
1151 (setq xmltok-had-param-entity-ref t)
1152 (xmltok-add-error "Parameter entity reference outside document type declaration"))
1154 ;; If we don't do this, we can get thousands of errors when
1155 ;; a plain text file is parsed.
1156 ((not xmltok-internal-subset-start)
1157 (when (let ((err (car xmltok-errors)))
1158 (or (not err)
1159 (<= (xmltok-error-end err) xmltok-start)))
1160 (goto-char xmltok-start))
1161 nil)
1162 ((eq xmltok-type 'not-well-formed) t)
1164 (xmltok-add-error "Token allowed only inside markup declaration")
1165 t)))
1167 (defun xmltok-parse-doctype ()
1168 (setq xmltok-markup-declaration-doctype-flag t)
1169 (xmltok-next-prolog-token)
1170 (when xmltok-internal-subset-start
1171 (xmltok-add-error "DOCTYPE declaration not allowed in internal subset")
1172 (xmltok-markup-declaration-parse-error))
1173 (when xmltok-contains-doctype
1174 (xmltok-add-error "Duplicate DOCTYPE declaration")
1175 (xmltok-markup-declaration-parse-error))
1176 (setq xmltok-contains-doctype t)
1177 (xmltok-require-token 'name 'prefixed-name)
1178 (xmltok-require-next-token "SYSTEM" "PUBLIC" ?\[ ?>)
1179 (cond ((eq xmltok-type ?\[)
1180 (setq xmltok-internal-subset-start (point)))
1181 ((eq xmltok-type ?>))
1183 (setq xmltok-doctype-external-subset-flag t)
1184 (xmltok-parse-external-id)
1185 (xmltok-require-token ?\[ ?>)
1186 (when (eq xmltok-type ?\[)
1187 (setq xmltok-internal-subset-start (point))))))
1189 (defun xmltok-parse-attlist-declaration ()
1190 (xmltok-require-next-token 'prefixed-name 'name)
1191 (while (progn
1192 (xmltok-require-next-token ?> 'name 'prefixed-name)
1193 (if (eq xmltok-type ?>)
1195 (xmltok-require-next-token ?\(
1196 "CDATA"
1197 "ID"
1198 "IDREF"
1199 "IDREFS"
1200 "ENTITY"
1201 "ENTITIES"
1202 "NMTOKEN"
1203 "NMTOKENS"
1204 "NOTATION")
1205 (cond ((eq xmltok-type ?\()
1206 (xmltok-parse-nmtoken-group))
1207 ((string= (xmltok-current-token-string)
1208 "NOTATION")
1209 (xmltok-require-next-token ?\()
1210 (xmltok-parse-nmtoken-group)))
1211 (xmltok-require-next-token "#IMPLIED"
1212 "#REQUIRED"
1213 "#FIXED"
1214 'literal)
1215 (when (string= (xmltok-current-token-string) "#FIXED")
1216 (xmltok-require-next-token 'literal))
1217 t))))
1219 (defun xmltok-parse-nmtoken-group ()
1220 (while (progn
1221 (xmltok-require-next-token 'nmtoken 'prefixed-name 'name)
1222 (xmltok-require-next-token ?| ?\))
1223 (eq xmltok-type ?|))))
1225 (defun xmltok-parse-element-declaration ()
1226 (xmltok-require-next-token 'name 'prefixed-name)
1227 (xmltok-require-next-token "EMPTY" "ANY" ?\()
1228 (when (eq xmltok-type ?\()
1229 (xmltok-require-next-token "#PCDATA"
1230 'name
1231 'prefixed-name
1232 'name-occur
1233 ?\()
1234 (cond ((eq xmltok-type 'hash-name)
1235 (xmltok-require-next-token ?| ?\) 'close-paren-star)
1236 (while (eq xmltok-type ?|)
1237 (xmltok-require-next-token 'name 'prefixed-name)
1238 (xmltok-require-next-token 'close-paren-star ?|)))
1239 (t (xmltok-parse-model-group))))
1240 (xmltok-require-next-token ?>))
1242 (defun xmltok-parse-model-group ()
1243 (xmltok-parse-model-group-member)
1244 (xmltok-require-next-token ?|
1247 'close-paren-star
1248 'close-paren-occur)
1249 (when (memq xmltok-type '(?, ?|))
1250 (let ((connector xmltok-type))
1251 (while (progn
1252 (xmltok-next-prolog-token)
1253 (xmltok-parse-model-group-member)
1254 (xmltok-require-next-token connector
1256 'close-paren-star
1257 'close-paren-occur)
1258 (eq xmltok-type connector))))))
1260 (defun xmltok-parse-model-group-member ()
1261 (xmltok-require-token 'name
1262 'prefixed-name
1263 'name-occur
1264 ?\()
1265 (when (eq xmltok-type ?\()
1266 (xmltok-next-prolog-token)
1267 (xmltok-parse-model-group)))
1269 (defun xmltok-parse-entity-declaration ()
1270 (let (paramp name)
1271 (xmltok-require-next-token 'name ?%)
1272 (when (eq xmltok-type ?%)
1273 (setq paramp t)
1274 (xmltok-require-next-token 'name))
1275 (setq name (xmltok-current-token-string))
1276 (xmltok-require-next-token 'literal "SYSTEM" "PUBLIC")
1277 (cond ((eq xmltok-type 'literal)
1278 (let ((replacement (xmltok-parse-entity-value)))
1279 (unless paramp
1280 (xmltok-define-entity name replacement)))
1281 (xmltok-require-next-token ?>))
1283 (xmltok-parse-external-id)
1284 (if paramp
1285 (xmltok-require-token ?>)
1286 (xmltok-require-token ?> "NDATA")
1287 (if (eq xmltok-type ?>)
1288 (xmltok-define-entity name 'external)
1289 (xmltok-require-next-token 'name)
1290 (xmltok-require-next-token ?>)
1291 (xmltok-define-entity name 'unparsed)))))))
1293 (defun xmltok-define-entity (name value)
1294 (when (and (or (not xmltok-had-param-entity-ref)
1295 xmltok-standalone)
1296 (not (assoc name xmltok-dtd)))
1297 (setq xmltok-dtd
1298 (cons (cons name value) xmltok-dtd))))
1300 (defun xmltok-parse-entity-value ()
1301 (let ((lim (1- (point)))
1302 (well-formed t)
1303 value-parts
1304 start)
1305 (save-excursion
1306 (goto-char (1+ xmltok-start))
1307 (setq start (point))
1308 (while (progn
1309 (skip-chars-forward "^%&" lim)
1310 (when (< (point) lim)
1311 (goto-char (1+ (point)))
1312 (cond ((eq (char-before) ?%)
1313 (xmltok-add-error "Parameter entity references are not allowed in the internal subset"
1314 (1- (point))
1315 (point))
1316 (setq well-formed nil))
1318 (let ((xmltok-start (1- (point)))
1319 xmltok-type xmltok-replacement)
1320 (xmltok-scan-after-amp (lambda (_start _end)))
1321 (cond ((eq xmltok-type 'char-ref)
1322 (setq value-parts
1323 (cons (buffer-substring-no-properties
1324 start
1325 xmltok-start)
1326 value-parts))
1327 (setq value-parts
1328 (cons xmltok-replacement
1329 value-parts))
1330 (setq start (point)))
1331 ((eq xmltok-type 'not-well-formed)
1332 (setq well-formed nil))))))
1333 t))))
1334 (if (not well-formed)
1336 (apply 'concat
1337 (nreverse (cons (buffer-substring-no-properties start lim)
1338 value-parts))))))
1340 (defun xmltok-parse-notation-declaration ()
1341 (xmltok-require-next-token 'name)
1342 (xmltok-require-next-token "SYSTEM" "PUBLIC")
1343 (let ((publicp (string= (xmltok-current-token-string) "PUBLIC")))
1344 (xmltok-require-next-token 'literal)
1345 (cond (publicp
1346 (xmltok-require-next-token 'literal ?>)
1347 (unless (eq xmltok-type ?>)
1348 (xmltok-require-next-token ?>)))
1349 (t (xmltok-require-next-token ?>)))))
1351 (defun xmltok-parse-external-id ()
1352 (xmltok-require-token "SYSTEM" "PUBLIC")
1353 (let ((publicp (string= (xmltok-current-token-string) "PUBLIC")))
1354 (xmltok-require-next-token 'literal)
1355 (when publicp
1356 (xmltok-require-next-token 'literal)))
1357 (xmltok-next-prolog-token))
1359 (defun xmltok-require-next-token (&rest types)
1360 (xmltok-next-prolog-token)
1361 (apply 'xmltok-require-token types))
1363 (defun xmltok-require-token (&rest types)
1364 ;; XXX Generate a more helpful error message
1365 (while (and (not (let ((type (car types)))
1366 (if (stringp (car types))
1367 (string= (xmltok-current-token-string) type)
1368 (eq type xmltok-type))))
1369 (setq types (cdr types))))
1370 (unless types
1371 (when (and xmltok-type
1372 (not (eq xmltok-type 'not-well-formed)))
1373 (xmltok-add-error "Unexpected token"))
1374 (xmltok-markup-declaration-parse-error))
1375 (let ((region-type (xmltok-prolog-region-type (car types))))
1376 (when region-type
1377 (xmltok-add-prolog-region region-type
1378 xmltok-start
1379 (point)))))
1381 (defun xmltok-current-token-string ()
1382 (buffer-substring-no-properties xmltok-start (point)))
1384 (define-error 'xmltok-markup-declaration-parse-error
1385 "Syntax error in markup declaration")
1387 (defun xmltok-markup-declaration-parse-error ()
1388 (signal 'xmltok-markup-declaration-parse-error nil))
1390 (defun xmltok-skip-markup-declaration ()
1391 (while (cond ((eq xmltok-type ?>)
1392 (xmltok-next-prolog-token)
1393 nil)
1394 ((and xmltok-markup-declaration-doctype-flag
1395 (eq xmltok-type ?\[))
1396 (setq xmltok-internal-subset-start (point))
1397 (xmltok-next-prolog-token)
1398 nil)
1399 ((memq xmltok-type '(nil
1400 end-prolog
1401 named-markup-declaration
1402 comment
1403 processing-instruction))
1404 nil)
1405 ((and xmltok-internal-subset-start
1406 (eq xmltok-type 'internal-subset-close))
1407 nil)
1408 (t (xmltok-next-prolog-token) t)))
1409 xmltok-type)
1411 (defun xmltok-prolog-region-type (required)
1412 (cond ((cdr (assq xmltok-type
1413 '((literal . literal)
1414 (?> . markup-declaration-close)
1415 (?\[ . internal-subset-open)
1416 (hash-name . hash-name)))))
1417 ((and (stringp required) (eq xmltok-type 'name))
1418 'keyword)))
1420 ;; Return new token type.
1422 (defun xmltok-next-prolog-token ()
1423 (skip-chars-forward " \t\r\n")
1424 (setq xmltok-start (point))
1425 (cond ((not (and (looking-at (xmltok-prolog regexp))
1426 (goto-char (match-end 0))))
1427 (let ((ch (char-after)))
1428 (cond (ch
1429 (goto-char (1+ (point)))
1430 (xmltok-add-error "Illegal char in prolog")
1431 (setq xmltok-type 'not-well-formed))
1432 (t (setq xmltok-type nil)))))
1433 ((or (xmltok-prolog start ncname-occur)
1434 (xmltok-prolog start colon-name-occur))
1435 (setq xmltok-name-end (1- (point)))
1436 (setq xmltok-name-colon (xmltok-prolog start colon))
1437 (setq xmltok-type 'name-occur))
1438 ((xmltok-prolog start colon)
1439 (setq xmltok-name-end (point))
1440 (setq xmltok-name-colon (xmltok-prolog start colon))
1441 (unless (looking-at "[ \t\r\n>),|[%]")
1442 (xmltok-add-error "Missing space after name"))
1443 (setq xmltok-type 'prefixed-name))
1444 ((or (xmltok-prolog start ncname-nmtoken)
1445 (xmltok-prolog start ncname-colon))
1446 (unless (looking-at "[ \t\r\n>),|[%]")
1447 (xmltok-add-error "Missing space after name token"))
1448 (setq xmltok-type 'nmtoken))
1449 ((xmltok-prolog start name)
1450 (setq xmltok-name-end (point))
1451 (setq xmltok-name-colon nil)
1452 (unless (looking-at "[ \t\r\n>),|[%]")
1453 (xmltok-add-error "Missing space after name"))
1454 (setq xmltok-type 'name))
1455 ((xmltok-prolog start hash-name)
1456 (setq xmltok-name-end (point))
1457 (unless (looking-at "[ \t\r\n>)|%]")
1458 (xmltok-add-error "Missing space after name"))
1459 (setq xmltok-type 'hash-name))
1460 ((xmltok-prolog start processing-instruction-question)
1461 (xmltok-scan-prolog-after-processing-instruction-open))
1462 ((xmltok-prolog start comment-open)
1463 ;; XXX if not-well-formed, ignore some stuff
1464 (xmltok-scan-after-comment-open))
1465 ((xmltok-prolog start named-markup-declaration)
1466 (setq xmltok-type 'named-markup-declaration))
1467 ((xmltok-prolog start instance-start)
1468 (goto-char xmltok-start)
1469 (setq xmltok-type 'end-prolog))
1470 ((xmltok-prolog start close-paren-star)
1471 (setq xmltok-type 'close-paren-star))
1472 ((xmltok-prolog start close-paren-occur)
1473 (setq xmltok-type 'close-paren-occur))
1474 ((xmltok-prolog start close-paren)
1475 (unless (looking-at "[ \t\r\n>,|)]")
1476 (xmltok-add-error "Missing space after )"))
1477 (setq xmltok-type ?\)))
1478 ((xmltok-prolog start single-char)
1479 (let ((ch (char-before)))
1480 (cond ((memq ch '(?\" ?\'))
1481 (xmltok-scan-prolog-literal))
1482 (t (setq xmltok-type ch)))))
1483 ((xmltok-prolog start percent)
1484 (cond ((xmltok-prolog start param-entity-ref-close)
1485 (setq xmltok-name-end (1- (point)))
1486 (setq xmltok-type 'param-entity-ref))
1487 ((xmltok-prolog start param-entity-ref)
1488 (xmltok-add-error "Missing ;")
1489 (setq xmltok-name-end (point))
1490 (setq xmltok-type 'param-entity-ref))
1491 ((looking-at "[ \t\r\n%]")
1492 (setq xmltok-type ?%))
1494 (xmltok-add-error "Expected name after %")
1495 (setq xmltok-type 'not-well-formed))))
1496 ((xmltok-prolog start nmtoken)
1497 (unless (looking-at "[ \t\r\n>),|[%]")
1498 (xmltok-add-error "Missing space after name token"))
1499 (setq xmltok-type 'nmtoken))
1500 ((xmltok-prolog start internal-subset-close)
1501 (setq xmltok-type 'internal-subset-close))
1502 ((xmltok-prolog start pound)
1503 (xmltok-add-error "Expected name after #")
1504 (setq xmltok-type 'not-well-formed))
1505 ((xmltok-prolog start markup-declaration)
1506 (xmltok-add-error "Expected name or -- after <!")
1507 (setq xmltok-type 'not-well-formed))
1508 ((xmltok-prolog start comment-first-dash)
1509 (xmltok-add-error "Expected <!--")
1510 (setq xmltok-type 'not-well-formed))
1511 ((xmltok-prolog start less-than)
1512 (xmltok-add-error "Incomplete markup")
1513 (setq xmltok-type 'not-well-formed))
1514 (t (error "Unhandled token in prolog %s"
1515 (match-string-no-properties 0)))))
1517 (defun xmltok-scan-prolog-literal ()
1518 (let* ((delim (string (char-before)))
1519 (safe-end (save-excursion
1520 (skip-chars-forward (concat "^<>[]" delim))
1521 (point)))
1522 (end (save-excursion
1523 (goto-char safe-end)
1524 (search-forward delim nil t))))
1525 (cond ((or (not end)
1526 (save-excursion
1527 (goto-char end)
1528 (looking-at "[ \t\r\n>%[]")))
1529 (goto-char end))
1530 ((eq (1+ safe-end) end)
1531 (goto-char end)
1532 (xmltok-add-error (format "Missing space after %s" delim)
1533 safe-end)))
1534 (setq xmltok-type 'literal)))
1536 (defun xmltok-scan-prolog-after-processing-instruction-open ()
1537 (search-forward "?>" nil 'move)
1538 (let* ((end (point))
1539 (target
1540 (save-excursion
1541 (goto-char (+ xmltok-start 2))
1542 (and (looking-at (xmltok-ncname regexp))
1543 (or (memq (char-after (match-end 0))
1544 '(?\n ?\t ?\r ? ))
1545 (= (match-end 0) (- end 2)))
1546 (match-string-no-properties 0)))))
1547 (cond ((not target)
1548 (xmltok-add-error "\
1549 Processing instruction does not start with a name"
1550 (+ xmltok-start 2)
1551 (+ xmltok-start 3)))
1552 ((not (and (= (length target) 3)
1553 (let ((case-fold-search t))
1554 (string-match "xml" target)))))
1555 ((= xmltok-start 1)
1556 (xmltok-add-error "Invalid XML declaration"
1557 xmltok-start
1558 (point)))
1559 ((save-excursion
1560 (goto-char xmltok-start)
1561 (looking-at (xmltok-xml-declaration regexp)))
1562 (xmltok-add-error "XML declaration not at beginning of file"
1563 xmltok-start
1564 (point)))
1566 (xmltok-add-error "Processing instruction has target of xml"
1567 (+ xmltok-start 2)
1568 (+ xmltok-start 5))))
1569 (xmltok-add-prolog-region 'processing-instruction-left
1570 xmltok-start
1571 (+ xmltok-start
1573 (if target
1574 (length target)
1575 0)))
1576 (xmltok-add-prolog-region 'processing-instruction-right
1577 (if target
1578 (save-excursion
1579 (goto-char (+ xmltok-start
1580 (length target)
1582 (skip-chars-forward " \t\r\n")
1583 (point))
1584 (+ xmltok-start 2))
1585 (point)))
1586 (setq xmltok-type 'processing-instruction))
1588 (defun xmltok-parse-entities ()
1589 (let ((todo xmltok-dtd))
1590 (when (and (or xmltok-had-param-entity-ref
1591 xmltok-doctype-external-subset-flag)
1592 (not xmltok-standalone))
1593 (setq xmltok-dtd (cons t xmltok-dtd)))
1594 (while todo
1595 (xmltok-parse-entity (car todo))
1596 (setq todo (cdr todo)))))
1598 (defun xmltok-parse-entity (name-def)
1599 (let ((def (cdr name-def))
1600 ;; in case its value is buffer local
1601 (xmltok-dtd xmltok-dtd)
1602 buf)
1603 (when (stringp def)
1604 (if (string-match "\\`[^&<\t\r\n]*\\'" def)
1605 (setcdr name-def (cons def def))
1606 (setcdr name-def 'not-well-formed) ; avoid infinite expansion loops
1607 (setq buf (get-buffer-create
1608 (format " *Entity %s*" (car name-def))))
1609 (with-current-buffer buf
1610 (erase-buffer)
1611 (insert def)
1612 (goto-char (point-min))
1613 (setcdr name-def
1614 (xmltok-parse-entity-replacement)))
1615 (kill-buffer buf)))))
1617 (defun xmltok-parse-entity-replacement ()
1618 (let ((def (cons "" "")))
1619 (while (let* ((start (point))
1620 (found (re-search-forward "[<&\t\r\n]\\|]]>" nil t))
1621 (ch (and found (char-before)))
1622 (str (buffer-substring-no-properties
1623 start
1624 (if found
1625 (match-beginning 0)
1626 (point-max)))))
1627 (setq def
1628 (xmltok-append-entity-def def
1629 (cons str str)))
1630 (cond ((not found) nil)
1631 ((eq ch ?>)
1632 (setq def 'not-well-formed)
1633 nil)
1634 ((eq ch ?<)
1635 (xmltok-save
1636 (setq xmltok-start (1- (point)))
1637 (xmltok-scan-after-lt)
1638 (setq def
1639 (xmltok-append-entity-def
1641 (cond ((memq xmltok-type
1642 '(start-tag
1643 end-tag
1644 empty-element))
1645 'element)
1646 ((memq xmltok-type
1647 '(comment
1648 processing-instruction))
1649 (cons "" nil))
1650 ((eq xmltok-type
1651 'cdata-section)
1652 (cons (buffer-substring-no-properties
1653 (+ xmltok-start 9)
1654 (- (point) 3))
1655 nil))
1656 (t 'not-well-formed)))))
1658 ((eq ch ?&)
1659 (let ((xmltok-start (1- (point)))
1660 xmltok-type
1661 xmltok-replacement
1662 xmltok-errors)
1663 (xmltok-scan-after-amp 'xmltok-handle-nested-entity)
1664 (cond ((eq xmltok-type 'entity-ref)
1665 (setq def
1666 (xmltok-append-entity-def
1668 xmltok-replacement)))
1669 ((eq xmltok-type 'char-ref)
1670 (setq def
1671 (xmltok-append-entity-def
1673 (if xmltok-replacement
1674 (cons xmltok-replacement
1675 xmltok-replacement)
1676 (and xmltok-errors 'not-well-formed)))))
1678 (setq def 'not-well-formed))))
1681 (setq def
1682 (xmltok-append-entity-def
1684 (cons (match-string-no-properties 0)
1685 " ")))
1686 t))))
1687 def))
1689 (defun xmltok-handle-nested-entity (start end)
1690 (let* ((name-def (assoc (buffer-substring-no-properties start end)
1691 xmltok-dtd))
1692 (def (cdr name-def)))
1693 (when (stringp def)
1694 (xmltok-parse-entity name-def)
1695 (setq def (cdr name-def)))
1696 (setq xmltok-replacement
1697 (cond ((null name-def)
1698 (if (eq (car xmltok-dtd) t)
1700 'not-well-formed))
1701 ((eq def 'unparsed) 'not-well-formed)
1702 (t def)))))
1704 (defun xmltok-append-entity-def (d1 d2)
1705 (cond ((consp d1)
1706 (if (consp d2)
1707 (cons (concat (car d1) (car d2))
1708 (and (cdr d1)
1709 (cdr d2)
1710 (concat (cdr d1) (cdr d2))))
1711 d2))
1712 ((consp d2) d1)
1714 (let ((defs '(not-well-formed external element)))
1715 (while (not (or (eq (car defs) d1)
1716 (eq (car defs) d2)))
1717 (setq defs (cdr defs)))
1718 (car defs)))))
1720 (defun xmltok-add-prolog-region (type start end)
1721 (setq xmltok-prolog-regions
1722 (cons (vector type start end)
1723 xmltok-prolog-regions)))
1725 (defun xmltok-merge-attributes ()
1726 "Return a list merging `xmltok-attributes' and `xmltok-namespace-attributes'.
1727 The members of the merged list are in order of occurrence in the
1728 document. The list may share list structure with `xmltok-attributes'
1729 and `xmltok-namespace-attributes'."
1730 (cond ((not xmltok-namespace-attributes)
1731 xmltok-attributes)
1732 ((not xmltok-attributes)
1733 xmltok-namespace-attributes)
1735 (let ((atts1 xmltok-attributes)
1736 (atts2 xmltok-namespace-attributes)
1737 merged)
1738 (while (and atts1 atts2)
1739 (cond ((< (xmltok-attribute-name-start (car atts1))
1740 (xmltok-attribute-name-start (car atts2)))
1741 (setq merged (cons (car atts1) merged))
1742 (setq atts1 (cdr atts1)))
1744 (setq merged (cons (car atts2) merged))
1745 (setq atts2 (cdr atts2)))))
1746 (setq merged (nreverse merged))
1747 (cond (atts1 (setq merged (nconc merged atts1)))
1748 (atts2 (setq merged (nconc merged atts2))))
1749 merged))))
1751 ;;; Testing
1753 (defun xmltok-forward-test ()
1754 (interactive)
1755 (if (xmltok-forward)
1756 (message "Scanned %s" xmltok-type)
1757 (message "Scanned nothing")))
1759 (defun xmltok-next-prolog-token-test ()
1760 (interactive)
1761 (if (xmltok-next-prolog-token)
1762 (message "Scanned %s"
1763 (if (integerp xmltok-type)
1764 (string xmltok-type)
1765 xmltok-type))
1766 (message "Scanned end of file")))
1768 (provide 'xmltok)
1770 ;;; xmltok.el ends here