comparison lisp/xml.el @ 54877:1bf7ef48f54f

(xml-maybe-do-ns): New function to handle namespace parsing of both attribute and element names. (xml-ns-parse-ns-attrs, xml-ns-expand-el, xml-ns-expand-attr) (xml-intern-attrlist): Remove in favor of xml-maybe-do-ns. (xml-parse-tag): Update assumed namespaces. Clean up namespace parsing. (xml-parse-attlist): Make it do its own namespace parsing.

54876:95ee18354a3a

;;
;; 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.

	      (goto-char (point-max))))
	  (if parse-dtd
	      (cons dtd (nreverse xml))
	    (nreverse xml)))))))

(defun xml-ns-parse-ns-attrs (attr-list &optional xml-ns)
  "Parse the namespace attributes and return a list of cons in the form:
\(namespace . prefix)"

  (mapcar
   (lambda (attr)
     (let* ((splitup (split-string (car attr) ":"))
	    (prefix (nth 0 splitup))
	    (lname (nth 1 splitup)))
       (when (string= "xmlns" prefix)
	 (push (cons (if lname
			 lname
		       "")
		     (cdr attr))
	       xml-ns)))) attr-list)
  xml-ns)

;; expand element names
(defun xml-ns-expand-el (el xml-ns)
  "Expand the XML elements from \"prefix:local-name\" to a cons in the form
\"(namespace . local-name)\"."

  (let* ((splitup (split-string el ":"))
	 (lname (or (nth 1 splitup)
		    (nth 0 splitup)))
	 (prefix (if (nth 1 splitup)
		     (nth 0 splitup)
		   (if (string= lname "xmlns")
		       "xmlns"
		     "")))
	 (ns (cdr (assoc-string prefix xml-ns))))
    (if (string= "" ns)
	lname
      (cons (intern (concat ":" ns))
	    lname))))

;; expand attribute names
(defun xml-ns-expand-attr (attr-list xml-ns)
  "Expand the attribute list for a particular element from the form
\"prefix:local-name\" to the form \"{namespace}:local-name\"."

  (mapcar
   (lambda (attr)
     (let* ((splitup (split-string (car attr) ":"))
	    (lname (or (nth 1 splitup)
		       (nth 0 splitup)))
	    (prefix (if (nth 1 splitup)
			(nth 0 splitup)
		      (if (string= (car attr) "xmlns")
			  "xmlns"
			"")))
	    (ns (cdr (assoc-string prefix xml-ns))))
       (setcar attr
	       (if (string= "" ns)
		   lname
		 (cons (intern (concat ":" ns))
		       lname)))))
   attr-list)
  attr-list)

(defun xml-intern-attrlist (attr-list)
  "Convert attribute names to symbols for backward compatibility."
  (mapcar (lambda (attr)
	    (setcar attr (intern (car attr))))
	  attr-list)
  attr-list)

(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 "<\\([^/>[:space:]]+\\)")
      (goto-char (match-end 1))

      ;; Parse this node
      (let* ((node-name (match-string 1))
	     (attr-list (xml-parse-attlist))
	     (children (if  (consp xml-ns) ;; take care of namespace parsing
			    (progn
			      (setq xml-ns (xml-ns-parse-ns-attrs
					    attr-list xml-ns))
			      (list (xml-ns-expand-attr
				     attr-list xml-ns)
				    (xml-ns-expand-el
				     node-name xml-ns)))
			    (list (xml-intern-attrlist attr-list)
				  (intern node-name))))
	     pos)

	;; 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 ())
	end-pos name)
    (skip-syntax-forward " ")
    (while (looking-at (eval-when-compile
			 (concat "\\(" xml-name-regexp "\\)\\s-*=\\s-*")))
      (setq name (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 ?

54877:1bf7ef48f54f

;;
;; 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.

	      (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 "<\\([^/>[: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 ?