Change XML name type to represent namespace URI as a string, and to

compare namespace URIs using string comparison.

diff --git a/v7/src/xml/xml-names.scm b/v7/src/xml/xml-names.scm
index b423ac2cde13f02bcdf7ce7830c691312c61cf2a..4d7598ff57457d63e12ac5b8bce588c8bdea4174 100644 (file)
--- a/v7/src/xml/xml-names.scm
+++ b/v7/src/xml/xml-names.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml-names.scm,v 1.16 2007/07/23 01:43:39 cph Exp $
+$Id: xml-names.scm,v 1.17 2007/07/23 02:46:07 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -31,35 +31,38 @@ USA.
 \f
 (define (make-xml-name qname uri)
   (let ((qname (make-xml-qname qname))
-       (uri (->uri uri)))
-    (if (null-xml-namespace-uri? uri)
+       (uri-string
+        (cond ((string? uri) uri)
+              ((wide-string? uri) (wide-string->utf8-string uri))
+              ((symbol? uri) (symbol-name uri))
+              ((uri? uri) (uri->string uri))
+              (else (error:not-uri uri 'MAKE-XML-NAME)))))
+    (string->uri uri-string)           ;signals error if not URI
+    (if (string-null? uri-string)
        qname
        (begin
-         (check-prefix+uri qname uri)
-         (%make-xml-name qname uri)))))
-
-(define (check-prefix+uri qname uri)
-  (if (not (let ((s (symbol-name qname)))
-            (let ((c (find-prefix-separator s)))
-              (case c
-                ((#f) #t)
-                ((ILLEGAL) #f)
-                (else
-                 (case (utf8-string->symbol (string-head s c))
-                   ((xml) (uri=? uri xml-uri))
-                   ((xmlns) (uri=? uri xmlns-uri))
-                   (else #t)))))))
-      (error:bad-range-argument uri 'MAKE-XML-NAME)))
-
-(define (%make-xml-name qname uri)
+         (if (not (let ((s (symbol-name qname)))
+                    (let ((c (find-prefix-separator s)))
+                      (case c
+                        ((#f) #t)
+                        ((ILLEGAL) #f)
+                        (else
+                         (case (utf8-string->symbol (string-head s c))
+                           ((xml) (string=? uri-string xml-uri-string))
+                           ((xmlns) (string=? uri-string xmlns-uri-string))
+                           (else #t)))))))
+             (error:bad-range-argument uri-string 'MAKE-XML-NAME))
+         (%make-xml-name qname uri-string)))))
+
+(define (%make-xml-name qname uri-string)
   (let ((uname
         (let ((local (xml-qname-local qname)))
           (hash-table/intern! (hash-table/intern! expanded-names
-                                                  uri
+                                                  uri-string
                                                   make-eq-hash-table)
                               local
                               (lambda ()
-                                (make-expanded-name uri
+                                (make-expanded-name uri-string
                                                     local
                                                     (make-eq-hash-table)))))))
     (hash-table/intern! (expanded-name-combos uname)
@@ -67,7 +70,7 @@ USA.
                        (lambda () (make-combo-name qname uname)))))
 
 (define expanded-names
-  (make-eq-hash-table))
+  (make-string-hash-table))
 
 (define (xml-name? object)
   (or (xml-qname? object)
@@ -87,9 +90,11 @@ USA.
 (define (null-xml-namespace-uri)
   null-namespace-uri)
 
-(define null-namespace-uri (->relative-uri ""))
-(define xml-uri (->absolute-uri "http://www.w3.org/XML/1998/namespace"))
-(define xmlns-uri (->absolute-uri "http://www.w3.org/2000/xmlns/"))
+(define null-namespace-uri (->uri ""))
+(define xml-uri-string "http://www.w3.org/XML/1998/namespace")
+(define xml-uri (->uri xml-uri-string))
+(define xmlns-uri-string "http://www.w3.org/2000/xmlns/")
+(define xmlns-uri (->uri xmlns-uri-string))
 \f
 (define (make-xml-nmtoken object)
   (if (string? object)
@@ -159,7 +164,7 @@ USA.
   (eq? (xml-name-qname name) qname))
 
 (define (xml-name-uri name)
-  (cond ((xml-qname? name) (null-xml-namespace-uri))
+  (cond ((xml-qname? name) "")
        ((combo-name? name) (expanded-name-uri (combo-name-expanded name)))
        (else (error:not-xml-name name 'XML-NAME-URI))))
 

diff --git a/v7/src/xml/xml-parser.scm b/v7/src/xml/xml-parser.scm
index 78e02176e64a5d87f7fbc03279849e5d79d971b7..5a179fc7c9719c398596c73f995328267a9339de 100644 (file)
--- a/v7/src/xml/xml-parser.scm
+++ b/v7/src/xml/xml-parser.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml-parser.scm,v 1.75 2007/07/23 01:43:41 cph Exp $
+$Id: xml-parser.scm,v 1.76 2007/07/23 02:46:09 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -379,7 +379,15 @@ USA.
                (set-xml-attribute-name! attr
                                         (expand-attribute-name
                                          (xml-attribute-name attr))))
-             attrs)))
+             attrs)
+    (do ((attrs attrs (cdr attrs)))
+       ((not (pair? attrs)) unspecific)
+      (let ((name (xml-attribute-name (car attrs))))
+       (if (there-exists? (cdr attrs)
+             (lambda (attr)
+               (xml-name=? (xml-attribute-name attr) name)))
+           (perror p "Attributes with same name"
+                   (xml-name-qname name)))))))
 
 (define (parse-element-content b p name)
   (let ((vc (parse-content b)))
@@ -569,33 +577,27 @@ USA.
                    (tail (loop (cdr attrs))))
                (let ((qname (car uname))
                      (p (cdr uname)))
-                 (let ((get-uri
+                 (let ((forbidden-uri
                         (lambda ()
-                          (if (string-null? value)
-                              (null-xml-namespace-uri)
-                              (string->uri value))))
-                       (forbidden-uri
-                        (lambda (uri)
-                          (perror p "Forbidden namespace URI"
-                                  (uri->string uri)))))
+                          (perror p "Forbidden namespace URI" value))))
                    (let ((guarantee-legal-uri
-                          (lambda (uri)
-                            (if (or (uri=? uri xml-uri)
-                                    (uri=? uri xmlns-uri))
-                                (forbidden-uri uri)))))
+                          (lambda ()
+                            (if (or (string=? value xml-uri-string)
+                                    (string=? value xmlns-uri-string))
+                                (forbidden-uri)))))
                      (cond ((xml-name=? qname 'xmlns)
-                            (let ((uri (get-uri)))
-                              (guarantee-legal-uri uri)
-                              (cons (cons (null-xml-name-prefix) uri) tail)))
+                            (string->uri value) ;signals error if not URI
+                            (guarantee-legal-uri)
+                            (cons (cons (null-xml-name-prefix) value) tail))
                            ((xml-name-prefix=? qname 'xmlns)
                             (if (xml-name=? qname 'xmlns:xmlns)
                                 (perror p "Illegal namespace prefix" qname))
-                            (let ((uri (get-uri)))
-                              (if (xml-name=? qname 'xmlns:xml)
-                                  (if (not (uri=? uri xml-uri))
-                                      (forbidden-uri uri))
-                                  (guarantee-legal-uri uri))
-                              (cons (cons (xml-name-local qname) uri) tail)))
+                            (string->uri value) ;signals error if not URI
+                            (if (xml-name=? qname 'xmlns:xml)
+                                (if (not (string=? value xml-uri-string))
+                                    (forbidden-uri))
+                                (guarantee-legal-uri))
+                            (cons (cons (xml-name-local qname) value) tail))
                            (else tail))))))
              *prefix-bindings*)))
   unspecific)
@@ -608,20 +610,20 @@ USA.
        (p (cdr uname)))
     (if *in-dtd?*
        qname
-       (let ((uri (lookup-namespace-prefix qname p attribute-name?)))
-         (if (null-xml-namespace-uri? uri)
+       (let ((string (lookup-namespace-prefix qname p attribute-name?)))
+         (if (string-null? string)
              qname
-             (%make-xml-name qname uri))))))
+             (%make-xml-name qname string))))))
 
 (define (lookup-namespace-prefix qname p attribute-name?)
   (let ((prefix (xml-qname-prefix qname)))
     (cond ((eq? prefix 'xmlns)
-          xmlns-uri)
+          xmlns-uri-string)
          ((eq? prefix 'xml)
-          xml-uri)
+          xml-uri-string)
          ((and attribute-name?
                (null-xml-name-prefix? prefix))
-          (null-xml-namespace-uri))
+          "")
          (else
           (let ((entry (assq prefix *prefix-bindings*)))
             (if entry
@@ -629,7 +631,7 @@ USA.
                 (begin
                   (if (not (null-xml-name-prefix? prefix))
                       (perror p "Undeclared XML prefix" prefix))
-                  (null-xml-namespace-uri))))))))
+                  "")))))))
 \f
 ;;;; Processing instructions
 

diff --git a/v7/src/xml/xml-struct.scm b/v7/src/xml/xml-struct.scm
index da547a525af242f44cd8de8d2f5bc68ef78c3023..23c8a91d420ba449ddb8e312ba752815d5f41aa7 100644 (file)
--- a/v7/src/xml/xml-struct.scm
+++ b/v7/src/xml/xml-struct.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml-struct.scm,v 1.57 2007/01/05 21:19:29 cph Exp $
+$Id: xml-struct.scm,v 1.58 2007/07/23 02:46:10 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -452,16 +452,16 @@ USA.
                            (symbol-append 'xmlns: prefix))
                        elt)))
     (and value
-        (if (string-null? value)
-            (null-xml-namespace-uri)
-            (->absolute-uri value)))))
+        (begin
+          (string->uri value)          ;signals error if not URI
+          value))))
 
-(define (xml-element-namespace-prefix elt uri)
+(define (xml-element-namespace-prefix elt uri-string)
   (let ((attr
         (find-matching-item (xml-element-attributes elt)
           (lambda (attr)
             (and (xml-attribute-namespace-decl? attr)
-                 (uri=? (->uri (xml-attribute-value attr)) uri))))))
+                 (string=? (xml-attribute-value attr) uri-string))))))
     (and attr
         (let ((name (xml-attribute-name attr)))
           (if (xml-name=? name 'xmlns)

diff --git a/v7/src/xml/xml.pkg b/v7/src/xml/xml.pkg
index bc194f5a014e65f06989be5d33cabd38947a5ac1..0f3a09e0cb9e47589a6d74549dee2dc93ef9f28e 100644 (file)
--- a/v7/src/xml/xml.pkg
+++ b/v7/src/xml/xml.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml.pkg,v 1.91 2007/01/17 03:43:00 cph Exp $
+$Id: xml.pkg,v 1.92 2007/07/23 02:46:07 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -73,7 +73,9 @@ USA.
          xml-qname-string
          xml-qname?
          xml-uri
-         xmlns-uri)
+         xml-uri-string
+         xmlns-uri
+         xmlns-uri-string)
   (export (runtime xml)
          %make-xml-name
          string-composed-of?