From bhyde at pobox.com  Wed Nov  1 01:38:47 2006
From: bhyde at pobox.com (Ben Hyde)
Date: Tue, 31 Oct 2006 20:38:47 -0500
Subject: [s-xml-devel] Yet more complexity in resolve-identifier
Message-ID: <F99387E3-7B58-4A60-B2C0-3755A43AD675@pobox.com>

The trivial part of the following diff is avoiding the attempt to  
call file-position on openmcl's string-input-streams.

The fun part changes the way that xml symbols are resolved so that  
new schemes can be introduced; for example looking them up in a  
dictionary.

Index: xml.lisp
===================================================================
RCS file: /project/s-xml/cvsroot/s-xml/src/xml.lisp,v
retrieving revision 1.16
diff -u -r1.16 xml.lisp
--- xml.lisp	31 Jan 2006 11:44:15 -0000	1.16
+++ xml.lisp	1 Nov 2006 01:29:50 -0000
@@ -28,8 +28,10 @@
		     "XML parser ~?~@[ near stream position ~d~]."
		     (xml-parser-error-message condition)
		     (xml-parser-error-args condition)
-		     (and (xml-parser-error-stream condition)
-			  (file-position (xml-parser-error-stream condition))))))
+		     (let ((stream? (xml-parser-error-stream condition)))
+		       (and stream?
+			    #+openmcl(not (typep stream? 'ccl::string-input-stream))
+			    (file-position stream?))))))
    (:documentation "Thrown by the XML parser to indicate errorneous  
input"))
(setf (documentation 'xml-parser-error-message 'function)
@@ -48,10 +50,10 @@
;; attribute parsing hooks
;; this is a bit complicated, refer to the mailing lists for a more  
detailed explanation

-(defun parse-attribute-name (string)
+(defun parse-attribute-name (state string)
    "Default parser for the attribute name"
    (declare (special *namespaces*))
-  (resolve-identifier string *namespaces* t))
+  (resolve-identifier state string *namespaces* t))
(defun parse-attribute-value (name string)
    "Default parser for the attribute value"
@@ -248,7 +250,7 @@
(defvar *auto-export-symbols* t
    "If t, export newly interned symbols form their packages")
-(defun resolve-identifier (identifier namespaces &optional as- 
attribute)
+(defun default-resolve-identifier (identifier namespaces as-attribute)
    "Resolve the string identifier in the list of namespace bindings"
    (if *ignore-namespaces*
        (intern identifier :keyword)
@@ -352,6 +354,11 @@
     (mini-buffer :documentation "The secondary, smaller reusable  
character buffer"
		:accessor get-mini-buffer
		:initform (make-extendable-string))
+   (resolve-identifier-hook
+    :documentation "Handle identifier strings as approprate given  
current namespaces etc."
+    :accessor get-resolve-identifier-hook
+    :initarg :resolve-identifier-hook
+    :initform #'default-resolve-identifier)
     (new-element-hook :documentation "Called when new element starts"
		     ;; Handle the start of a new xml element with name and  
attributes,
		     ;; receiving seed from previous element (sibling or parent)
@@ -482,6 +489,10 @@
	   (t
              (when (char/= char #\Null) (unread-char char stream))
	    (return identifier))))))
+
+(defmethod resolve-identifier ((state xml-parser-state) identifier  
namespaces as-attribute)
+  (funcall (get-resolve-identifier-hook state)
+	   identifier namespaces as-attribute))
	
(defun skip-comment (stream)
    "Skip an XML comment in stream, positioned after the opening '<!--',
@@ -557,7 +568,7 @@
         (when (zerop taglevel) (return))
         (setf char (read-char stream nil #\Null))
         (when (char= char #\Null)
-	 (error (parser-error "encountered unexpected eof for special (!  
or ?) tag" nil stream)))
+	 (error (parser-error "encountered unexpected eof for special (!  
or ?) tag")))
         (if (char/= string-delimiter #\Null)
	   ;; inside a string we only look for a closing string delimiter
	   (when (char= char string-delimiter)
@@ -584,7 +595,7 @@
       ;; read the attribute key
       (let ((key (let ((string (parse-identifier stream (get-mini- 
buffer state))))
                    (if *ignore-namespaces*
-                      (funcall *attribute-name-parser* string)
+                      (funcall *attribute-name-parser* state string)
                        (copy-seq string)))))
         ;; skip separating whitespace
         (setf char (skip-whitespace stream))
@@ -610,19 +621,19 @@
    (when (char= (peek-char nil stream nil #\Null) #\!)
      (skip-special-tag stream state)
      (return-from parse-xml-element))
-  (let ((char #\Null) buffer open-tag parent-seed has-children)
+  (let ((char #\Null) buffer open-tag-text parent-seed has-children)
      (declare (type character char))
      (setf parent-seed (get-seed state))
      ;; read tag name (no whitespace between < and name ?)
-    (setf open-tag (copy-seq (parse-identifier stream (get-mini- 
buffer state))))
+    (setf open-tag-text (copy-seq (parse-identifier stream (get-mini- 
buffer state))))
      ;; tag has been read, read attributes if any
      (multiple-value-bind (attributes peeked-char)
	(parse-xml-element-attributes stream state)
-      (let ((*namespaces* (extend-namespaces attributes *namespaces*)))
-        (setf open-tag (resolve-identifier open-tag *namespaces*))
+      (let* ((*namespaces* (extend-namespaces attributes *namespaces*))
+	     (open-tag (resolve-identifier state open-tag-text *namespaces*  
nil)))
          (unless *ignore-namespaces*
            (dolist (attribute attributes)
-            (setf (car attribute) (funcall *attribute-name-parser*  
(car attribute))
+            (setf (car attribute) (funcall *attribute-name-parser*  
state (car attribute))
                    (cdr attribute) (funcall *attribute-value-parser*  
(car attribute) (cdr attribute)))))
          (setf (get-seed state) (funcall (get-new-element-hook state)
                                          open-tag attributes (get- 
seed state)))
@@ -657,8 +668,7 @@
                          (setf (get-seed state) (funcall (get-text- 
hook state)
                                                          (copy-seq  
buffer) (get-seed state))))
                        (read-char stream)
-                      (let ((close-tag (resolve-identifier (parse- 
identifier stream (get-mini-buffer state))
-                                                            
*namespaces*)))
+                      (let ((close-tag (resolve-identifier state  
(parse-identifier stream (get-mini-buffer state)) *namespaces* nil)))
                          (unless (eq open-tag close-tag)
                            (error (parser-error "found <~a> not  
matched by </~a> but by <~a>"
                                                 (list open-tag open- 
tag close-tag) stream)))