[s-xml-cvs] CVS update: s-xml/src/xml.lisp

[Sven Van Caekenberghe]

Update of /project/s-xml/cvsroot/s-xml/src
In directory common-lisp.net:/tmp/cvs-serv32108/src

Modified Files:
	xml.lisp 
Log Message:
default namespaces without a prefix are now handled by creating a new, uniquely named package and the same prefix

Date: Fri Sep  2 16:38:40 2005
Author: scaekenberghe

Index: s-xml/src/xml.lisp
diff -u s-xml/src/xml.lisp:1.10 s-xml/src/xml.lisp:1.11
--- s-xml/src/xml.lisp:1.10	Mon Aug 29 17:01:47 2005
+++ s-xml/src/xml.lisp	Fri Sep  2 16:38:39 2005
@@ -1,6 +1,6 @@
 ;;;; -*- mode: lisp -*-
 ;;;;
-;;;; $Id: xml.lisp,v 1.10 2005/08/29 15:01:47 scaekenberghe Exp $
+;;;; $Id: xml.lisp,v 1.11 2005/09/02 14:38:39 scaekenberghe Exp $
 ;;;;
 ;;;; This is a Common Lisp implementation of a basic but usable XML parser.
 ;;;; The parser is non-validating and not complete (no CDATA).
@@ -232,6 +232,25 @@
 (defvar *auto-create-namespace-packages* t
   "If t, new packages will be created for namespaces, if needed, named by the prefix")
 
+(defun new-namespace (uri &optional prefix)
+  "Register a new namespace for uri and prefix, creating a package if necessary"
+  (if prefix
+      (register-namespace uri
+                          prefix
+                          (or (find-package prefix)
+                              (if *auto-create-namespace-packages*
+                                  (make-package prefix :nicknames `(,(string-upcase prefix)))
+                                (error "Cannot find or create package ~s" prefix))))
+    (let ((unique-name (loop :for i :upfrom 0
+                             :do (let ((name (format nil "ns-~d" i)))
+                                   (when (not (find-package name))
+                                     (return name))))))
+      (register-namespace uri
+                          unique-name
+                          (if *auto-create-namespace-packages*
+                              (make-package (string-upcase unique-name) :nicknames `(,unique-name))
+                            (error "Cannot create package ~s" unique-name))))))
+
 (defun extend-namespaces (attributes namespaces)
   "Given possible 'xmlns[:prefix]' attributes, extend the namespaces bindings"
   (unless *ignore-namespaces*
@@ -246,19 +265,13 @@
                              (prefix name)
                              (namespace (find-namespace uri)))
                         (unless namespace
-                          (setf namespace 
-                                (register-namespace uri
-                                                    prefix
-                                                    (or (find-package prefix)
-                                                        (if *auto-create-namespace-packages*
-                                                            (make-package prefix :nicknames `(,(string-upcase prefix)))
-                                                          (error "Cannot find or create package ~s" prefix))))))
+                          (setf namespace (new-namespace uri prefix)))
                         (push `(,prefix . ,namespace) namespaces))))))
       (when default-namespace-uri
         (let ((namespace (find-namespace default-namespace-uri)))
-          (if namespace
-              (push `("" . namespace) namespaces)
-            (error "No prefix found for default namespace ~s" default-namespace-uri))))))
+          (unless namespace
+            (setf namespace (new-namespace default-namespace-uri)))
+          (push `("" . ,namespace) namespaces)))))
   namespaces)
 
 (defun print-identifier (identifier stream &optional as-attribute)