(xml-parse-tag): Namespace support.

(xml-parse-file): Namespace suport.
(xml-parse-region): Namespace suport.

2 files changed, 111 insertions, 133 deletions

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 302cf8c4a3b..7f8665f2ad6 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,8 @@
+2003-07-14  Mark A. Hershberger  <mah@everybody.org>
+
+        * xml.el (xml-parse-tag, xml-parse-file, xml-parse-region):
+        Namespace support.
+
 2003-07-13  Juanma Barranquero  <lektu@terra.es>
 
         * frame.el (modify-all-frames-parameters): Reinstalled (copyright
@@ -19,85 +24,6 @@
         (Man-translate-references): Call `Man-translate-cleanup' to clean
         leading, trailing and middle spaces.
 
-2003-07-13  Michael Mauger  <mmaug@yahoo.com>
-
-        Version 1.8.0 of sql-mode.
-
-        Simplify selection of SQL products to define highlighting and
-        interactive mode.  Includes detailed instructions on adding support
-        for new products.
-
-        * progmodes/sql.el (sql-product): New variable.  Identifies SQL
-        product for use in highlighting and interactive mode.
-        (sql-interactive-product): New variable.  SQL product for
-        sql-interactive-mode.
-        (sql-product-support): New variable.  Specifies product-specific
-        parameters to drive highlighting and interactive mode.
-        (sql-imenu-generic-expression): Add more object types.
-        (sql-sqlite-options): Correct comment.
-        (sql-ms-program): Use "osql" rather than "isql".
-        (sql-prompt-regexp, sql-prompt-length): Update comment.
-        (sql-mode-menu): Add "Start SQLi session" entry.  Replace
-        Highlighting submenu with Product menu.  Fix Send Region entry.
-        (sql-mode-abbrev-table): Add abbreviations.  Support of SYSTEM-FLAG
-        on define-abbrev.  Support was removed with last check-in; it now
-        handles older Emacsen without the SYSTEM-FLAG.
-        (sql-mode-font-lock-object-name): Add font-lock pattern for object
-        names.
-        (sql-mode-ansi-font-lock-keywords): Set as default value.
-        (sql-mode-oracle-font-lock-keywords): Set as default value.  Support
-        Oracle 9i keywords.
-        (sql-mode-postgres-font-lock-keywords): Set as default value.
-        (sql-mode-linter-font-lock-keywords): Set as default value.
-        (sql-mode-ms-font-lock-keywords): New variable.  Support Microsoft
-        SQLServer 2000.
-        (sql-mode-sybase-font-lock-keywords)
-        (sql-mode-interbase-font-lock-keywords)
-        (sql-mode-sqlite-font-lock-keywords)
-        (sql-mode-strong-font-lock-keywords)
-        (sql-mode-mysql-font-lock-keywords)
-        (sql-mode-db2-font-lock-keywords): New variables.  Default to ANSI
-        keywords.
-        (sql-mode-font-lock-defaults): Update comment.
-        (sql-product-feature): New function.  Returns feature associated
-        with a product from `sql-product-support' alist.
-        (sql-product-font-lock): New function.  Set font-lock support based
-        on `sql-product'.
-        (sql-add-product-keywords): New function.  Add font-lock rules to
-        product-specific keyword variables.
-        (sql-set-product): New function.  Set `sql-product' and apply
-        appropriate font-lock highlighting.
-        (sql-highlight-product): New function.  Set font-lock support based
-        on a product.  Also set mode name to include product name.
-        (sql-highlight-ansi-keywords, sql-highlight-oracle-keywords)
-        (sql-highlight-postgres-keywords, sql-highlight-linter-keywords):
-        Use `sql-set-product'.
-        (sql-highlight-ms-keywords)
-        (sql-highlight-sybase-keywords)
-        (sql-highlight-interbase-keywords)
-        (sql-highlight-strong-keywords)
-        (sql-highlight-mysql-keywords)
-        (sql-highlight-sqlite-keywords)
-        (sql-highlight-db2-keywords): New functions.  Use `sql-set-product'.
-        (sql-get-login): Prompt in the same order as the tokens.
-        (sql-mode): Uses `sql-product-highlight' and
-        `sql-product-font-lock'.
-        (sql-product-interactive): New function.  Common portions of
-        product-specific interactive mode wrappers.
-        (sql-interactive-mode): Rewritten to use product features.
-        (sql-oracle, sql-sybase, sql-informix, sql-sqlite, sql-mysql)
-        (sql-solid, sql-ingres, sql-ms, sql-postgres, sql-interbase)
-        (sql-db2, sql-linter): Use `sql-product-interactive'.
-        (sql-connect-oracle, sql-connect-sybase, sql-connect-informix)
-        (sql-connect-sqlite, sql-connect-mysql, sql-connect-solid)
-        (sql-connect-ingres, sql-connect-postgres)
-        (sql-connect-interbase, sql-connect-db2, sql-connect-linter): New
-        functions.  Format command line parameters and invoke comint on the
-        appropriate interpreter.  Code was in the corresponding `sql-xyz'
-        function before.
-        (sql-connect-ms): New function.  Support -E argument to use
-        operating system credentials for authentication.
-
 2003-07-13  Lars Hansen  <larsh@math.ku.dk>
 
         * desktop.el (desktop-buffer-dired-misc-data, desktop-buffer-dired):
diff --git a/lisp/xml.el b/lisp/xml.el
index f62b70fceb4..55c8fca23aa 100644
--- a/lisp/xml.el
+++ b/lisp/xml.el
@@ -121,11 +121,12 @@ An empty string is returned if the attribute was not found."
 ;;*******************************************************************
 
 ;;;###autoload
-(defun xml-parse-file (file &optional parse-dtd)
+(defun xml-parse-file (file &optional parse-dtd parse-ns)
   "Parse the well-formed XML file FILE.
 If FILE is already visited, use its buffer and don't kill it.
 Returns the top node with all its children.
-If PARSE-DTD is non-nil, the DTD is parsed rather than skipped."
+If PARSE-DTD is non-nil, the DTD is parsed rather than skipped.
+If PARSE-NS is non-nil, then QNAMES are expanded."
   (let ((keep))
     (if (get-file-buffer file)
         (progn
@@ -137,7 +138,7 @@ If PARSE-DTD is non-nil, the DTD is parsed rather than skipped."
     (let ((xml (xml-parse-region (point-min)
                                  (point-max)
                                  (current-buffer)
-                                 parse-dtd)))
+                                 parse-dtd parse-ns)))
       (if keep
           (goto-char keep)
         (kill-buffer (current-buffer)))
@@ -184,13 +185,14 @@ If PARSE-DTD is non-nil, the DTD is parsed rather than skipped."
 ;;   prolog    ::=    XMLDecl? Misc* (doctypedecl Misc*)?
 
 ;;;###autoload
-(defun xml-parse-region (beg end &optional buffer parse-dtd)
+(defun xml-parse-region (beg end &optional buffer parse-dtd parse-ns)
   "Parse the region from BEG to END in BUFFER.
 If BUFFER is nil, it defaults to the current buffer.
 Returns the XML list for the region, or raises an error if the region
-is not a well-formed XML file.
+is not well-formed XML.
 If PARSE-DTD is non-nil, the DTD is parsed rather than skipped,
-and returned as the first element of the list."
+and returned as the first element of the list.
+If PARSE-NS is non-nil, then QNAMES are expanded."
   (save-restriction
     (narrow-to-region beg end)
     ;; Use fixed syntax table to ensure regexp char classes and syntax
@@ -209,7 +211,7 @@ and returned as the first element of the list."
                   (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))
+                    (setq result (xml-parse-tag parse-dtd parse-ns))
                     (cond
                      ((null result))
                      ((listp (car result))
@@ -224,57 +226,108 @@ and returned as the first element of the list."
             (nreverse xml)))))))
 
 
-(defun xml-parse-tag (&optional parse-dtd)
+(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.
+If PARSE-NS is non-nil, then QNAMES are expanded.
 Returns one of:
  - a list : the matching node
  - nil    : the point is not looking at a tag.
  - a pair : the first element is the DTD, the second is the node."
-  (cond
-   ;; Processing instructions (like the <?xml version="1.0"?> tag at the
-   ;; beginning of a document).
-   ((looking-at "<\\?")
-    (search-forward "?>")
-    (skip-syntax-forward " ")
-    (xml-parse-tag parse-dtd))
-   ;;  Character data (CDATA) sections, in which no tag should be interpreted
-   ((looking-at "<!\\[CDATA\\[")
-    (let ((pos (match-end 0)))
-      (unless (search-forward "]]>" nil t)
-        (error "CDATA section does not end anywhere in the document"))
-      (buffer-substring pos (match-beginning 0))))
-   ;;  DTD for the document
-   ((looking-at "<!DOCTYPE")
-    (let (dtd)
-      (if parse-dtd
-          (setq dtd (xml-parse-dtd))
-        (xml-skip-dtd))
+  (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 "?>")
+      (skip-syntax-forward " ")
+      (xml-parse-tag parse-dtd xml-ns))
+     ;;  Character data (CDATA) sections, in which no tag should be interpreted
+     ((looking-at "<!\\[CDATA\\[")
+      (let ((pos (match-end 0)))
+        (unless (search-forward "]]>" nil t)
+          (error "CDATA section does not end anywhere in the document"))
+        (buffer-substring pos (match-beginning 0))))
+     ;;  DTD for the document
+     ((looking-at "<!DOCTYPE")
+      (let (dtd)
+        (if parse-dtd
+            (setq dtd (xml-parse-dtd))
+          (xml-skip-dtd))
       (skip-syntax-forward " ")
       (if dtd
-          (cons dtd (xml-parse-tag))
-        (xml-parse-tag))))
-   ;;  skip comments
-   ((looking-at "<!--")
-    (search-forward "-->")
-    nil)
-   ;;  end tag
-   ((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)
-
-      ;; is this an empty element ?
-      (if (looking-at "/>")
-          (progn
-            (forward-char 2)
-            (nreverse children))
+          (cons dtd (xml-parse-tag nil xml-ns))
+        (xml-parse-tag nil xml-ns))))
+     ;;  skip comments
+     ((looking-at "<!--")
+      (search-forward "-->")
+      nil)
+     ;;  end tag
+     ((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))
 
         ;; is this a valid start tag ?
         (if (eq (char-after) ?>)
@@ -289,7 +342,7 @@ Returns one of:
                     (error "XML: Invalid end tag (expecting %s) at pos %d"
                            node-name (point)))
                    ((= (char-after) ?<)
-                    (let ((tag (xml-parse-tag)))
+                    (let ((tag (xml-parse-tag nil xml-ns)))
                       (when tag
                         (push tag children))))
                    (t
@@ -320,12 +373,11 @@ Returns one of:
               (nreverse children))
           ;;  This was an invalid start tag
           (error "XML: Invalid attribute list")))))
-   (t ;; This is not a tag.
-    (error "XML: Invalid character"))))
+     (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."
+  "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 " ")