comparison lisp/xml.el @ 89909:68c22ea6027c

Sync to HEAD

89908:ee1402f7b568

;;; xml.el --- XML parser

;; Copyright (C) 2000, 2001, 2003 Free Software Foundation, Inc.

;; Author: Emmanuel Briot  <[e-mail]>
;; Maintainer: Mark A. Hershberger <[e-mail]>
;; Keywords: xml, data

;;
;; There can be only top level node, but with any number of children below.

;;; LIST FORMAT

;; The functions `xml-parse-file' and `xml-parse-tag' return a list with
;; the following format:
;;
;;    xml-list   ::= (node node ...)
;;    node       ::= (tag_name attribute-list . child_node_list)
;;    child_node_list ::= child_node child_node ...
;;    child_node ::= node | string
;;    tag_name   ::= string
;;    attribute_list ::= (("attribute" . "value") ("attribute" . "value") ...)
;;                       | nil
;;    string     ::= "..."
;;
;; Some macros are provided to ease the parsing of this list.
;; Whitespace is preserved.  Fixme: There should be a tree-walker that
;; can remove it.

;;; Code:

;; Note that {buffer-substring,match-string}-no-properties were
;; formerly used in several places, but that removes composition info.

      (if child
	  (if (equal (xml-node-name child) child-name)
	      (push child match))))
    (nreverse match)))

(defun xml-get-attribute (node attribute)
  "Get from NODE the value of ATTRIBUTE.
An empty string is returned if the attribute was not found."
  (if (xml-node-attributes node)
      (let ((value (assoc attribute (xml-node-attributes node))))
	(if value
	    (cdr value)
	  ""))
    ""))

