cgit.sxemacs.org Git - gnus/blob - contrib/xml.el

   1 ;;; xml.el --- XML parser
   2
   3 ;; Copyright (C) 2000, 2001 Free Software Foundation, Inc.
   4
   5 ;; Author: Emmanuel Briot  <briot@gnat.com>
   6 ;; Maintainer: Emmanuel Briot <briot@gnat.com>
   7 ;; Keywords: xml
   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 full XML parser. It parses a file, and returns a list
  27 ;; that can be used internally by any other lisp file.
  28 ;; See some example in todo.el
  29
  30 ;;; FILE FORMAT
  31
  32 ;; It does not parse the DTD, if present in the XML file, but knows how to
  33 ;; ignore it. The XML file is assumed to be well-formed. In case of error, the
  34 ;; parsing stops and the XML file is shown where the parsing stopped.
  35 ;;
  36 ;; It also knows how to ignore comments, as well as the special ?xml? tag
  37 ;; in the XML file.
  38 ;;
  39 ;; The XML file should have the following format:
  40 ;;    <node1 attr1="name1" attr2="name2" ...>value
  41 ;;       <node2 attr3="name3" attr4="name4">value2</node2>
  42 ;;       <node3 attr5="name5" attr6="name6">value3</node3>
  43 ;;    </node1>
  44 ;; Of course, the name of the nodes and attributes can be anything. There can
  45 ;; be any number of attributes (or none), as well as any number of children
  46 ;; below the nodes.
  47 ;;
  48 ;; There can be only top level node, but with any number of children below.
  49
  50 ;;; LIST FORMAT
  51
  52 ;; The functions `xml-parse-file' and `xml-parse-tag' return a list with
  53 ;; the following format:
  54 ;;
  55 ;;    xml-list   ::= (node node ...)
  56 ;;    node       ::= (tag_name attribute-list . child_node_list)
  57 ;;    child_node_list ::= child_node child_node ...
  58 ;;    child_node ::= node | string
  59 ;;    tag_name   ::= string
  60 ;;    attribute_list ::= (("attribute" . "value") ("attribute" . "value") ...)
  61 ;;                       | nil
  62 ;;    string     ::= "..."
  63 ;;
  64 ;; Some macros are provided to ease the parsing of this list
  65
  66 ;;; Code:
  67
  68 ;;*******************************************************************
  69 ;;**
  70 ;;**  Macros to parse the list
  71 ;;**
  72 ;;*******************************************************************
  73
  74 (defsubst xml-node-name (node)
  75   "Return the tag associated with NODE.
  76 The tag is a lower-case symbol."
  77   (car node))
  78
  79 (defsubst xml-node-attributes (node)
  80   "Return the list of attributes of NODE.
  81 The list can be nil."
  82   (nth 1 node))
  83
  84 (defsubst xml-node-children (node)
  85   "Return the list of children of NODE.
  86 This is a list of nodes, and it can be nil."
  87   (cddr node))
  88
  89 (defun xml-get-children (node child-name)
  90   "Return the children of NODE whose tag is CHILD-NAME.
  91 CHILD-NAME should be a lower case symbol."
  92   (let ((match ()))
  93     (dolist (child (xml-node-children node))
  94       (if child
  95           (if (equal (xml-node-name child) child-name)
  96               (push child match))))
  97     (nreverse match)))
  98
  99 (defun xml-get-attribute (node attribute)
 100   "Get from NODE the value of ATTRIBUTE.
 101 An empty string is returned if the attribute was not found."
 102   (if (xml-node-attributes node)
 103       (let ((value (assoc attribute (xml-node-attributes node))))
 104         (if value
 105             (cdr value)
 106           ""))
 107     ""))
 108
 109 ;;*******************************************************************
 110 ;;**
 111 ;;**  Creating the list
 112 ;;**
 113 ;;*******************************************************************
 114
 115 (defun xml-parse-file (file &optional parse-dtd)
 116   "Parse the well-formed XML FILE.
 117 If FILE is already edited, this will keep the buffer alive.
 118 Returns the top node with all its children.
 119 If PARSE-DTD is non-nil, the DTD is parsed rather than skipped."
 120   (let ((keep))
 121     (if (get-file-buffer file)
 122         (progn
 123           (set-buffer (get-file-buffer file))
 124           (setq keep (point)))
 125       (find-file file))
 126
 127     (let ((xml (xml-parse-region (point-min)
 128                                  (point-max)
 129                                  (current-buffer)
 130                                  parse-dtd)))
 131       (if keep
 132           (goto-char keep)
 133         (kill-buffer (current-buffer)))
 134       xml)))
 135
 136 (defun xml-parse-region (beg end &optional buffer parse-dtd)
 137   "Parse the region from BEG to END in BUFFER.
 138 If BUFFER is nil, it defaults to the current buffer.
 139 Returns the XML list for the region, or raises an error if the region
 140 is not a well-formed XML file.
 141 If PARSE-DTD is non-nil, the DTD is parsed rather than skipped,
 142 and returned as the first element of the list"
 143   (let (xml result dtd)
 144     (save-excursion
 145       (if buffer
 146           (set-buffer buffer))
 147       (goto-char beg)
 148       (while (< (point) end)
 149         (if (search-forward "<" end t)
 150             (progn
 151               (forward-char -1)
 152               (if (null xml)
 153                   (progn
 154                     (setq result (xml-parse-tag end parse-dtd))
 155                     (cond
 156                      ((null result))
 157                      ((listp (car result))
 158                       (setq dtd (car result))
 159                       (add-to-list 'xml (cdr result)))
 160                      (t
 161                       (add-to-list 'xml result))))
 162
 163                 ;;  translation of rule [1] of XML specifications
 164                 (error "XML files can have only one toplevel tag")))
 165           (goto-char end)))
 166       (if parse-dtd
 167           (cons dtd (reverse xml))
 168         (reverse xml)))))
 169
 170
 171 (defun xml-parse-tag (end &optional parse-dtd)
 172   "Parse the tag that is just in front of point.
 173 The end tag must be found before the position END in the current buffer.
 174 If PARSE-DTD is non-nil, the DTD of the document, if any, is parsed and
 175 returned as the first element in the list.
 176 Returns one of:
 177    - a list : the matching node
 178    - nil    : the point is not looking at a tag.
 179    - a cons cell: the first element is the DTD, the second is the node"
 180   (cond
 181    ;; Processing instructions (like the <?xml version="1.0"?> tag at the
 182    ;; beginning of a document)
 183    ((looking-at "<\\?")
 184     (search-forward "?>" end)
 185     (skip-chars-forward " \t\n")
 186     (xml-parse-tag end))
 187    ;;  Character data (CDATA) sections, in which no tag should be interpreted
 188    ((looking-at "<!\\[CDATA\\[")
 189     (let ((pos (match-end 0)))
 190       (unless (search-forward "]]>" end t)
 191         (error "CDATA section does not end anywhere in the document"))
 192       (buffer-substring-no-properties pos (match-beginning 0))))
 193    ;;  DTD for the document
 194    ((looking-at "<!DOCTYPE")
 195     (let (dtd)
 196       (if parse-dtd
 197           (setq dtd (xml-parse-dtd end))
 198         (xml-skip-dtd end))
 199       (skip-chars-forward " \t\n")
 200       (if dtd
 201           (cons dtd (xml-parse-tag end))
 202         (xml-parse-tag end))))
 203    ;;  skip comments
 204    ((looking-at "<!--")
 205     (search-forward "-->" end)
 206     nil)
 207    ;;  end tag
 208    ((looking-at "</")
 209     '())
 210    ;;  opening tag
 211    ((looking-at "<\\([^/> \t\n]+\\)")
 212     (goto-char (match-end 1))
 213     (let* ((case-fold-search nil) ;; XML is case-sensitive.
 214            (node-name (match-string 1))
 215            ;; Parse the attribute list.
 216            (children (list (xml-parse-attlist end) (intern node-name)))
 217            pos)
 218
 219       ;; is this an empty element ?
 220       (if (looking-at "/>")
 221           (progn
 222             (forward-char 2)
 223             (nreverse (cons '("") children)))
 224
 225         ;; is this a valid start tag ?
 226         (if (eq (char-after) ?>)
 227             (progn
 228               (forward-char 1)
 229               ;;  Now check that we have the right end-tag. Note that this
 230               ;;  one might contain spaces after the tag name
 231               (while (not (looking-at (concat "</" node-name "[ \t\n]*>")))
 232                 (cond
 233                  ((looking-at "</")
 234                   (error (concat
 235                           "XML: invalid syntax -- invalid end tag (expecting "
 236                           node-name
 237                           ") at pos " (number-to-string (point)))))
 238                  ((= (char-after) ?<)
 239                   (let ((tag (xml-parse-tag end)))
 240                     (when tag
 241                       (push tag children))))
 242                  (t
 243                   (setq pos (point))
 244                   (search-forward "<" end)
 245                   (forward-char -1)
 246                   (let ((string (buffer-substring-no-properties pos (point)))
 247                         (pos 0))
 248
 249                     ;; Clean up the string (no newline characters)
 250                     ;; Not done, since as per XML specifications, the XML processor
 251                     ;; should always pass the whole string to the application.
 252                     ;;      (while (string-match "\\s +" string pos)
 253                     ;;        (setq string (replace-match " " t t string))
 254                     ;;        (setq pos (1+ (match-beginning 0))))
 255
 256                     (setq string (xml-substitute-special string))
 257                     (setq children
 258                           (if (stringp (car children))
 259                               ;; The two strings were separated by a comment.
 260                               (cons (concat (car children) string)
 261                                     (cdr children))
 262                             (cons string children)))))))
 263               (goto-char (match-end 0))
 264               (if (> (point) end)
 265                   (error "XML: End tag for %s not found before end of region"
 266                          node-name))
 267               (nreverse children))
 268
 269           ;;  This was an invalid start tag
 270           (error "XML: Invalid attribute list")
 271           ))))
 272    (t ;; This is not a tag.
 273     (error "XML: Invalid character"))
 274    ))
 275
 276 (defun xml-parse-attlist (end)
 277   "Return the attribute-list that point is looking at.
 278 The search for attributes end at the position END in the current buffer.
 279 Leaves the point on the first non-blank character after the tag."
 280   (let ((attlist ())
 281         name)
 282     (skip-chars-forward " \t\n")
 283     (while (looking-at "\\([a-zA-Z_:][-a-zA-Z0-9._:]*\\)[ \t\n]*=[ \t\n]*")
 284       (setq name (intern (match-string 1)))
 285       (goto-char (match-end 0))
 286
 287       ;; Do we have a string between quotes (or double-quotes),
 288       ;;  or a simple word ?
 289       (unless (looking-at "\"\\([^\"]*\\)\"")
 290         (unless (looking-at "'\\([^']*\\)'")
 291           (error "XML: Attribute values must be given between quotes")))
 292
 293       ;; Each attribute must be unique within a given element
 294       (if (assoc name attlist)
 295           (error "XML: each attribute must be unique within an element"))
 296
 297       (push (cons name (match-string-no-properties 1)) attlist)
 298       (goto-char (match-end 0))
 299       (skip-chars-forward " \t\n")
 300       (if (> (point) end)
 301           (error "XML: end of attribute list not found before end of region"))
 302       )
 303     (nreverse attlist)))
 304
 305 ;;*******************************************************************
 306 ;;**
 307 ;;**  The DTD (document type declaration)
 308 ;;**  The following functions know how to skip or parse the DTD of
 309 ;;**  a document
 310 ;;**
 311 ;;*******************************************************************
 312
 313 (defun xml-skip-dtd (end)
 314   "Skip the DTD that point is looking at.
 315 The DTD must end before the position END in the current buffer.
 316 The point must be just before the starting tag of the DTD.
 317 This follows the rule [28] in the XML specifications."
 318   (forward-char (length "<!DOCTYPE"))
 319   (if (looking-at "[ \t\n]*>")
 320       (error "XML: invalid DTD (excepting name of the document)"))
 321   (condition-case nil
 322       (progn
 323         (forward-word 1)  ;; name of the document
 324         (skip-chars-forward " \t\n")
 325         (if (looking-at "\\[")
 326             (re-search-forward "\\][ \t\n]*>" end)
 327           (search-forward ">" end)))
 328     (error (error "XML: No end to the DTD"))))
 329
 330 (defun xml-parse-dtd (end)
 331   "Parse the DTD that point is looking at.
 332 The DTD must end before the position END in the current buffer."
 333   (forward-char (length "<!DOCTYPE"))
 334   (skip-chars-forward " \t\n")
 335   (if (looking-at ">")
 336       (error "XML: invalid DTD (excepting name of the document)"))
 337
 338   ;;  Get the name of the document
 339   (looking-at "\\sw+")
 340   (let ((dtd (list (match-string-no-properties 0) 'dtd))
 341         type element end-pos)
 342     (goto-char (match-end 0))
 343
 344     (skip-chars-forward " \t\n")
 345
 346     ;;  External DTDs => don't know how to handle them yet
 347     (if (looking-at "SYSTEM")
 348         (error "XML: Don't know how to handle external DTDs"))
 349
 350     (if (not (= (char-after) ?\[))
 351         (error "XML: Unknown declaration in the DTD"))
 352
 353     ;;  Parse the rest of the DTD
 354     (forward-char 1)
 355     (while (and (not (looking-at "[ \t\n]*\\]"))
 356                 (<= (point) end))
 357       (cond
 358
 359        ;;  Translation of rule [45] of XML specifications
 360        ((looking-at
 361          "[\t \n]*<!ELEMENT[ \t\n]+\\([a-zA-Z0-9.%;]+\\)[ \t\n]+\\([^>]+\\)>")
 362
 363         (setq element (intern (match-string-no-properties 1))
 364               type    (match-string-no-properties 2))
 365         (setq end-pos (match-end 0))
 366
 367         ;;  Translation of rule [46] of XML specifications
 368         (cond
 369          ((string-match "^EMPTY[ \t\n]*$" type)     ;; empty declaration
 370           (setq type 'empty))
 371          ((string-match "^ANY[ \t\n]*$" type)       ;; any type of contents
 372           (setq type 'any))
 373          ((string-match "^(\\(.*\\))[ \t\n]*$" type) ;; children ([47])
 374           (setq type (xml-parse-elem-type (match-string-no-properties 1 type))))
 375          ((string-match "^%[^;]+;[ \t\n]*$" type)   ;; substitution
 376           nil)
 377          (t
 378           (error "XML: Invalid element type in the DTD")))
 379
 380         ;;  rule [45]: the element declaration must be unique
 381         (if (assoc element dtd)
 382             (error "XML: elements declaration must be unique in a DTD (<%s>)"
 383                    (symbol-name element)))
 384
 385         ;;  Store the element in the DTD
 386         (push (list element type) dtd)
 387         (goto-char end-pos))
 388
 389
 390        (t
 391         (error "XML: Invalid DTD item"))
 392        )
 393       )
 394
 395     ;;  Skip the end of the DTD
 396     (search-forward ">" end)
 397     (nreverse dtd)))
 398
 399
 400 (defun xml-parse-elem-type (string)
 401   "Convert a STRING for an element type into an elisp structure."
 402
 403   (let (elem modifier)
 404     (if (string-match "(\\([^)]+\\))\\([+*?]?\\)" string)
 405         (progn
 406           (setq elem     (match-string 1 string)
 407                 modifier (match-string 2 string))
 408           (if (string-match "|" elem)
 409               (setq elem (cons 'choice
 410                                (mapcar 'xml-parse-elem-type
 411                                        (split-string elem "|"))))
 412             (if (string-match "," elem)
 413                 (setq elem (cons 'seq
 414                                  (mapcar 'xml-parse-elem-type
 415                                          (split-string elem ","))))
 416               )))
 417       (if (string-match "[ \t\n]*\\([^+*?]+\\)\\([+*?]?\\)" string)
 418           (setq elem     (match-string 1 string)
 419                 modifier (match-string 2 string))))
 420
 421     (if (and (stringp elem) (string= elem "#PCDATA"))
 422         (setq elem 'pcdata))
 423
 424     (cond
 425      ((string= modifier "+")
 426       (list '+ elem))
 427      ((string= modifier "*")
 428       (list '* elem))
 429      ((string= modifier "?")
 430       (list '? elem))
 431      (t
 432       elem))))
 433
 434
 435 ;;*******************************************************************
 436 ;;**
 437 ;;**  Substituting special XML sequences
 438 ;;**
 439 ;;*******************************************************************
 440
 441 (defun xml-substitute-special (string)
 442   "Return STRING, after subsituting special XML sequences."
 443   (while (string-match "&amp;" string)
 444     (setq string (replace-match "&"  t nil string)))
 445   (while (string-match "&lt;" string)
 446     (setq string (replace-match "<"  t nil string)))
 447   (while (string-match "&gt;" string)
 448     (setq string (replace-match ">"  t nil string)))
 449   (while (string-match "&apos;" string)
 450     (setq string (replace-match "'"  t nil string)))
 451   (while (string-match "&quot;" string)
 452     (setq string (replace-match "\"" t nil string)))
 453   string)
 454
 455 ;;*******************************************************************
 456 ;;**
 457 ;;**  Printing a tree.
 458 ;;**  This function is intended mainly for debugging purposes.
 459 ;;**
 460 ;;*******************************************************************
 461
 462 (defun xml-debug-print (xml)
 463   (dolist (node xml)
 464     (xml-debug-print-internal node "")))
 465
 466 (defun xml-debug-print-internal (xml indent-string)
 467   "Outputs the XML tree in the current buffer.
 468 The first line indented with INDENT-STRING."
 469   (let ((tree xml)
 470         attlist)
 471     (insert indent-string "<" (symbol-name (xml-node-name tree)))
 472
 473     ;;  output the attribute list
 474     (setq attlist (xml-node-attributes tree))
 475     (while attlist
 476       (insert " ")
 477       (insert (symbol-name (caar attlist)) "=\"" (cdar attlist) "\"")
 478       (setq attlist (cdr attlist)))
 479
 480     (insert ">")
 481
 482     (setq tree (xml-node-children tree))
 483
 484     ;;  output the children
 485     (dolist (node tree)
 486       (cond
 487        ((listp node)
 488         (insert "\n")
 489         (xml-debug-print-internal node (concat indent-string "  ")))
 490        ((stringp node) (insert node))
 491        (t
 492         (error "Invalid XML tree"))))
 493
 494     (insert "\n" indent-string
 495             "</" (symbol-name (xml-node-name xml)) ">")))
 496
 497 (provide 'xml)
 498
 499 ;;; xml.el ends here