lisp/nxml/xmltok.el

   1 ;;; xmltok.el --- XML tokenization  -*- lexical-binding:t -*-
   2
   3 ;; Copyright (C) 2003, 2007-2014 Free Software Foundation, Inc.
   4
   5 ;; Author: James Clark
   6 ;; Keywords: wp, hypermedia, languages, XML
   7
   8 ;; This file is part of GNU Emacs.
   9
  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.
  14
  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.
  19
  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/>.
  22
  23 ;;; Commentary:
  24
  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).
  41 ;;
  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.
  45 ;;
  46 ;; It is non-conformant by design in the following respects.
  47 ;;
  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.
  52 ;;
  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.
  59 ;;
  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.
  63 ;;
  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).
  67 ;;
  68 ;; There are also a number of things that have not yet been
  69 ;; implemented that make it non-conformant.
  70 ;;
  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.
  75 ;;
  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.
  80 ;;
  81 ;; 3. It does not check the syntax of public identifiers in the DTD.
  82 ;;
  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.
  89
  90 ;;; Code:
  91
  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.")
  98
  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'.")
 106
 107 (defvar xmltok-namespace-attributes nil
 108   "List containing namespace declarations of last scanned element.
 109 List has same format as `xmltok-attributes'.")
 110
 111 (defvar xmltok-dtd nil
 112   "Information about the DTD used by `xmltok-forward'.
 113 `xmltok-forward-prolog' sets this up.
 114
 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).
 119
 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.")
 134
 135
 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.")
 143
 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))
 155
 156 (defsubst xmltok-attribute-name-start (att)
 157   (aref att 0))
 158
 159 (defsubst xmltok-attribute-name-colon (att)
 160   (aref att 1))
 161
 162 (defsubst xmltok-attribute-name-end (att)
 163   (aref att 2))
 164
 165 (defsubst xmltok-attribute-value-start (att)
 166   (aref att 3))
 167
 168 (defsubst xmltok-attribute-value-end (att)
 169   (aref att 4))
 170
 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))
 177
 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))
 184
 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))))
 190
 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))))
 197
 198 (defun xmltok-attribute-value (att)
 199   (let ((rnv (xmltok-attribute-raw-normalized-value att)))
 200     (and rnv
 201          (if (stringp rnv)
 202              rnv
 203            (buffer-substring-no-properties (xmltok-attribute-value-start att)
 204                                            (xmltok-attribute-value-end att))))))
 205
 206 (defun xmltok-start-tag-prefix ()
 207   (and xmltok-name-colon
 208        (buffer-substring-no-properties (1+ xmltok-start)
 209                                        xmltok-name-colon)))
 210
 211 (defun xmltok-start-tag-local-name ()
 212   (buffer-substring-no-properties (1+ (or xmltok-name-colon
 213                                           xmltok-start))
 214                                   xmltok-name-end))
 215
 216 (defun xmltok-end-tag-prefix ()
 217   (and xmltok-name-colon
 218        (buffer-substring-no-properties (+ 2 xmltok-start)
 219                                        xmltok-name-colon)))
 220
 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))
 226
 227 (defun xmltok-start-tag-qname ()
 228   (buffer-substring-no-properties (+ xmltok-start 1) xmltok-name-end))
 229
 230 (defun xmltok-end-tag-qname ()
 231   (buffer-substring-no-properties (+ xmltok-start 2) xmltok-name-end))
 232
 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))
 251
 252 (defsubst xmltok-error-message (err)
 253   (aref err 0))
 254
 255 (defsubst xmltok-error-start (err)
 256   (aref err 1))
 257
 258 (defsubst xmltok-error-end (err)
 259   (aref err 2))
 260
 261 (defsubst xmltok-make-error (message start end)
 262   (vector message start end))
 263
 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)))
 270
 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))
 279                  (t
 280                   (forward-char 1)
 281                   (xmltok-scan-after-lt))))
 282           ((eq ch ?\&)
 283            (cond ((> space-count 0)
 284                   (setq xmltok-type 'space))
 285                  (t
 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))
 296                  (t
 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)))
 307           (t
 308            (goto-char (point-max))
 309            (setq xmltok-type 'data)))))
 310
 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))))
 322
 323 (eval-when-compile
 324
 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.
 328
 329   ;; Construct a symbolic regexp from a regexp.
 330   (defun xmltok-r (str)
 331     (cons str nil))
 332
 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))))))
 345
 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)))))))
 355
 356   (defun xmltok-p (&rest r) (xmltok+ "\\(?:"
 357                                      (apply 'xmltok+ r)
 358                                      "\\)"))
 359
 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))
 370               (t
 371                (setq i (1+ i))
 372                (setq list (cdr list)))))
 373       (or found
 374           (error "Bad group name %s" elem))))
 375
 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))))))))
 407
 408
 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)))
 475
 476     (xmltok-defregexp xmltok-ncname  (xmltok+ open ncname close))
 477
 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
 548                        ")"
 549                        (xmltok-p
 550                         (xmltok-g close-paren-occur "[+?]")
 551                         or
 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 ":") *
 568               or
 569               name-start-char
 570               name-continue-char *
 571               ":"
 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)))))
 606
 607 (defconst xmltok-ncname-regexp (xmltok-ncname regexp))
 608
 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))
 613         (t
 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 `>'"
 665                                   nil
 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))))
 683                       (t
 684                        (xmltok-add-error "Missing `>'"
 685                                          nil
 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))
 708                (t
 709                 (xmltok-add-error "Not well-formed")
 710                 (setq xmltok-type 'not-well-formed))))))
 711
 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))
 740
 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)
 747                 (t
 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)))))
 755
 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))))
 771                         t))
 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)
 795                          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)
 801                          t)
 802                         (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)
 825                  (t
 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)))
 840
 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)))
 866
 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))))
 908
 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))
 913         (t
 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))
 931                (t
 932                 (xmltok-add-error "Missing closing `;'")
 933                 (setq xmltok-type 'not-well-formed))))))
 934
 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 <")))
 940
 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))
 958           (t
 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)))))))
 964
 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)))
 972                 (t
 973                  (xmltok-add-error "Invalid character code" start end)
 974                  nil))))
 975   (setq xmltok-type 'char-ref))
 976
 977 (defun xmltok-char-number (start end)
 978   (let* ((base (if (eq (char-after (+ start 2)) ?x)
 979                    16
 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)))
 988
 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)))))
 997
 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))