;;*******************************************************************
;;**
;;**  Creating the list
;;**

	  (goto-char (point-min))
	  (while (not (eobp))
	    (if (search-forward "<" nil t)
		(progn
		  (forward-char -1)
		  (if xml
		      ;;  translation of rule [1] of XML specifications
		      (error "XML files can have only one toplevel tag")
		    (setq result (xml-parse-tag parse-dtd parse-ns))
		    (cond
		     ((null result))
		     ((listp (car result))
		      (setq dtd (car result))
		      (if (cdr result)	; possible leading comment
			  (add-to-list 'xml (cdr result))))
		     (t
		      (add-to-list 'xml result)))))
	      (goto-char (point-max))))
	  (if parse-dtd
	      (cons dtd (nreverse xml))
	    (nreverse xml)))))))


(defun xml-parse-tag (&optional parse-dtd parse-ns)
  "Parse the tag at point.
If PARSE-DTD is non-nil, the DTD of the document, if any, is parsed and
returned as the first element in the list.

 - a pair : the first element is the DTD, the second is the node."
  (let ((xml-ns (if (consp parse-ns)
		    parse-ns
		  (if parse-ns
		      (list
		       ;; Default no namespace
		       (cons "" "")
		       ;; We need to seed the xmlns namespace
		       (cons "xmlns" "http://www.w3.org/2000/xmlns/"))))))
    (cond
     ;; Processing instructions (like the <?xml version="1.0"?> tag at the
     ;; beginning of a document).
     ((looking-at "<\\?")
      (search-forward "?>")

     ((looking-at "</")
      '())
     ;;  opening tag
     ((looking-at "<\\([^/>[:space:]]+\\)")
      (goto-char (match-end 1))
      (let* ((node-name (match-string 1))
	     ;; Parse the attribute list.
	     (children (list (xml-parse-attlist) (intern node-name)))
	     pos)

	;; add the xmlns:* attrs to our cache
	(when (consp xml-ns)
	  (mapcar
	   (lambda (attr)
	     (let* ((splitup (split-string (symbol-name (car attr)) ":"))
		    (prefix (nth 0 splitup))
		    (lname (nth 1 splitup)))
	       (when (string= "xmlns" prefix)
		 (setq xml-ns (append (list (cons (if lname
						      lname
						    "")
						  (cdr attr)))
				      xml-ns)))))
	   (car children))

	  ;; expand element names
	  (let* ((splitup (split-string (symbol-name (cadr children)) ":"))
		 (lname (or (nth 1 splitup)
			    (nth 0 splitup)))
		 (prefix (if (nth 1 splitup)
			     (nth 0 splitup)
			   "")))
	    (setcdr children (list
			      (intern (concat "{"
					     (cdr (assoc-string prefix xml-ns))
					     "}" lname)))))

	  ;; expand attribute names
	  (mapcar
	   (lambda (attr)
	     (let* ((splitup (split-string (symbol-name (car attr)) ":"))
		    (lname (or (nth 1 splitup)
			       (nth 0 splitup)))
		    (prefix (if (nth 1 splitup)
				(nth 0 splitup)
			      (caar xml-ns))))

	       (setcar attr (intern (concat "{"
					    (cdr (assoc-string prefix xml-ns))
					    "}" lname)))))
	   (car children)))

	;; is this an empty element ?
	(if (looking-at "/>")
	(progn
	  (forward-char 2)
	  (nreverse children))

	  ;;  This was an invalid start tag
	  (error "XML: Invalid attribute list")))))
     (t	;; This is not a tag.
      (error "XML: Invalid character")))))

(defun xml-parse-attlist ()
  "Return the attribute-list after point.Leave point at the first non-blank character after the tag."
  (let ((attlist ())
	start-pos name)
    (skip-syntax-forward " ")
    (while (looking-at (eval-when-compile
			 (concat "\\(" xml-name-regexp "\\)\\s-*=\\s-*")))
      (setq name (intern (match-string 1)))
      (goto-char (match-end 0))

      ;; See also: http://www.w3.org/TR/2000/REC-xml-20001006#AVNormalize

      ;; Do we have a string between quotes (or double-quotes),
      ;;  or a simple word ?
      (if (looking-at "\"\\([^\"]*\\)\"")
	  (setq start-pos (match-beginning 0))
	(if (looking-at "'\\([^']*\\)'")
	    (setq start-pos (match-beginning 0))
	  (error "XML: Attribute values must be given between quotes")))

      ;; Each attribute must be unique within a given element
      (if (assoc name attlist)
	  (error "XML: each attribute must be unique within an element"))

      (let ((string (match-string 1))
	    (pos 0))
	(replace-regexp-in-string "\\s-\\{2,\\}" " " string)
	(push (cons name (xml-substitute-special string)) attlist))

      (goto-char start-pos)
      (forward-sexp)			; we have string syntax

      (skip-syntax-forward " "))
    (nreverse attlist)))

;;*******************************************************************
;;**

	   ;;  Translation of rule [45] of XML specifications
	   ((looking-at
	     "<!ELEMENT\\s-+\\([[:alnum:].%;]+\\)\\s-+\\([^>]+\\)>")

	    (setq element (intern (match-string 1))
		  type    (match-string-no-properties 2))
	    (setq end-pos (match-end 0))

	    ;;  Translation of rule [46] of XML specifications
	    (cond

	      (error "XML: Invalid element type in the DTD")))

	    ;;  rule [45]: the element declaration must be unique
	    (if (assoc element dtd)
		(error "XML: element declarations must be unique in a DTD (<%s>)"
		       (symbol-name element)))

	    ;;  Store the element in the DTD
	    (push (list element type) dtd)
	    (goto-char end-pos))
	   ((looking-at "<!--")

	    (error "XML: Invalid DTD item")))

	  ;;  Skip the end of the DTD
	  (search-forward ">"))))
    (nreverse dtd)))


(defun xml-parse-elem-type (string)
  "Convert element type STRING into a Lisp structure."

  (let (elem modifier)

    (insert ?\n indent-string
	    ?< ?/ (symbol-name (xml-node-name xml)) ?>)))

