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