lisp/xml.el

   1 ;;; xml.el --- XML parser
   2
   3 ;; Copyright (C) 2000, 01, 03, 2004  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 2, or (at your option)
  14 ;; 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; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Commentary:
  27
  28 ;; This file contains a somewhat incomplete non-validating XML parser.  It
  29 ;; parses a file, and returns a list that can be used internally by
  30 ;; any other lisp libraries.
  31
  32 ;;; FILE FORMAT
  33
  34 ;; The document type declaration may either be ignored or (optionally)
  35 ;; parsed, but currently the parsing will only accept element
  36 ;; declarations.  The XML file is assumed to be well-formed. In case
  37 ;; of error, the parsing stops and the XML file is shown where the
  38 ;; parsing stopped.
  39 ;;
  40 ;; It also knows how to ignore comments and processing instructions.
  41 ;;
  42 ;; The XML file should have the following format:
  43 ;;    <node1 attr1="name1" attr2="name2" ...>value
  44 ;;       <node2 attr3="name3" attr4="name4">value2</node2>
  45 ;;       <node3 attr5="name5" attr6="name6">value3</node3>
  46 ;;    </node1>
  47 ;; Of course, the name of the nodes and attributes can be anything. There can
  48 ;; be any number of attributes (or none), as well as any number of children
  49 ;; below the nodes.
  50 ;;
  51 ;; There can be only top level node, but with any number of children below.
  52
  53 ;;; LIST FORMAT
  54
  55 ;; The functions `xml-parse-file' and `xml-parse-tag' return a list with
  56 ;; the following format:
  57 ;;
  58 ;;    xml-list   ::= (node node ...)
  59 ;;    node       ::= (tag_name attribute-list . child_node_list)
  60 ;;    child_node_list ::= child_node child_node ...
  61 ;;    child_node ::= node | string
  62 ;;    tag_name   ::= string
  63 ;;    attribute_list ::= (("attribute" . "value") ("attribute" . "value") ...)
  64 ;;                       | nil
  65 ;;    string     ::= "..."
  66 ;;
  67 ;; Some macros are provided to ease the parsing of this list.
  68 ;; Whitespace is preserved.  Fixme: There should be a tree-walker that
  69 ;; can remove it.
  70
  71 ;;; Code:
  72
  73 ;; Note that {buffer-substring,match-string}-no-properties were
  74 ;; formerly used in several places, but that removes composition info.
  75
  76 ;;*******************************************************************
  77 ;;**
  78 ;;**  Macros to parse the list
  79 ;;**
  80 ;;*******************************************************************
  81
  82 (defsubst xml-node-name (node)
  83   "Return the tag associated with NODE.
  84 The tag is a lower-case symbol."
  85   (car node))
  86
  87 (defsubst xml-node-attributes (node)
  88   "Return the list of attributes of NODE.
  89 The list can be nil."
  90   (nth 1 node))
  91
  92 (defsubst xml-node-children (node)
  93   "Return the list of children of NODE.
  94 This is a list of nodes, and it can be nil."
  95   (cddr node))
  96
  97 (defun xml-get-children (node child-name)
  98   "Return the children of NODE whose tag is CHILD-NAME.
  99 CHILD-NAME should be a lower case symbol."
 100   (let ((match ()))
 101     (dolist (child (xml-node-children node))
 102       (if child
 103           (if (equal (xml-node-name child) child-name)
 104               (push child match))))
 105     (nreverse match)))
 106
 107 (defun xml-get-attribute-or-nil (node attribute)
 108   "Get from NODE the value of ATTRIBUTE.
 109 Return `nil' if the attribute was not found.
 110
 111 See also `xml-get-attribute'."
 112   (cdr (assoc attribute (xml-node-attributes node))))
 113
 114 (defsubst xml-get-attribute (node attribute)
 115   "Get from NODE the value of ATTRIBUTE.
 116 An empty string is returned if the attribute was not found.
 117
 118 See also `xml-get-attribute-or-nil'."
 119   (or (xml-get-attribute-or-nil node attribute) ""))
 120
 121 ;;*******************************************************************
 122 ;;**
 123 ;;**  Creating the list
 124 ;;**
 125 ;;*******************************************************************
 126
 127 ;;;###autoload
 128 (defun xml-parse-file (file &optional parse-dtd parse-ns)
 129   "Parse the well-formed XML file FILE.
 130 If FILE is already visited, use its buffer and don't kill it.
 131 Returns the top node with all its children.
 132 If PARSE-DTD is non-nil, the DTD is parsed rather than skipped.
 133 If PARSE-NS is non-nil, then QNAMES are expanded."
 134   (let ((keep))
 135     (if (get-file-buffer file)
 136         (progn
 137           (set-buffer (get-file-buffer file))
 138           (setq keep (point)))
 139       (let (auto-mode-alist)            ; no need for xml-mode
 140         (find-file file)))
 141
 142     (let ((xml (xml-parse-region (point-min)
 143                                  (point-max)
 144                                  (current-buffer)
 145                                  parse-dtd parse-ns)))
 146       (if keep
 147           (goto-char keep)
 148         (kill-buffer (current-buffer)))
 149       xml)))
 150
 151 ;; Note that this is setup so that we can do whitespace-skipping with
 152 ;; `(skip-syntax-forward " ")', inter alia.  Previously this was slow
 153 ;; compared with `re-search-forward', but that has been fixed.  Also
 154 ;; note that the standard syntax table contains other characters with
 155 ;; whitespace syntax, like NBSP, but they are invalid in contexts in
 156 ;; which we might skip whitespace -- specifically, they're not
 157 ;; NameChars [XML 4].
 158
 159 (defvar xml-syntax-table
 160   (let ((table (make-syntax-table)))
 161     ;; Get space syntax correct per XML [3].
 162     (dotimes (c 31)
 163       (modify-syntax-entry c "." table)) ; all are space in standard table
 164     (dolist (c '(?\t ?\n ?\r))          ; these should be space
 165       (modify-syntax-entry c " " table))
 166     ;; For skipping attributes.
 167     (modify-syntax-entry ?\" "\"" table)
 168     (modify-syntax-entry ?' "\"" table)
 169     ;; Non-alnum name chars should be symbol constituents (`-' and `_'
 170     ;; are OK by default).
 171     (modify-syntax-entry ?. "_" table)
 172     (modify-syntax-entry ?: "_" table)
 173     ;; XML [89]
 174     (dolist (c '(#x00B7 #x02D0 #x02D1 #x0387 #x0640 #x0E46 #x0EC6 #x3005
 175                  #x3031 #x3032 #x3033 #x3034 #x3035 #x309D #x309E #x30FC
 176                  #x30FD #x30FE))
 177       (modify-syntax-entry (decode-char 'ucs c) "w" table))
 178     ;; Fixme: rest of [4]
 179     table)
 180   "Syntax table used by `xml-parse-region'.")
 181
 182 ;; XML [5]
 183 ;; Note that [:alpha:] matches all multibyte chars with word syntax.
 184 (eval-and-compile
 185   (defconst xml-name-regexp "[[:alpha:]_:][[:alnum:]._:-]*"))
 186
 187 ;; Fixme:  This needs re-writing to deal with the XML grammar properly, i.e.
 188 ;;   document    ::=    prolog element Misc*
 189 ;;   prolog    ::=    XMLDecl? Misc* (doctypedecl Misc*)?
 190
 191 ;;;###autoload
 192 (defun xml-parse-region (beg end &optional buffer parse-dtd parse-ns)
 193   "Parse the region from BEG to END in BUFFER.
 194 If BUFFER is nil, it defaults to the current buffer.
 195 Returns the XML list for the region, or raises an error if the region
 196 is not well-formed XML.
 197 If PARSE-DTD is non-nil, the DTD is parsed rather than skipped,
 198 and returned as the first element of the list.
 199 If PARSE-NS is non-nil, then QNAMES are expanded."
 200   (save-restriction
 201     (narrow-to-region beg end)
 202     ;; Use fixed syntax table to ensure regexp char classes and syntax
 203     ;; specs DTRT.
 204     (with-syntax-table (standard-syntax-table)
 205       (let ((case-fold-search nil)      ; XML is case-sensitive.
 206             xml result dtd)
 207         (save-excursion
 208           (if buffer
 209               (set-buffer buffer))
 210           (goto-char (point-min))
 211           (while (not (eobp))
 212             (if (search-forward "<" nil t)
 213                 (progn
 214                   (forward-char -1)
 215                   (setq result (xml-parse-tag parse-dtd parse-ns))
 216                   (if (and xml result)
 217                       ;;  translation of rule [1] of XML specifications
 218                       (error "XML files can have only one toplevel tag")
 219                     (cond
 220                      ((null result))
 221                      ((and (listp (car result))
 222                            parse-dtd)
 223                       (setq dtd (car result))
 224                       (if (cdr result)  ; possible leading comment
 225                           (add-to-list 'xml (cdr result))))
 226                      (t
 227                       (add-to-list 'xml result)))))
 228               (goto-char (point-max))))
 229           (if parse-dtd
 230               (cons dtd (nreverse xml))
 231             (nreverse xml)))))))
 232
 233 (defun xml-ns-parse-ns-attrs (attr-list &optional xml-ns)
 234   "Parse the namespace attributes and return a list of cons in the form:
 235 \(namespace . prefix)"
 236
 237   (mapcar
 238    (lambda (attr)
 239      (let* ((splitup (split-string (car attr) ":"))
 240             (prefix (nth 0 splitup))
 241             (lname (nth 1 splitup)))
 242        (when (string= "xmlns" prefix)
 243          (push (cons (if lname
 244                          lname
 245                        "")
 246                      (cdr attr))
 247                xml-ns)))) attr-list)
 248   xml-ns)
 249
 250 ;; expand element names
 251 (defun xml-ns-expand-el (el xml-ns)
 252   "Expand the XML elements from \"prefix:local-name\" to a cons in the form
 253 \"(namespace . local-name)\"."
 254
 255   (let* ((splitup (split-string el ":"))
 256          (lname (or (nth 1 splitup)
 257                     (nth 0 splitup)))
 258          (prefix (if (nth 1 splitup)
 259                      (nth 0 splitup)
 260                    (if (string= lname "xmlns")
 261                        "xmlns"
 262                      "")))
 263          (ns (cdr (assoc-string prefix xml-ns))))
 264     (if (string= "" ns)
 265         lname
 266       (cons (intern (concat ":" ns))
 267             lname))))
 268
 269 ;; expand attribute names
 270 (defun xml-ns-expand-attr (attr-list xml-ns)
 271   "Expand the attribute list for a particular element from the form
 272 \"prefix:local-name\" to the form \"{namespace}:local-name\"."
 273
 274   (mapcar
 275    (lambda (attr)
 276      (let* ((splitup (split-string (car attr) ":"))
 277             (lname (or (nth 1 splitup)
 278                        (nth 0 splitup)))
 279             (prefix (if (nth 1 splitup)
 280                         (nth 0 splitup)
 281                       (if (string= (car attr) "xmlns")
 282                           "xmlns"
 283                         "")))
 284             (ns (cdr (assoc-string prefix xml-ns))))
 285        (setcar attr
 286                (if (string= "" ns)
 287                    lname
 288                  (cons (intern (concat ":" ns))
 289                        lname)))))
 290    attr-list)
 291   attr-list)
 292
 293 (defun xml-intern-attrlist (attr-list)
 294   "Convert attribute names to symbols for backward compatibility."
 295   (mapcar (lambda (attr)
 296             (setcar attr (intern (car attr))))
 297           attr-list)
 298   attr-list)
 299
 300 (defun xml-parse-tag (&optional parse-dtd parse-ns)
 301   "Parse the tag at point.
 302 If PARSE-DTD is non-nil, the DTD of the document, if any, is parsed and
 303 returned as the first element in the list.
 304 If PARSE-NS is non-nil, then QNAMES are expanded.
 305 Returns one of:
 306  - a list : the matching node
 307  - nil    : the point is not looking at a tag.
 308  - a pair : the first element is the DTD, the second is the node."
 309   (let ((xml-ns (if (consp parse-ns)
 310                     parse-ns
 311                   (if parse-ns
 312                       (list
 313                        ;; Default no namespace
 314                        (cons "" "")
 315                        ;; We need to seed the xmlns namespace
 316                        (cons "xmlns" "http://www.w3.org/2000/xmlns/"))))))
 317     (cond
 318      ;; Processing instructions (like the <?xml version="1.0"?> tag at the
 319      ;; beginning of a document).
 320      ((looking-at "<\\?")
 321       (search-forward "?>")
 322       (skip-syntax-forward " ")
 323       (xml-parse-tag parse-dtd xml-ns))
 324      ;;  Character data (CDATA) sections, in which no tag should be interpreted
 325      ((looking-at "<!\\[CDATA\\[")
 326       (let ((pos (match-end 0)))
 327         (unless (search-forward "]]>" nil t)
 328           (error "CDATA section does not end anywhere in the document"))
 329         (buffer-substring pos (match-beginning 0))))
 330      ;;  DTD for the document
 331      ((looking-at "<!DOCTYPE")
 332       (let (dtd)
 333         (if parse-dtd
 334             (setq dtd (xml-parse-dtd))
 335           (xml-skip-dtd))
 336       (skip-syntax-forward " ")
 337       (if dtd
 338           (cons dtd (xml-parse-tag nil xml-ns))
 339         (xml-parse-tag nil xml-ns))))
 340      ;;  skip comments
 341      ((looking-at "<!--")
 342       (search-forward "-->")
 343       nil)
 344      ;;  end tag
 345      ((looking-at "</")
 346       '())
 347      ;;  opening tag
 348      ((looking-at "<\\([^/>[:space:]]+\\)")
 349       (goto-char (match-end 1))
 350
 351       ;; Parse this node
 352       (let* ((node-name (match-string 1))
 353              (attr-list (xml-parse-attlist))
 354              (children (if  (consp xml-ns) ;; take care of namespace parsing
 355                             (progn
 356                               (setq xml-ns (xml-ns-parse-ns-attrs
 357                                             attr-list xml-ns))
 358                               (list (xml-ns-expand-attr
 359                                      attr-list xml-ns)
 360                                     (xml-ns-expand-el
 361                                      node-name xml-ns)))
 362                             (list (xml-intern-attrlist attr-list)
 363                                   (intern node-name))))
 364              pos)
 365
 366         ;; is this an empty element ?
 367         (if (looking-at "/>")
 368         (progn
 369           (forward-char 2)
 370           (nreverse children))
 371
 372         ;; is this a valid start tag ?
 373         (if (eq (char-after) ?>)
 374             (progn
 375               (forward-char 1)
 376               ;;  Now check that we have the right end-tag. Note that this
 377               ;;  one might contain spaces after the tag name
 378               (let ((end (concat "</" node-name "\\s-*>")))
 379                 (while (not (looking-at end))
 380                   (cond
 381                    ((looking-at "</")
 382                     (error "XML: Invalid end tag (expecting %s) at pos %d"
 383                            node-name (point)))
 384                    ((= (char-after) ?<)
 385                     (let ((tag (xml-parse-tag nil xml-ns)))
 386                       (when tag
 387                         (push tag children))))
 388                    (t
 389                     (setq pos (point))
 390                     (search-forward "<")
 391                     (forward-char -1)
 392                     (let ((string (buffer-substring pos (point)))
 393                           (pos 0))
 394
 395                       ;; Clean up the string.  As per XML
 396                       ;; specifications, the XML processor should
 397                       ;; always pass the whole string to the
 398                       ;; application.  But \r's should be replaced:
 399                       ;; http://www.w3.org/TR/2000/REC-xml-20001006#sec-line-ends
 400                       (while (string-match "\r\n?" string pos)
 401                         (setq string (replace-match "\n" t t string))
 402                         (setq pos (1+ (match-beginning 0))))
 403
 404                       (setq string (xml-substitute-special string))
 405                       (setq children
 406                             (if (stringp (car children))
 407                                 ;; The two strings were separated by a comment.
 408                                 (cons (concat (car children) string)
 409                                       (cdr children))
 410                               (cons string children))))))))
 411
 412               (goto-char (match-end 0))
 413               (nreverse children))
 414           ;;  This was an invalid start tag
 415           (error "XML: Invalid attribute list")))))
 416      (t ;; This is not a tag.
 417       (error "XML: Invalid character")))))
 418
 419 (defun xml-parse-attlist ()
 420   "Return the attribute-list after point.  Leave point at the
 421 first non-blank character after the tag."
 422   (let ((attlist ())
 423         end-pos name)
 424     (skip-syntax-forward " ")
 425     (while (looking-at (eval-when-compile
 426                          (concat "\\(" xml-name-regexp "\\)\\s-*=\\s-*")))
 427       (setq name (match-string 1))
 428       (goto-char (match-end 0))
 429
 430       ;; See also: http://www.w3.org/TR/2000/REC-xml-20001006#AVNormalize
 431
 432       ;; Do we have a string between quotes (or double-quotes),
 433       ;;  or a simple word ?
 434       (if (looking-at "\"\\([^\"]*\\)\"")
 435           (setq end-pos (match-end 0))
 436         (if (looking-at "'\\([^']*\\)'")
 437             (setq end-pos (match-end 0))
 438           (error "XML: Attribute values must be given between quotes")))
 439
 440       ;; Each attribute must be unique within a given element
 441       (if (assoc name attlist)
 442           (error "XML: each attribute must be unique within an element"))
 443
 444       ;; Multiple whitespace characters should be replaced with a single one
 445       ;; in the attributes
 446       (let ((string (match-string 1))
 447             (pos 0))
 448         (replace-regexp-in-string "\\s-\\{2,\\}" " " string)
 449         (push (cons name (xml-substitute-special string)) attlist))
 450
 451       (goto-char end-pos)
 452       (skip-syntax-forward " "))
 453     (nreverse attlist)))
 454
 455 ;;*******************************************************************
 456 ;;**
 457 ;;**  The DTD (document type declaration)
 458 ;;**  The following functions know how to skip or parse the DTD of
 459 ;;**  a document
 460 ;;**
 461 ;;*******************************************************************
 462
 463 ;; Fixme: This fails at least if the DTD contains conditional sections.
 464
 465 (defun xml-skip-dtd ()
 466   "Skip the DTD at point.
 467 This follows the rule [28] in the XML specifications."
 468   (forward-char (length "<!DOCTYPE"))
 469   (if (looking-at "\\s-*>")
 470       (error "XML: invalid DTD (excepting name of the document)"))
 471   (condition-case nil
 472       (progn
 473         (forward-sexp)
 474         (skip-syntax-forward " ")
 475         (if (looking-at "\\[")
 476             (re-search-forward "]\\s-*>")
 477           (search-forward ">")))
 478     (error (error "XML: No end to the DTD"))))
 479
 480 (defun xml-parse-dtd ()
 481   "Parse the DTD at point."
 482   (forward-char (eval-when-compile (length "<!DOCTYPE")))
 483   (skip-syntax-forward " ")
 484   (if (looking-at ">")
 485       (error "XML: invalid DTD (excepting name of the document)"))
 486
 487   ;;  Get the name of the document
 488   (looking-at xml-name-regexp)
 489   (let ((dtd (list (match-string 0) 'dtd))
 490         type element end-pos)
 491     (goto-char (match-end 0))
 492
 493     (skip-syntax-forward " ")
 494     ;; XML [75]
 495     (cond ((looking-at "PUBLIC\\s-+")
 496            (goto-char (match-end 0))
 497            (unless (or (re-search-forward
 498                         "\\=\"\\([[:space:][:alnum:]-'()+,./:=?;!*#@$_%]*\\)\""
 499                         nil t)
 500                        (re-search-forward
 501                         "\\='\\([[:space:][:alnum:]-()+,./:=?;!*#@$_%]*\\)'"
 502                         nil t))
 503              (error "XML: missing public id"))
 504            (let ((pubid (match-string 1)))
 505              (unless (or (re-search-forward "\\='\\([^']*\\)'" nil t)
 506                          (re-search-forward "\\=\"\\([^\"]*\\)\"" nil t))
 507                (error "XML: missing system id"))
 508              (push (list pubid (match-string 1) 'public) dtd)))
 509           ((looking-at "SYSTEM\\s-+")
 510            (goto-char (match-end 0))
 511            (unless (or (re-search-forward "\\='\\([^']*\\)'" nil t)
 512                        (re-search-forward "\\=\"\\([^\"]*\\)\"" nil t))
 513              (error "XML: missing system id"))
 514            (push (list (match-string 1) 'system) dtd)))
 515     (skip-syntax-forward " ")
 516     (if (eq ?> (char-after))
 517         (forward-char)
 518       (skip-syntax-forward " ")
 519       (if (not (eq (char-after) ?\[))
 520           (error "XML: bad DTD")
 521         (forward-char)
 522         ;;  Parse the rest of the DTD
 523         ;;  Fixme: Deal with ENTITY, ATTLIST, NOTATION, PIs.
 524         (while (not (looking-at "\\s-*\\]"))
 525           (skip-syntax-forward " ")
 526           (cond
 527
 528            ;;  Translation of rule [45] of XML specifications
 529            ((looking-at
 530              "<!ELEMENT\\s-+\\([[:alnum:].%;]+\\)\\s-+\\([^>]+\\)>")
 531
 532             (setq element (match-string 1)
 533                   type    (match-string-no-properties 2))
 534             (setq end-pos (match-end 0))
 535
 536             ;;  Translation of rule [46] of XML specifications
 537             (cond
 538              ((string-match "^EMPTY[ \t\n\r]*$" type) ;; empty declaration
 539               (setq type 'empty))
 540              ((string-match "^ANY[ \t\n\r]*$" type) ;; any type of contents
 541               (setq type 'any))
 542              ((string-match "^(\\(.*\\))[ \t\n\r]*$" type) ;; children ([47])
 543               (setq type (xml-parse-elem-type (match-string 1 type))))
 544              ((string-match "^%[^;]+;[ \t\n\r]*$" type) ;; substitution
 545               nil)
 546              (t
 547               (error "XML: Invalid element type in the DTD")))
 548
 549             ;;  rule [45]: the element declaration must be unique
 550             (if (assoc element dtd)
 551                 (error "XML: element declarations must be unique in a DTD (<%s>)"
 552                        element))
 553
 554             ;;  Store the element in the DTD
 555             (push (list element type) dtd)
 556             (goto-char end-pos))
 557            ((looking-at "<!--")
 558             (search-forward "-->"))
 559
 560            (t
 561             (error "XML: Invalid DTD item")))
 562
 563           ;;  Skip the end of the DTD
 564           (search-forward ">"))))
 565     (nreverse dtd)))
 566
 567 (defun xml-parse-elem-type (string)
 568   "Convert element type STRING into a Lisp structure."
 569
 570   (let (elem modifier)
 571     (if (string-match "(\\([^)]+\\))\\([+*?]?\\)" string)
 572         (progn
 573           (setq elem     (match-string 1 string)
 574                 modifier (match-string 2 string))
 575           (if (string-match "|" elem)
 576               (setq elem (cons 'choice
 577                                (mapcar 'xml-parse-elem-type
 578                                        (split-string elem "|"))))
 579             (if (string-match "," elem)
 580                 (setq elem (cons 'seq
 581                                  (mapcar 'xml-parse-elem-type
 582                                          (split-string elem ",")))))))
 583       (if (string-match "[ \t\n\r]*\\([^+*?]+\\)\\([+*?]?\\)" string)
 584           (setq elem     (match-string 1 string)
 585                 modifier (match-string 2 string))))
 586
 587     (if (and (stringp elem) (string= elem "#PCDATA"))
 588         (setq elem 'pcdata))
 589
 590     (cond
 591      ((string= modifier "+")
 592       (list '+ elem))
 593      ((string= modifier "*")
 594       (list '* elem))
 595      ((string= modifier "?")
 596       (list '\? elem))
 597      (t
 598       elem))))
 599
 600 ;;*******************************************************************
 601 ;;**
 602 ;;**  Substituting special XML sequences
 603 ;;**
 604 ;;*******************************************************************
 605
 606 (eval-when-compile
 607   (defvar str))                ; dynamic from replace-regexp-in-string
 608
 609 ;; Fixme:  Take declared entities from the DTD when they're available.
 610 (defun xml-substitute-entity (match)
 611   "Subroutine of xml-substitute-special."
 612   (save-match-data
 613     (let ((match1 (match-string 1 str)))
 614       (cond ((string= match1 "lt") "<")
 615             ((string= match1 "gt") ">")
 616             ((string= match1 "apos") "'")
 617             ((string= match1 "quot") "\"")
 618             ((string= match1 "amp") "&")
 619             ((and (string-match "#\\([0-9]+\\)" match1)
 620                   (let ((c (decode-char
 621                             'ucs
 622                             (string-to-number (match-string 1 match1)))))
 623                     (if c (string c))))) ; else unrepresentable
 624             ((and (string-match "#x\\([[:xdigit:]]+\\)" match1)
 625                   (let ((c (decode-char
 626                             'ucs
 627                             (string-to-number (match-string 1 match1) 16))))
 628                     (if c (string c)))))
 629             ;; Default to asis.  Arguably, unrepresentable code points
 630             ;; might be best replaced with U+FFFD.
 631             (t match)))))
 632
 633 (defun xml-substitute-special (string)
 634   "Return STRING, after subsituting entity references."
 635   ;; This originally made repeated passes through the string from the
 636   ;; beginning, which isn't correct, since then either "&amp;amp;" or
 637   ;; "&#38;amp;" won't DTRT.
 638   (replace-regexp-in-string "&\\([^;]+\\);"
 639                             #'xml-substitute-entity string t t))
 640
 641 ;;*******************************************************************
 642 ;;**
 643 ;;**  Printing a tree.
 644 ;;**  This function is intended mainly for debugging purposes.
 645 ;;**
 646 ;;*******************************************************************
 647
 648 (defun xml-debug-print (xml)
 649   (dolist (node xml)
 650     (xml-debug-print-internal node "")))
 651
 652 (defun xml-debug-print-internal (xml indent-string)
 653   "Outputs the XML tree in the current buffer.
 654 The first line is indented with INDENT-STRING."
 655   (let ((tree xml)
 656         attlist)
 657     (insert indent-string ?< (symbol-name (xml-node-name tree)))
 658
 659     ;;  output the attribute list
 660     (setq attlist (xml-node-attributes tree))
 661     (while attlist
 662       (insert ?\  (symbol-name (caar attlist)) "=\"" (cdar attlist) ?\")
 663       (setq attlist (cdr attlist)))
 664
 665     (insert ?>)
 666
 667     (setq tree (xml-node-children tree))
 668
 669     ;;  output the children
 670     (dolist (node tree)
 671       (cond
 672        ((listp node)
 673         (insert ?\n)
 674         (xml-debug-print-internal node (concat indent-string "  ")))
 675        ((stringp node) (insert node))
 676        (t
 677         (error "Invalid XML tree"))))
 678
 679     (insert ?\n indent-string
 680             ?< ?/ (symbol-name (xml-node-name xml)) ?>)))
 681
 682 (provide 'xml)
 683
 684 ;;; arch-tag: 5864b283-5a68-4b59-a20d-36a72b353b9b
 685 ;;; xml.el ends here