(provide 'xml)

;;; xml.el ends here

89909:68c22ea6027c

;;; xml.el --- XML parser

;; Copyright (C) 2000, 01, 03, 2004  Free Software Foundation, Inc.

;; Author: Emmanuel Briot  <[e-mail]>
;; Maintainer: Mark A. Hershberger <[e-mail]>
;; Keywords: xml, data

;;
;; There can be only top level node, but with any number of children below.

;;; LIST FORMAT

;; The functions `xml-parse-file', `xml-parse-region' and
;; `xml-parse-tag' return a list with the following format:
;;
;;    xml-list   ::= (node node ...)
;;    node       ::= (qname attribute-list . child_node_list)
;;    child_node_list ::= child_node child_node ...
;;    child_node ::= node | string
;;    qname      ::= (:namespace-uri . "name") | "name"
;;    attribute_list ::= ((qname . "value") (qname . "value") ...)
;;                       | nil
;;    string     ::= "..."
;;
;; Some macros are provided to ease the parsing of this list.
;; Whitespace is preserved.  Fixme: There should be a tree-walker that
;; can remove it.

;; TODO:
;;  * xml:base, xml:space support
;;  * more complete DOCTYPE parsing
;;  * pi support

;;; Code:

;; Note that {buffer-substring,match-string}-no-properties were
;; formerly used in several places, but that removes composition info.

      (if child
	  (if (equal (xml-node-name child) child-name)
	      (push child match))))
    (nreverse match)))

(defun xml-get-attribute-or-nil (node attribute)
  "Get from NODE the value of ATTRIBUTE.
Return `nil' if the attribute was not found.

See also `xml-get-attribute'."
  (cdr (assoc attribute (xml-node-attributes node))))

(defsubst xml-get-attribute (node attribute)
  "Get from NODE the value of ATTRIBUTE.
An empty string is returned if the attribute was not found.

See also `xml-get-attribute-or-nil'."
  (or (xml-get-attribute-or-nil node attribute) ""))