1002
1003 ;;; Prolog parsing
1004
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)
1013
1014 (defconst xmltok-predefined-entity-alist
1015   '(("lt" "<" . "<")
1016     ("gt" ">" . ">")
1017     ("amp" "&" . "&")
1018     ("apos" "'" . "'")
1019     ("quot" "\"" . "\"")))
1020
1021 (defun xmltok-forward-prolog ()
1022   "Move forward to the end of the XML prolog.
1023
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)))
1057
1058 (defconst xmltok-bad-xml-decl-regexp
1059   "[ \t\r\n]*<\\?xml\\(?:[ \t\r\n]\\|\\?>\\)")
1060
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))))))
1083
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"))))
1123     t))
1124
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)))
1130
1131 (defun xmltok-parse-prolog-item ()
1132   (cond ((eq xmltok-type 'comment)
1133          (xmltok-add-prolog-region 'comment
1134                                    xmltok-start
1135                                    (point))
1136          t)
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))
1154                  (t
1155                   (xmltok-add-error "Unknown markup declaration"
1156                                     (+ xmltok-start 2))
1157                   (xmltok-next-prolog-token)
1158                   (xmltok-markup-declaration-parse-error))))
1159          t)
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"))
1173          t)
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"))
1178          t)
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)
1188         (t
1189          (xmltok-add-error "Token allowed only inside markup declaration")
1190          t)))
1191
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 ?>))
1207         (t
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))))))
1213
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 ?>)
1219                nil
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))))
1243
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 ?|))))
1249
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 ?>))
1266
1267 (defun xmltok-parse-model-group ()
1268   (xmltok-parse-model-group-member)
1269   (xmltok-require-next-token ?|
1270                              ?,
1271                              ?\)
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
1280                                           ?\)
1281                                           'close-paren-star
1282                                           'close-paren-occur)
1283                (eq xmltok-type connector))))))
1284
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)))
1293
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 ?>))
1307           (t
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)))))))
1317
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))))
1324
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))
1342                        (t
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)
1360         nil
1361       (apply 'concat
1362              (nreverse (cons (buffer-substring-no-properties start lim)
1363                              value-parts))))))
1364
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 ?>)))))
1375
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))
1383
1384 (defun xmltok-require-next-token (&rest types)
1385   (xmltok-next-prolog-token)
1386   (apply 'xmltok-require-token types))
1387
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)))))
1405
1406 (defun xmltok-current-token-string ()
1407   (buffer-substring-no-properties xmltok-start (point)))
1408
1409 (define-error 'xmltok-markup-declaration-parse-error
1410   "Syntax error in markup declaration")
1411
1412 (defun xmltok-markup-declaration-parse-error ()
1413   (signal 'xmltok-markup-declaration-parse-error nil))
1414
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)
1435
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)))
1444
1445 ;; Return new token type.
1446
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 ?%))
1518                (t
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)))))
1541
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)))
1560
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)))
1590           (t
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
1597                                  2
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)
1606                                                   2))
1607                                     (skip-chars-forward " \t\r\n")
1608                                     (point))
1609                                 (+ xmltok-start 2))
1610                               (point)))
1611   (setq xmltok-type 'processing-instruction))
1612
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)))))
1622
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)))))
1641
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
1665                              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)))))
1682                     t)
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
1692                                     def
1693                                     xmltok-replacement)))
1694                             ((eq xmltok-type 'char-ref)
1695                              (setq def
1696                                    (xmltok-append-entity-def
1697                                     def
1698                                     (if xmltok-replacement
1699                                          (cons xmltok-replacement
1700                                                xmltok-replacement)
1701                                       (and xmltok-errors 'not-well-formed)))))
1702                             (t
1703                              (setq def 'not-well-formed))))
1704                     t)
1705                    (t
1706                     (setq def
1707                           (xmltok-append-entity-def
1708                            def
1709                            (cons (match-string-no-properties 0)
1710                                  " ")))
1711                     t))))
1712     def))
1713
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)
1724                      nil
1725                    'not-well-formed))
1726                 ((eq def 'unparsed) 'not-well-formed)
1727                 (t def)))))
1728
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)
1738         (t
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)))))
1744
1745 (defun xmltok-add-prolog-region (type start end)
1746   (setq xmltok-prolog-regions
1747         (cons (vector type start end)
1748               xmltok-prolog-regions)))
1749
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)
1759         (t
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)))
1768                    (t
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))))
1775
1776 ;;; Testing
1777
1778 (defun xmltok-forward-test ()
1779   (interactive)
1780   (if (xmltok-forward)
1781       (message "Scanned %s" xmltok-type)
1782     (message "Scanned nothing")))
1783
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")))
1792
1793 (provide 'xmltok)
1794
1795 ;;; xmltok.el ends here