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