;;*******************************************************************
;;**
;;**  Creating the list
;;**

	  (goto-char (point-min))
	  (while (not (eobp))
	    (if (search-forward "<" nil t)
		(progn
		  (forward-char -1)
		  (setq result (xml-parse-tag parse-dtd parse-ns))
		  (if (and xml result)
		      ;;  translation of rule [1] of XML specifications
		      (error "XML files can have only one toplevel tag")
		    (cond
		     ((null result))
		     ((and (listp (car result))
			   parse-dtd)
		      (setq dtd (car result))
		      (if (cdr result)	; possible leading comment
			  (add-to-list 'xml (cdr result))))
		     (t
		      (add-to-list 'xml result)))))
	      (goto-char (point-max))))
	  (if parse-dtd
	      (cons dtd (nreverse xml))
	    (nreverse xml)))))))

(defun xml-maybe-do-ns (name default xml-ns)
  "Perform any namespace expansion.  NAME is the name to perform the expansion on.
DEFAULT is the default namespace.  XML-NS is a cons of namespace
names to uris.  When namespace-aware parsing is off, then XML-NS
is nil.

During namespace-aware parsing, any name without a namespace is
put into the namespace identified by DEFAULT.  nil is used to
specify that the name shouldn't be given a namespace."
  (if (consp xml-ns)
      (let* ((nsp (string-match ":" name))
	     (lname (if nsp (substring name (match-end 0)) name))
	     (prefix (if nsp (substring name 0 (match-beginning 0)) default))
	     (special (and (string-equal lname "xmlns") (not prefix)))
             ;; Setting default to nil will insure that there is not
             ;; matching cons in xml-ns.  In which case we
	     (ns (or (cdr (assoc (if special "xmlns" prefix)
                                 xml-ns))
                     :)))
        (cons ns (if special "" lname)))
    (intern name)))

(defun xml-parse-tag (&optional parse-dtd parse-ns)
  "Parse the tag at point.
If PARSE-DTD is non-nil, the DTD of the document, if any, is parsed and
returned as the first element in the list.

 - a pair : the first element is the DTD, the second is the node."
  (let ((xml-ns (if (consp parse-ns)
		    parse-ns
		  (if parse-ns
		      (list
                       ;; Default for empty prefix is no namespace
                       (cons ""      :)
		       ;; "xml" namespace
		       (cons "xml"   :http://www.w3.org/XML/1998/namespace)
		       ;; We need to seed the xmlns namespace
		       (cons "xmlns" :http://www.w3.org/2000/xmlns/))))))
    (cond
     ;; Processing instructions (like the <?xml version="1.0"?> tag at the
     ;; beginning of a document).
     ((looking-at "<\\?")
      (search-forward "?>")

     ((looking-at "</")
      '())
     ;;  opening tag
     ((looking-at "<\\([^/>[:space:]]+\\)")
      (goto-char (match-end 1))

      ;; Parse this node
      (let* ((node-name (match-string 1))
             ;; Parse the attribute list.
             (attrs (xml-parse-attlist xml-ns))
             children pos)

        ;; add the xmlns:* attrs to our cache
        (when (consp xml-ns)
	  (dolist (attr attrs)
	    (when (and (consp (car attr))
		       (eq :http://www.w3.org/2000/xmlns/
			   (caar attr)))
	      (push (cons (cdar attr) (intern (concat ":" (cdr attr))))
		    xml-ns))))

        ;; expand element names
        (setq node-name (list (xml-maybe-do-ns node-name "" xml-ns)))

        (setq children (list attrs node-name))
	;; is this an empty element ?
	(if (looking-at "/>")
	(progn
	  (forward-char 2)
	  (nreverse children))

	  ;;  This was an invalid start tag
	  (error "XML: Invalid attribute list")))))
     (t	;; This is not a tag.
      (error "XML: Invalid character")))))

(defun xml-parse-attlist (&optional xml-ns)
  "Return the attribute-list after point.  Leave point at the
first non-blank character after the tag."
  (let ((attlist ())
	end-pos name)
    (skip-syntax-forward " ")
    (while (looking-at (eval-when-compile
			 (concat "\\(" xml-name-regexp "\\)\\s-*=\\s-*")))
      (setq end-pos (match-end 0))
      (setq name (xml-maybe-do-ns (match-string 1) nil xml-ns))
      (goto-char end-pos)

      ;; See also: http://www.w3.org/TR/2000/REC-xml-20001006#AVNormalize

      ;; Do we have a string between quotes (or double-quotes),
      ;;  or a simple word ?
      (if (looking-at "\"\\([^\"]*\\)\"")
	  (setq end-pos (match-end 0))
	(if (looking-at "'\\([^']*\\)'")
	    (setq end-pos (match-end 0))
	  (error "XML: Attribute values must be given between quotes")))

      ;; Each attribute must be unique within a given element
      (if (assoc name attlist)
	  (error "XML: each attribute must be unique within an element"))

      (let ((string (match-string 1))
	    (pos 0))
	(replace-regexp-in-string "\\s-\\{2,\\}" " " string)
	(push (cons name (xml-substitute-special string)) attlist))

      (goto-char end-pos)
      (skip-syntax-forward " "))
    (nreverse attlist)))

;;*******************************************************************
;;**

	   ;;  Translation of rule [45] of XML specifications
	   ((looking-at
	     "<!ELEMENT\\s-+\\([[:alnum:].%;]+\\)\\s-+\\([^>]+\\)>")

	    (setq element (match-string 1)
		  type    (match-string-no-properties 2))
	    (setq end-pos (match-end 0))

	    ;;  Translation of rule [46] of XML specifications
	    (cond

	      (error "XML: Invalid element type in the DTD")))

	    ;;  rule [45]: the element declaration must be unique
	    (if (assoc element dtd)
		(error "XML: element declarations must be unique in a DTD (<%s>)"
		       element))

	    ;;  Store the element in the DTD
	    (push (list element type) dtd)
	    (goto-char end-pos))
	   ((looking-at "<!--")

	    (error "XML: Invalid DTD item")))

	  ;;  Skip the end of the DTD
	  (search-forward ">"))))
    (nreverse dtd)))

(defun xml-parse-elem-type (string)
  "Convert element type STRING into a Lisp structure."

  (let (elem modifier)

    (insert ?\n indent-string
	    ?< ?/ (symbol-name (xml-node-name xml)) ?>)))

(provide 'xml)

;;; arch-tag: 5864b283-5a68-4b59-a20d-36a72b353b9b
;;; xml.el ends here