code.delx.au - gnu-emacs/blob - lisp/xml.el

   1 ;;; xml.el --- XML parser
   2
   3 ;; Copyright (C) 2000-2012 Free Software Foundation, Inc.
   4
   5 ;; Author: Emmanuel Briot  <briot@gnat.com>
   6 ;; Maintainer: Mark A. Hershberger <mah@everybody.org>
   7 ;; Keywords: xml, data
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; This file contains a somewhat incomplete non-validating XML parser.  It
  27 ;; parses a file, and returns a list that can be used internally by
  28 ;; any other Lisp libraries.
  29
  30 ;;; FILE FORMAT
  31
  32 ;; The document type declaration may either be ignored or (optionally)
  33 ;; parsed, but currently the parsing will only accept element
  34 ;; declarations.  The XML file is assumed to be well-formed.  In case
  35 ;; of error, the parsing stops and the XML file is shown where the
  36 ;; parsing stopped.
  37 ;;
  38 ;; It also knows how to ignore comments and processing instructions.
  39 ;;
  40 ;; The XML file should have the following format:
  41 ;;    <node1 attr1="name1" attr2="name2" ...>value
  42 ;;       <node2 attr3="name3" attr4="name4">value2</node2>
  43 ;;       <node3 attr5="name5" attr6="name6">value3</node3>
  44 ;;    </node1>
  45 ;; Of course, the name of the nodes and attributes can be anything.  There can
  46 ;; be any number of attributes (or none), as well as any number of children
  47 ;; below the nodes.
  48 ;;
  49 ;; There can be only top level node, but with any number of children below.
  50
  51 ;;; LIST FORMAT
  52
  53 ;; The functions `xml-parse-file', `xml-parse-region' and
  54 ;; `xml-parse-tag' return a list with the following format:
  55 ;;
  56 ;;    xml-list   ::= (node node ...)
  57 ;;    node       ::= (qname attribute-list . child_node_list)
  58 ;;    child_node_list ::= child_node child_node ...
  59 ;;    child_node ::= node | string
  60 ;;    qname      ::= (:namespace-uri . "name") | "name"
  61 ;;    attribute_list ::= ((qname . "value") (qname . "value") ...)
  62 ;;                       | nil
  63 ;;    string     ::= "..."
  64 ;;
  65 ;; Some macros are provided to ease the parsing of this list.
  66 ;; Whitespace is preserved.  Fixme: There should be a tree-walker that
  67 ;; can remove it.
  68
  69 ;; TODO:
  70 ;;  * xml:base, xml:space support
  71 ;;  * more complete DOCTYPE parsing
  72 ;;  * pi support
  73
  74 ;;; Code:
  75
  76 ;; Note that buffer-substring and match-string were formerly used in
  77 ;; several places, because the -no-properties variants remove
  78 ;; composition info.  However, after some discussion on emacs-devel,
  79 ;; the consensus was that the speed of the -no-properties variants was
  80 ;; a worthwhile tradeoff especially since we're usually parsing files
  81 ;; instead of hand-crafted XML.
  82
  83 ;;;  Macros to parse the list
  84
  85 (defconst xml-undefined-entity "?"
  86   "What to substitute for undefined entities")
  87
  88 (defconst xml-default-ns '(("" . "")
  89                            ("xml" . "http://www.w3.org/XML/1998/namespace")
  90                            ("xmlns" . "http://www.w3.org/2000/xmlns/"))
  91   "Alist mapping default XML namespaces to their URIs.")
  92
  93 (defvar xml-entity-alist
  94   '(("lt"   . "&#60;")
  95     ("gt"   . ">")
  96     ("apos" . "'")
  97     ("quot" . "\"")
  98     ("amp"  . "&#38;"))
  99   "Alist mapping XML entities to their replacement text.")
 100
 101 (defvar xml-entity-expansion-limit 20000
 102   "The maximum size of entity reference expansions.
 103 If the size of the buffer increases by this many characters while
 104 expanding entity references in a segment of character data, the
 105 XML parser signals an error.  Setting this to nil removes the
 106 limit (making the parser vulnerable to XML bombs).")
 107
 108 (defvar xml-parameter-entity-alist nil
 109   "Alist of defined XML parametric entities.")
 110
 111 (defvar xml-sub-parser nil
 112   "Non-nil when the XML parser is parsing an XML fragment.")
 113
 114 (defvar xml-validating-parser nil
 115   "Set to non-nil to get validity checking.")
 116
 117 (defsubst xml-node-name (node)
 118   "Return the tag associated with NODE.
 119 Without namespace-aware parsing, the tag is a symbol.
 120
 121 With namespace-aware parsing, the tag is a cons of a string
 122 representing the uri of the namespace with the local name of the
 123 tag.  For example,
 124
 125     <foo>
 126
 127 would be represented by
 128
 129     '(\"\" . \"foo\")."
 130
 131   (car node))
 132
 133 (defsubst xml-node-attributes (node)
 134   "Return the list of attributes of NODE.
 135 The list can be nil."
 136   (nth 1 node))
 137
 138 (defsubst xml-node-children (node)
 139   "Return the list of children of NODE.
 140 This is a list of nodes, and it can be nil."
 141   (cddr node))
 142
 143 (defun xml-get-children (node child-name)
 144   "Return the children of NODE whose tag is CHILD-NAME.
 145 CHILD-NAME should match the value returned by `xml-node-name'."
 146   (let ((match ()))
 147     (dolist (child (xml-node-children node))
 148       (if (and (listp child)
 149                (equal (xml-node-name child) child-name))
 150           (push child match)))
 151     (nreverse match)))
 152
 153 (defun xml-get-attribute-or-nil (node attribute)
 154   "Get from NODE the value of ATTRIBUTE.
 155 Return nil if the attribute was not found.
 156
 157 See also `xml-get-attribute'."
 158   (cdr (assoc attribute (xml-node-attributes node))))
 159
 160 (defsubst xml-get-attribute (node attribute)
 161   "Get from NODE the value of ATTRIBUTE.
 162 An empty string is returned if the attribute was not found.
 163
 164 See also `xml-get-attribute-or-nil'."
 165   (or (xml-get-attribute-or-nil node attribute) ""))
 166
 167 ;;;  Creating the list
 168
 169 ;;;###autoload
 170 (defun xml-parse-file (file &optional parse-dtd parse-ns)
 171   "Parse the well-formed XML file FILE.
 172 Return the top node with all its children.
 173 If PARSE-DTD is non-nil, the DTD is parsed rather than skipped.
 174 If PARSE-NS is non-nil, then QNAMES are expanded."
 175   (with-temp-buffer
 176     (insert-file-contents file)
 177     (xml--parse-buffer parse-dtd parse-ns)))
 178
 179 (eval-and-compile
 180 (let* ((start-chars (concat "[:alpha:]:_"))
 181        (name-chars  (concat "-[:digit:]." start-chars))
 182        ;;[3] S ::= (#x20 | #x9 | #xD | #xA)+
 183        (whitespace  "[ \t\n\r]"))
 184   ;; [4] NameStartChar ::= ":" | [A-Z] | "_" | [a-z] | [#xC0-#xD6]
 185   ;;                     | [#xD8-#xF6] | [#xF8-#x2FF] | [#x370-#x37D] | [#x37F-#x1FFF]
 186   ;;                     | [#x200C-#x200D] | [#x2070-#x218F] | [#x2C00-#x2FEF]
 187   ;;                     | [#x3001-#xD7FF] | [#xF900-#xFDCF] | [#xFDF0-#xFFFD]
 188   ;;                     | [#x10000-#xEFFFF]
 189   (defconst xml-name-start-char-re (concat "[" start-chars "]"))
 190   ;; [4a] NameChar ::= NameStartChar | "-" | "." | [0-9] | #xB7
 191   ;;                 | [#x0300-#x036F] | [#x203F-#x2040]
 192   (defconst xml-name-char-re (concat "[" name-chars  "]"))
 193   ;; [5] Name     ::= NameStartChar (NameChar)*
 194   (defconst xml-name-re      (concat xml-name-start-char-re xml-name-char-re "*"))
 195   ;; [6] Names    ::= Name (#x20 Name)*
 196   (defconst xml-names-re     (concat xml-name-re "\\(?: " xml-name-re "\\)*"))
 197   ;; [7] Nmtoken  ::= (NameChar)+
 198   (defconst xml-nmtoken-re   (concat xml-name-char-re "+"))
 199   ;; [8] Nmtokens ::= Nmtoken (#x20 Nmtoken)*
 200   (defconst xml-nmtokens-re  (concat xml-nmtoken-re "\\(?: " xml-name-re "\\)*"))
 201   ;; [66] CharRef ::= '&#' [0-9]+ ';' | '&#x' [0-9a-fA-F]+ ';'
 202   (defconst xml-char-ref-re  "\\(?:&#[0-9]+;\\|&#x[0-9a-fA-F]+;\\)")
 203   ;; [68] EntityRef   ::= '&' Name ';'
 204   (defconst xml-entity-ref   (concat "&" xml-name-re ";"))
 205   ;; [69] PEReference ::= '%' Name ';'
 206   (defconst xml-pe-reference-re (concat "%" xml-name-re ";"))
 207   ;; [67] Reference   ::= EntityRef | CharRef
 208   (defconst xml-reference-re (concat "\\(?:" xml-entity-ref "\\|" xml-char-ref-re "\\)"))
 209   ;; [10] AttValue    ::= '"' ([^<&"] | Reference)* '"' |  "'" ([^<&'] | Reference)* "'"
 210   (defconst xml-att-value-re (concat "\\(?:\"\\(?:[^&\"]\\|" xml-reference-re "\\)*\"\\|"
 211                                      "'\\(?:[^&']\\|" xml-reference-re "\\)*'\\)"))
 212   ;; [56] TokenizedType ::= 'ID' [VC: ID] [VC: One ID / Element Type] [VC: ID Attribute Default]
 213   ;;                      | 'IDREF'    [VC: IDREF]
 214   ;;                      | 'IDREFS'   [VC: IDREF]
 215   ;;                      | 'ENTITY'   [VC: Entity Name]
 216   ;;                      | 'ENTITIES' [VC: Entity Name]
 217   ;;                      | 'NMTOKEN'  [VC: Name Token]
 218   ;;                      | 'NMTOKENS' [VC: Name Token]
 219   (defconst xml-tokenized-type-re (concat "\\(?:ID\\|IDREF\\|IDREFS\\|ENTITY\\|"
 220                                           "ENTITIES\\|NMTOKEN\\|NMTOKENS\\)"))
 221   ;; [58] NotationType ::= 'NOTATION' S '(' S? Name (S? '|' S? Name)* S? ')'
 222   (defconst xml-notation-type-re
 223     (concat "\\(?:NOTATION" whitespace "(" whitespace "*" xml-name-re
 224             "\\(?:" whitespace "*|" whitespace "*" xml-name-re "\\)*"
 225             whitespace "*)\\)"))
 226   ;; [59] Enumeration ::= '(' S? Nmtoken (S? '|' S? Nmtoken)* S? ')'
 227   ;;       [VC: Enumeration] [VC: No Duplicate Tokens]
 228   (defconst xml-enumeration-re (concat "\\(?:(" whitespace "*" xml-nmtoken-re
 229                                      "\\(?:" whitespace "*|" whitespace "*"
 230                                      xml-nmtoken-re "\\)*"
 231                                      whitespace ")\\)"))
 232   ;; [57] EnumeratedType ::= NotationType | Enumeration
 233   (defconst xml-enumerated-type-re (concat "\\(?:" xml-notation-type-re
 234                                            "\\|" xml-enumeration-re "\\)"))
 235   ;; [54] AttType    ::= StringType | TokenizedType | EnumeratedType
 236   ;; [55] StringType ::= 'CDATA'
 237   (defconst xml-att-type-re (concat "\\(?:CDATA\\|" xml-tokenized-type-re
 238                                     "\\|" xml-notation-type-re
 239                                     "\\|" xml-enumerated-type-re "\\)"))
 240   ;; [60] DefaultDecl ::= '#REQUIRED' | '#IMPLIED' | (('#FIXED' S)? AttValue)
 241   (defconst xml-default-decl-re (concat "\\(?:#REQUIRED\\|#IMPLIED\\|\\(?:#FIXED"
 242                                         whitespace "\\)*" xml-att-value-re "\\)"))
 243   ;; [53] AttDef      ::= S Name S AttType S DefaultDecl
 244   (defconst xml-att-def-re (concat "\\(?:" whitespace "*" xml-name-re
 245                                    whitespace "*" xml-att-type-re
 246                                    whitespace "*" xml-default-decl-re "\\)"))
 247   ;; [9] EntityValue ::= '"' ([^%&"] | PEReference | Reference)* '"'
 248   ;;                   | "'" ([^%&'] | PEReference | Reference)* "'"
 249   (defconst xml-entity-value-re (concat "\\(?:\"\\(?:[^%&\"]\\|" xml-pe-reference-re
 250                                         "\\|" xml-reference-re
 251                                         "\\)*\"\\|'\\(?:[^%&']\\|"
 252                                         xml-pe-reference-re "\\|"
 253                                         xml-reference-re "\\)*'\\)"))))
 254
 255 ;; [75] ExternalID ::= 'SYSTEM' S SystemLiteral
 256 ;;                   | 'PUBLIC' S PubidLiteral S SystemLiteral
 257 ;; [76] NDataDecl ::=           S 'NDATA' S
 258 ;; [73] EntityDef  ::= EntityValue| (ExternalID NDataDecl?)
 259 ;; [71] GEDecl     ::= '<!ENTITY' S Name S EntityDef S? '>'
 260 ;; [74] PEDef      ::= EntityValue | ExternalID
 261 ;; [72] PEDecl     ::= '<!ENTITY' S '%' S Name S PEDef S? '>'
 262 ;; [70] EntityDecl ::= GEDecl | PEDecl
 263
 264 ;; Note that this is setup so that we can do whitespace-skipping with
 265 ;; `(skip-syntax-forward " ")', inter alia.  Previously this was slow
 266 ;; compared with `re-search-forward', but that has been fixed.  Also
 267 ;; note that the standard syntax table contains other characters with
 268 ;; whitespace syntax, like NBSP, but they are invalid in contexts in
 269 ;; which we might skip whitespace -- specifically, they're not
 270 ;; NameChars [XML 4].
 271
 272 (defvar xml-syntax-table
 273   (let ((table (make-syntax-table)))
 274     ;; Get space syntax correct per XML [3].
 275     (dotimes (c 31)
 276       (modify-syntax-entry c "." table)) ; all are space in standard table
 277     (dolist (c '(?\t ?\n ?\r))           ; these should be space
 278       (modify-syntax-entry c " " table))
 279     ;; For skipping attributes.
 280     (modify-syntax-entry ?\" "\"" table)
 281     (modify-syntax-entry ?' "\"" table)
 282     ;; Non-alnum name chars should be symbol constituents (`-' and `_'
 283     ;; are OK by default).
 284     (modify-syntax-entry ?. "_" table)
 285     (modify-syntax-entry ?: "_" table)
 286     ;; XML [89]
 287     (unless (featurep 'xemacs)
 288       (dolist (c '(#x00B7 #x02D0 #x02D1 #x0387 #x0640 #x0E46 #x0EC6 #x3005
 289                           #x3031 #x3032 #x3033 #x3034 #x3035 #x309D #x309E #x30FC
 290                           #x30FD #x30FE))
 291         (modify-syntax-entry (decode-char 'ucs c) "w" table)))
 292     ;; Fixme: rest of [4]
 293     table)
 294   "Syntax table used by `xml-parse-region'.")
 295
 296 ;; XML [5]
 297 ;; Note that [:alpha:] matches all multibyte chars with word syntax.
 298 (eval-and-compile
 299   (defconst xml-name-regexp "[[:alpha:]_:][[:alnum:]._:-]*"))
 300
 301 ;; Fixme:  This needs re-writing to deal with the XML grammar properly, i.e.
 302 ;;   document    ::=    prolog element Misc*
 303 ;;   prolog    ::=    XMLDecl? Misc* (doctypedecl Misc*)?
 304
 305 ;;;###autoload
 306 (defun xml-parse-region (&optional beg end buffer parse-dtd parse-ns)
 307   "Parse the region from BEG to END in BUFFER.
 308 If BEG is nil, it defaults to `point-min'.
 309 If END is nil, it defaults to `point-max'.
 310 If BUFFER is nil, it defaults to the current buffer.
 311 Returns the XML list for the region, or raises an error if the region
 312 is not well-formed XML.
 313 If PARSE-DTD is non-nil, the DTD is parsed rather than skipped,
 314 and returned as the first element of the list.
 315 If PARSE-NS is non-nil, then QNAMES are expanded."
 316   ;; Use fixed syntax table to ensure regexp char classes and syntax
 317   ;; specs DTRT.
 318   (unless buffer
 319     (setq buffer (current-buffer)))
 320   (with-temp-buffer
 321     (insert-buffer-substring-no-properties buffer beg end)
 322     (xml--parse-buffer parse-dtd parse-ns)))
 323
 324 (defun xml--parse-buffer (parse-dtd parse-ns)
 325   (with-syntax-table (standard-syntax-table)
 326     (let ((case-fold-search nil)        ; XML is case-sensitive.
 327           ;; Prevent entity definitions from changing the defaults
 328           (xml-entity-alist xml-entity-alist)
 329           (xml-parameter-entity-alist xml-parameter-entity-alist)
 330           xml result dtd)
 331       (goto-char (point-min))
 332       (while (not (eobp))
 333         (if (search-forward "<" nil t)
 334             (progn
 335               (forward-char -1)
 336               (setq result (xml-parse-tag-1 parse-dtd parse-ns))
 337               (cond
 338                ((null result)
 339                 ;; Not looking at an xml start tag.
 340                 (unless (eobp)
 341                   (forward-char 1)))
 342                ((and xml (not xml-sub-parser))
 343                 ;; Translation of rule [1] of XML specifications
 344                 (error "XML: (Not Well-Formed) Only one root tag allowed"))
 345                ((and (listp (car result))
 346                      parse-dtd)
 347                 (setq dtd (car result))
 348                 (if (cdr result)        ; possible leading comment
 349                     (add-to-list 'xml (cdr result))))
 350                (t
 351                 (add-to-list 'xml result))))
 352           (goto-char (point-max))))
 353       (if parse-dtd
 354           (cons dtd (nreverse xml))
 355         (nreverse xml)))))
 356
 357 (defun xml-maybe-do-ns (name default xml-ns)
 358   "Perform any namespace expansion.
 359 NAME is the name to perform the expansion on.
 360 DEFAULT is the default namespace.  XML-NS is a cons of namespace
 361 names to uris.  When namespace-aware parsing is off, then XML-NS
 362 is nil.
 363
 364 During namespace-aware parsing, any name without a namespace is
 365 put into the namespace identified by DEFAULT.  nil is used to
 366 specify that the name shouldn't be given a namespace."
 367   (if (consp xml-ns)
 368       (let* ((nsp (string-match ":" name))
 369              (lname (if nsp (substring name (match-end 0)) name))
 370              (prefix (if nsp (substring name 0 (match-beginning 0)) default))
 371              (special (and (string-equal lname "xmlns") (not prefix)))
 372              ;; Setting default to nil will insure that there is not
 373              ;; matching cons in xml-ns.  In which case we
 374              (ns (or (cdr (assoc (if special "xmlns" prefix)
 375                                  xml-ns))
 376                      "")))
 377         (cons ns (if special "" lname)))
 378     (intern name)))
 379
 380 (defun xml-parse-fragment (&optional parse-dtd parse-ns)
 381   "Parse xml-like fragments."
 382   (let ((xml-sub-parser t)
 383         ;; Prevent entity definitions from changing the defaults
 384         (xml-entity-alist xml-entity-alist)
 385         (xml-parameter-entity-alist xml-parameter-entity-alist)
 386         children)
 387     (while (not (eobp))
 388       (let ((bit (xml-parse-tag-1 parse-dtd parse-ns)))
 389         (if children
 390             (setq children (append (list bit) children))
 391           (if (stringp bit)
 392               (setq children (list bit))
 393             (setq children bit)))))
 394     (reverse children)))
 395
 396 (defun xml-parse-tag (&optional parse-dtd parse-ns)
 397   "Parse the tag at point.
 398 If PARSE-DTD is non-nil, the DTD of the document, if any, is parsed and
 399 returned as the first element in the list.
 400 If PARSE-NS is non-nil, expand QNAMES; if the value of PARSE-NS
 401 is a list, use it as an alist mapping namespaces to URIs.
 402
 403 Return one of:
 404  - a list : the matching node
 405  - nil    : the point is not looking at a tag.
 406  - a pair : the first element is the DTD, the second is the node."
 407   (let ((buf (current-buffer))
 408         (pos (point)))
 409     (with-temp-buffer
 410       (insert-buffer-substring-no-properties buf pos)
 411       (goto-char (point-min))
 412       (xml-parse-tag-1 parse-dtd parse-ns))))
 413
 414 (defun xml-parse-tag-1 (&optional parse-dtd parse-ns)
 415   "Like `xml-parse-tag', but possibly modify the buffer while working."
 416   (let ((xml-validating-parser (or parse-dtd xml-validating-parser))
 417         (xml-ns (cond ((consp parse-ns) parse-ns)
 418                       (parse-ns xml-default-ns))))
 419     (cond
 420      ;; Processing instructions, like <?xml version="1.0"?>.
 421      ((looking-at "<\\?")
 422       (search-forward "?>")
 423       (skip-syntax-forward " ")
 424       (xml-parse-tag-1 parse-dtd xml-ns))
 425      ;; Character data (CDATA) sections, in which no tag should be interpreted
 426      ((looking-at "<!\\[CDATA\\[")
 427       (let ((pos (match-end 0)))
 428         (unless (search-forward "]]>" nil t)
 429           (error "XML: (Not Well Formed) CDATA section does not end anywhere in the document"))
 430         (concat
 431          (buffer-substring-no-properties pos (match-beginning 0))
 432          (xml-parse-string))))
 433      ;; DTD for the document
 434      ((looking-at "<!DOCTYPE[ \t\n\r]")
 435       (let ((dtd (xml-parse-dtd parse-ns)))
 436         (skip-syntax-forward " ")
 437         (if xml-validating-parser
 438             (cons dtd (xml-parse-tag-1 nil xml-ns))
 439           (xml-parse-tag-1 nil xml-ns))))
 440      ;; skip comments
 441      ((looking-at "<!--")
 442       (search-forward "-->")
 443       ;; FIXME: This loses the skipped-over spaces.
 444       (skip-syntax-forward " ")
 445       (unless (eobp)
 446         (let ((xml-sub-parser t))
 447           (xml-parse-tag-1 parse-dtd xml-ns))))
 448      ;; end tag
 449      ((looking-at "</")
 450       '())
 451      ;; opening tag
 452      ((looking-at (eval-when-compile (concat "<\\(" xml-name-re "\\)")))
 453       (goto-char (match-end 1))
 454       ;; Parse this node
 455       (let* ((node-name (match-string-no-properties 1))
 456              ;; Parse the attribute list.
 457              (attrs (xml-parse-attlist xml-ns))
 458              children)
 459         ;; add the xmlns:* attrs to our cache
 460         (when (consp xml-ns)
 461           (dolist (attr attrs)
 462             (when (and (consp (car attr))
 463                        (equal "http://www.w3.org/2000/xmlns/"
 464                               (caar attr)))
 465               (push (cons (cdar attr) (cdr attr))
 466                     xml-ns))))
 467         (setq children (list attrs (xml-maybe-do-ns node-name "" xml-ns)))
 468         (cond
 469          ;; is this an empty element ?
 470          ((looking-at "/>")
 471           (forward-char 2)
 472           (nreverse children))
 473          ;; is this a valid start tag ?
 474          ((eq (char-after) ?>)
 475           (forward-char 1)
 476           ;; Now check that we have the right end-tag.
 477           (let ((end (concat "</" node-name "\\s-*>")))
 478             (while (not (looking-at end))
 479               (cond
 480                ((eobp)
 481                 (error "XML: (Not Well-Formed) End of document while reading element `%s'"
 482                        node-name))
 483                ((looking-at "</")
 484                 (forward-char 2)
 485                 (error "XML: (Not Well-Formed) Invalid end tag `%s' (expecting `%s')"
 486                        (let ((pos (point)))
 487                          (buffer-substring pos (if (re-search-forward "\\s-*>" nil t)
 488                                                    (match-beginning 0)
 489                                                  (point-max))))
 490                        node-name))
 491                ;; Read a sub-element and push it onto CHILDREN.
 492                ((= (char-after) ?<)
 493                 (let ((tag (xml-parse-tag-1 nil xml-ns)))
 494                   (when tag
 495                     (push tag children))))
 496                ;; Read some character data.
 497                (t
 498                 (let ((expansion (xml-parse-string)))
 499                   (push (if (stringp (car children))
 500                             ;; If two strings were separated by a
 501                             ;; comment, concat them.
 502                             (concat (pop children) expansion)
 503                           expansion)
 504                         children)))))
 505             ;; Move point past the end-tag.
 506             (goto-char (match-end 0))
 507             (nreverse children)))
 508          ;; Otherwise this was an invalid start tag (expected ">" not found.)
 509          (t
 510           (error "XML: (Well-Formed) Couldn't parse tag: %s"
 511                  (buffer-substring-no-properties (- (point) 10) (+ (point) 1)))))))
 512
 513      ;; (Not one of PI, CDATA, Comment, End tag, or Start tag)
 514      (t
 515       (unless xml-sub-parser   ; Usually, we error out.
 516         (error "XML: (Well-Formed) Invalid character"))
 517       ;; However, if we're parsing incrementally, then we need to deal
 518       ;; with stray CDATA.
 519       (xml-parse-string)))))
 520
 521 (defun xml-parse-string ()
 522   "Parse character data at point, and return it as a string.
 523 Leave point at the start of the next thing to parse.  This
 524 function can modify the buffer by expanding entity and character
 525 references."
 526   (let ((start (point))
 527         ;; Keep track of the size of the rest of the buffer:
 528         (old-remaining-size (- (buffer-size) (point)))
 529         ref val)
 530     (while (and (not (eobp))
 531                 (not (looking-at "<")))
 532       ;; Find the next < or & character.
 533       (skip-chars-forward "^<&")
 534       (when (eq (char-after) ?&)
 535         ;; If we find an entity or character reference, expand it.
 536         (unless (looking-at (eval-when-compile
 537                               (concat "&\\(?:#\\([0-9]+\\)\\|#x\\([0-9a-fA-F]+\\)\\|\\("
 538                                       xml-name-re "\\)\\);")))
 539           (error "XML: (Not Well-Formed) Invalid entity reference"))
 540         ;; For a character reference, the next entity or character
 541         ;; reference must be after the replacement.  [4.6] "Numerical
 542         ;; character references are expanded immediately when
 543         ;; recognized and MUST be treated as character data."
 544         (cond ((setq ref (match-string 1))
 545                ;; Decimal character reference
 546                (setq val (save-match-data
 547                            (decode-char 'ucs (string-to-number ref))))
 548                (and (null val)
 549                     xml-validating-parser
 550                     (error "XML: (Validity) Invalid character `%s'" ref))
 551                (replace-match (or (string val) xml-undefined-entity) t t))
 552               ;; Hexadecimal character reference
 553               ((setq ref (match-string 2))
 554                (setq val (save-match-data
 555                            (decode-char 'ucs (string-to-number ref 16))))
 556                (and (null val)
 557                     xml-validating-parser
 558                     (error "XML: (Validity) Invalid character `x%s'" ref))
 559                (replace-match (or (string val) xml-undefined-entity) t t))
 560               ;; For an entity reference, search again from the start
 561               ;; of the replaced text, since the replacement can
 562               ;; contain entity or character references, or markup.
 563               ((setq ref (match-string 3))
 564                (setq val (assoc ref xml-entity-alist))
 565                (and (null val)
 566                     xml-validating-parser
 567                     (error "XML: (Validity) Undefined entity `%s'" ref))
 568                (replace-match (cdr val) t t)
 569                (goto-char (match-beginning 0))))
 570         ;; Check for XML bombs.
 571         (and xml-entity-expansion-limit
 572              (> (- (buffer-size) (point))
 573                 (+ old-remaining-size xml-entity-expansion-limit))
 574              (error "XML: Entity reference expansion \
 575 surpassed `xml-entity-expansion-limit'"))))
 576     ;; [2.11] Clean up line breaks.
 577     (let ((end-marker (point-marker)))
 578       (goto-char start)
 579       (while (re-search-forward "\r\n?" end-marker t)
 580         (replace-match "\n" t t))
 581       (goto-char end-marker)
 582       (buffer-substring start (point)))))
 583
 584 (defun xml-parse-attlist (&optional xml-ns)
 585   "Return the attribute-list after point.
 586 Leave point at the first non-blank character after the tag."
 587   (let ((attlist ())
 588         end-pos name)
 589     (skip-syntax-forward " ")
 590     (while (looking-at (eval-when-compile
 591                          (concat "\\(" xml-name-regexp "\\)\\s-*=\\s-*")))
 592       (setq end-pos (match-end 0))
 593       (setq name (xml-maybe-do-ns (match-string-no-properties 1) nil xml-ns))
 594       (goto-char end-pos)
 595
 596       ;; See also: http://www.w3.org/TR/2000/REC-xml-20001006#AVNormalize
 597
 598       ;; Do we have a string between quotes (or double-quotes),
 599       ;;  or a simple word ?
 600       (if (looking-at "\"\\([^\"]*\\)\"")
 601           (setq end-pos (match-end 0))
 602         (if (looking-at "'\\([^']*\\)'")
 603             (setq end-pos (match-end 0))
 604           (error "XML: (Not Well-Formed) Attribute values must be given between quotes")))
 605
 606       ;; Each attribute must be unique within a given element
 607       (if (assoc name attlist)
 608           (error "XML: (Not Well-Formed) Each attribute must be unique within an element"))
 609
 610       ;; Multiple whitespace characters should be replaced with a single one
 611       ;; in the attributes
 612       (let ((string (match-string-no-properties 1)))
 613         (replace-regexp-in-string "\\s-\\{2,\\}" " " string)
 614         (let ((expansion (xml-substitute-special string)))
 615           (unless (stringp expansion)
 616                                         ; We say this is the constraint.  It is actually that neither
 617                                         ; external entities nor "<" can be in an attribute value.
 618             (error "XML: (Not Well-Formed) Entities in attributes cannot expand into elements"))
 619           (push (cons name expansion) attlist)))
 620
 621       (goto-char end-pos)
 622       (skip-syntax-forward " "))
 623     (nreverse attlist)))
 624
 625 ;;; DTD (document type declaration)
 626
 627 ;; The following functions know how to skip or parse the DTD of a
 628 ;; document.  FIXME: it fails at least if the DTD contains conditional
 629 ;; sections.
 630
 631 (defun xml-skip-dtd ()
 632   "Skip the DTD at point.
 633 This follows the rule [28] in the XML specifications."
 634   (let ((xml-validating-parser nil))
 635     (xml-parse-dtd)))
 636
 637 (defun xml-parse-dtd (&optional parse-ns)
 638   "Parse the DTD at point."
 639   (forward-char (eval-when-compile (length "<!DOCTYPE")))
 640   (skip-syntax-forward " ")
 641   (if (and (looking-at ">")
 642            xml-validating-parser)
 643       (error "XML: (Validity) Invalid DTD (expecting name of the document)"))
 644
 645   ;;  Get the name of the document
 646   (looking-at xml-name-regexp)
 647   (let ((dtd (list (match-string-no-properties 0) 'dtd))
 648         (xml-parameter-entity-alist xml-parameter-entity-alist)
 649         (parameter-entity-re (eval-when-compile
 650                                (concat "%\\(" xml-name-re "\\);")))
 651         next-parameter-entity)
 652     (goto-char (match-end 0))
 653     (skip-syntax-forward " ")
 654
 655     ;; External subset (XML [75])
 656     (cond ((looking-at "PUBLIC\\s-+")
 657            (goto-char (match-end 0))
 658            (unless (or (re-search-forward
 659                         "\\=\"\\([[:space:][:alnum:]-'()+,./:=?;!*#@$_%]*\\)\""
 660                         nil t)
 661                        (re-search-forward
 662                         "\\='\\([[:space:][:alnum:]-()+,./:=?;!*#@$_%]*\\)'"
 663                         nil t))
 664              (error "XML: Missing Public ID"))
 665            (let ((pubid (match-string-no-properties 1)))
 666              (skip-syntax-forward " ")
 667              (unless (or (re-search-forward "\\='\\([^']*\\)'" nil t)
 668                          (re-search-forward "\\=\"\\([^\"]*\\)\"" nil t))
 669                (error "XML: Missing System ID"))
 670              (push (list pubid (match-string-no-properties 1) 'public) dtd)))
 671           ((looking-at "SYSTEM\\s-+")
 672            (goto-char (match-end 0))
 673            (unless (or (re-search-forward "\\='\\([^']*\\)'" nil t)
 674                        (re-search-forward "\\=\"\\([^\"]*\\)\"" nil t))
 675              (error "XML: Missing System ID"))
 676            (push (list (match-string-no-properties 1) 'system) dtd)))
 677     (skip-syntax-forward " ")
 678
 679     (if (eq (char-after) ?>)
 680
 681         ;; No internal subset
 682         (forward-char)
 683
 684       ;; Internal subset (XML [28b])
 685       (unless (eq (char-after) ?\[)
 686         (error "XML: Bad DTD"))
 687       (forward-char)
 688
 689       ;; [2.8]: "markup declarations may be made up in whole or in
 690       ;; part of the replacement text of parameter entities."
 691
 692       ;; Since parameter entities are valid only within the DTD, we
 693       ;; first search for the position of the next possible parameter
 694       ;; entity.  Then, search for the next DTD element; if it ends
 695       ;; before the next parameter entity, expand the parameter entity
 696       ;; and try again.
 697       (setq next-parameter-entity
 698             (save-excursion
 699               (if (re-search-forward parameter-entity-re nil t)
 700                   (match-beginning 0))))
 701
 702       ;; Parse the rest of the DTD
 703       ;; Fixme: Deal with NOTATION, PIs.
 704       (while (not (looking-at "\\s-*\\]"))
 705         (skip-syntax-forward " ")
 706         (cond
 707          ((eobp)
 708           (error "XML: (Well-Formed) End of document while reading DTD"))
 709          ;; Element declaration [45]:
 710          ((and (looking-at (eval-when-compile
 711                              (concat "<!ELEMENT\\s-+\\(" xml-name-re
 712                                      "\\)\\s-+\\([^>]+\\)>")))
 713                (or (null next-parameter-entity)
 714                    (<= (match-end 0) next-parameter-entity)))
 715           (let ((element (match-string-no-properties 1))
 716                 (type    (match-string-no-properties 2))
 717                 (end-pos (match-end 0)))
 718             ;; Translation of rule [46] of XML specifications
 719             (cond
 720              ((string-match "\\`EMPTY\\s-*\\'" type)  ; empty declaration
 721               (setq type 'empty))
 722              ((string-match "\\`ANY\\s-*$" type)      ; any type of contents
 723               (setq type 'any))
 724              ((string-match "\\`(\\(.*\\))\\s-*\\'" type) ; children ([47])
 725               (setq type (xml-parse-elem-type
 726                           (match-string-no-properties 1 type))))
 727              ((string-match "^%[^;]+;[ \t\n\r]*\\'" type) ; substitution
 728               nil)
 729              (xml-validating-parser
 730               (error "XML: (Validity) Invalid element type in the DTD")))
 731
 732             ;; rule [45]: the element declaration must be unique
 733             (and (assoc element dtd)
 734                  xml-validating-parser
 735                  (error "XML: (Validity) DTD element declarations must be unique (<%s>)"
 736                         element))
 737
 738             ;;  Store the element in the DTD
 739             (push (list element type) dtd)
 740             (goto-char end-pos)))
 741
 742          ;; Attribute-list declaration [52] (currently unsupported):
 743          ((and (looking-at (eval-when-compile
 744                              (concat "<!ATTLIST[ \t\n\r]*\\(" xml-name-re
 745                                      "\\)[ \t\n\r]*\\(" xml-att-def-re
 746                                      "\\)*[ \t\n\r]*>")))
 747                (or (null next-parameter-entity)
 748                    (<= (match-end 0) next-parameter-entity)))
 749           (goto-char (match-end 0)))
 750
 751          ;; Comments (skip to end, ignoring parameter entity):
 752          ((looking-at "<!--")
 753           (search-forward "-->")
 754           (and next-parameter-entity
 755                (> (point) next-parameter-entity)
 756                (setq next-parameter-entity
 757                      (save-excursion
 758                        (if (re-search-forward parameter-entity-re nil t)
 759                            (match-beginning 0))))))
 760
 761          ;; Internal entity declarations:
 762          ((and (looking-at (eval-when-compile
 763                              (concat "<!ENTITY[ \t\n\r]+\\(%[ \t\n\r]+\\)?\\("
 764                                      xml-name-re "\\)[ \t\n\r]*\\("
 765                                      xml-entity-value-re "\\)[ \t\n\r]*>")))
 766                (or (null next-parameter-entity)
 767                    (<= (match-end 0) next-parameter-entity)))
 768           (let* ((name (prog1 (match-string-no-properties 2)
 769                          (goto-char (match-end 0))))
 770                  (alist (if (match-string 1)
 771                             'xml-parameter-entity-alist
 772                           'xml-entity-alist))
 773                  ;; Retrieve the deplacement text:
 774                  (value (xml--entity-replacement-text
 775                          ;; Entity value, sans quotation marks:
 776                          (substring (match-string-no-properties 3) 1 -1))))
 777             ;; If the same entity is declared more than once, the
 778             ;; first declaration is binding.
 779             (unless (assoc name (symbol-value alist))
 780               (set alist (cons (cons name value) (symbol-value alist))))))
 781
 782          ;; External entity declarations (currently unsupported):
 783          ((and (or (looking-at (eval-when-compile
 784                                  (concat "<!ENTITY[ \t\n\r]+\\(%[ \t\n\r]+\\)?\\("
 785                                          xml-name-re "\\)[ \t\n\r]+SYSTEM[ \t\n\r]+"
 786                                          "\\(\"[^\"]*\"\\|'[^']*'\\)[ \t\n\r]*>")))
 787                    (looking-at (eval-when-compile
 788                                  (concat "<!ENTITY[ \t\n\r]+\\(%[ \t\n\r]+\\)?\\("
 789                                          xml-name-re "\\)[ \t\n\r]+PUBLIC[ \t\n\r]+"
 790                                          "\"[- \r\na-zA-Z0-9'()+,./:=?;!*#@$_%]*\""
 791                                          "\\|'[- \r\na-zA-Z0-9()+,./:=?;!*#@$_%]*'"
 792                                          "[ \t\n\r]+\\(\"[^\"]*\"\\|'[^']*'\\)"
 793                                          "[ \t\n\r]*>"))))
 794                (or (null next-parameter-entity)
 795                    (<= (match-end 0) next-parameter-entity)))
 796           (goto-char (match-end 0)))
 797
 798          ;; If a parameter entity is in the way, expand it.
 799          (next-parameter-entity
 800           (save-excursion
 801             (goto-char next-parameter-entity)
 802             (unless (looking-at parameter-entity-re)
 803               (error "XML: Internal error"))
 804             (let* ((entity (match-string 1))
 805                    (beg    (point-marker))
 806                    (elt    (assoc entity xml-parameter-entity-alist)))
 807               (if elt
 808                   (progn
 809                     (replace-match (cdr elt) t t)
 810                     ;; The replacement can itself be a parameter entity.
 811                     (goto-char next-parameter-entity))
 812                 (goto-char (match-end 0))))
 813             (setq next-parameter-entity
 814                   (if (re-search-forward parameter-entity-re nil t)
 815                       (match-beginning 0)))))
 816
 817          ;; Anything else is garbage (ignored if not validating).
 818          (xml-validating-parser
 819           (error "XML: (Validity) Invalid DTD item"))
 820          (t
 821           (skip-chars-forward "^]"))))
 822
 823       (if (looking-at "\\s-*]>")
 824           (goto-char (match-end 0))))
 825     (nreverse dtd)))
 826
 827 (defun xml--entity-replacement-text (string)
 828   "Return the replacement text for the entity value STRING.
 829 The replacement text is obtained by replacing character
 830 references and parameter-entity references."
 831   (let ((ref-re (eval-when-compile
 832                   (concat "\\(?:&#\\([0-9]+\\)\\|&#x\\([0-9a-fA-F]+\\)\\|%\\("
 833                           xml-name-re "\\)\\);")))
 834         children)
 835     (while (string-match ref-re string)
 836       (push (substring string 0 (match-beginning 0)) children)
 837       (let ((remainder (substring string (match-end 0)))
 838             ref val)
 839         (cond ((setq ref (match-string 1 string))
 840                ;; Decimal character reference
 841                (setq val (decode-char 'ucs (string-to-number ref)))
 842                (if val (push (string val) children)))
 843               ;; Hexadecimal character reference
 844               ((setq ref (match-string 2 string))
 845                (setq val (decode-char 'ucs (string-to-number ref 16)))
 846                (if val (push (string val) children)))
 847               ;; Parameter entity reference
 848               ((setq ref (match-string 3 string))
 849                (setq val (assoc ref xml-parameter-entity-alist))
 850                (and (null val)
 851                     xml-validating-parser
 852                     (error "XML: (Validity) Undefined parameter entity `%s'" ref))
 853                (push (or (cdr val) xml-undefined-entity) children)))
 854         (setq string remainder)))
 855     (mapconcat 'identity (nreverse (cons string children)) "")))
 856
 857 (defun xml-parse-elem-type (string)
 858   "Convert element type STRING into a Lisp structure."
 859
 860   (let (elem modifier)
 861     (if (string-match "(\\([^)]+\\))\\([+*?]?\\)" string)
 862         (progn
 863           (setq elem     (match-string-no-properties 1 string)
 864                 modifier (match-string-no-properties 2 string))
 865           (if (string-match "|" elem)
 866               (setq elem (cons 'choice
 867                                (mapcar 'xml-parse-elem-type
 868                                        (split-string elem "|"))))
 869             (if (string-match "," elem)
 870                 (setq elem (cons 'seq
 871                                  (mapcar 'xml-parse-elem-type
 872                                          (split-string elem ",")))))))
 873       (if (string-match "[ \t\n\r]*\\([^+*?]+\\)\\([+*?]?\\)" string)
 874           (setq elem     (match-string-no-properties 1 string)
 875                 modifier (match-string-no-properties 2 string))))
 876
 877     (if (and (stringp elem) (string= elem "#PCDATA"))
 878         (setq elem 'pcdata))
 879
 880     (cond
 881      ((string= modifier "+")
 882       (list '+ elem))
 883      ((string= modifier "*")
 884       (list '* elem))
 885      ((string= modifier "?")
 886       (list '\? elem))
 887      (t
 888       elem))))
 889
 890 ;;; Substituting special XML sequences
 891
 892 (defun xml-substitute-special (string)
 893   "Return STRING, after substituting entity and character references.
 894 STRING is assumed to occur in an XML attribute value."
 895   (let ((ref-re (eval-when-compile
 896                   (concat "&\\(?:#\\(x\\)?\\([0-9]+\\)\\|\\("
 897                           xml-name-re "\\)\\);")))
 898         (strlen (length string))
 899         children)
 900     (while (string-match ref-re string)
 901       (push (substring string 0 (match-beginning 0)) children)
 902       (let* ((remainder (substring string (match-end 0)))
 903              (ref (match-string 2 string)))
 904         (if ref
 905             ;; [4.6] Character references are included as
 906             ;; character data.
 907             (let ((val (decode-char 'ucs (string-to-number
 908                                           ref (if (match-string 1 string) 16)))))
 909               (push (cond (val (string val))
 910                           (xml-validating-parser
 911                            (error "XML: (Validity) Undefined character `x%s'" ref))
 912                           (t xml-undefined-entity))
 913                     children)
 914               (setq string remainder
 915                     strlen (length string)))
 916           ;; [4.4.5] Entity references are "included in literal".
 917           ;; Note that we don't need do anything special to treat
 918           ;; quotes as normal data characters.
 919           (setq ref (match-string 3 string))
 920           (let ((val (or (cdr (assoc ref xml-entity-alist))
 921                          (if xml-validating-parser
 922                              (error "XML: (Validity) Undefined entity `%s'" ref)
 923                            xml-undefined-entity))))
 924             (setq string (concat val remainder)))
 925           (and xml-entity-expansion-limit
 926                (> (length string) (+ strlen xml-entity-expansion-limit))
 927                (error "XML: Passed `xml-entity-expansion-limit' while expanding `&%s;'"
 928                       ref)))))
 929     (mapconcat 'identity (nreverse (cons string children)) "")))
 930
 931 (defun xml-substitute-numeric-entities (string)
 932   "Substitute SGML numeric entities by their respective utf characters.
 933 This function replaces numeric entities in the input STRING and
 934 returns the modified string.  For example \"&#42;\" gets replaced
 935 by \"*\"."
 936   (if (and string (stringp string))
 937       (let ((start 0))
 938         (while (string-match "&#\\([0-9]+\\);" string start)
 939           (condition-case nil
 940               (setq string (replace-match
 941                             (string (read (substring string
 942                                                      (match-beginning 1)
 943                                                      (match-end 1))))
 944                             nil nil string))
 945             (error nil))
 946           (setq start (1+ (match-beginning 0))))
 947         string)
 948     nil))
 949
 950 ;;; Printing a parse tree (mainly for debugging).
 951
 952 (defun xml-debug-print (xml &optional indent-string)
 953   "Outputs the XML in the current buffer.
 954 XML can be a tree or a list of nodes.
 955 The first line is indented with the optional INDENT-STRING."
 956   (setq indent-string (or indent-string ""))
 957   (dolist (node xml)
 958     (xml-debug-print-internal node indent-string)))
 959
 960 (defalias 'xml-print 'xml-debug-print)
 961
 962 (defun xml-escape-string (string)
 963   "Return STRING with entity substitutions made from `xml-entity-alist'."
 964   (mapconcat (lambda (byte)
 965                (let ((char (char-to-string byte)))
 966                  (if (rassoc char xml-entity-alist)
 967                      (concat "&" (car (rassoc char xml-entity-alist)) ";")
 968                    char)))
 969              string ""))
 970
 971 (defun xml-debug-print-internal (xml indent-string)
 972   "Outputs the XML tree in the current buffer.
 973 The first line is indented with INDENT-STRING."
 974   (let ((tree xml)
 975         attlist)
 976     (insert indent-string ?< (symbol-name (xml-node-name tree)))
 977
 978     ;;  output the attribute list
 979     (setq attlist (xml-node-attributes tree))
 980     (while attlist
 981       (insert ?\  (symbol-name (caar attlist)) "=\""
 982               (xml-escape-string (cdar attlist)) ?\")
 983       (setq attlist (cdr attlist)))
 984
 985     (setq tree (xml-node-children tree))
 986
 987     (if (null tree)
 988         (insert ?/ ?>)
 989       (insert ?>)
 990
 991       ;;  output the children
 992       (dolist (node tree)
 993         (cond
 994          ((listp node)
 995           (insert ?\n)
 996           (xml-debug-print-internal node (concat indent-string "  ")))
 997          ((stringp node)
 998           (insert (xml-escape-string node)))
 999          (t
1000           (error "Invalid XML tree"))))
1001
1002       (when (not (and (null (cdr tree))
1003                       (stringp (car tree))))
1004         (insert ?\n indent-string))
1005       (insert ?< ?/ (symbol-name (xml-node-name xml)) ?>))))
1006
1007 (provide 'xml)
1008
1009 ;;; xml.el ends here