From e0e54c172fabbc202e9489e68082b263c7ce6d2b Mon Sep 17 00:00:00 2001
From: dlichteblau <dlichteblau>
Date: Sun, 4 Mar 2007 21:04:11 +0000
Subject: [PATCH] xml:base

---
 doc/html.xsl            |  1 +
 doc/index.xml           |  3 ++
 doc/klacks.xml          | 23 ++++++++++++
 doc/sax.xml             | 42 ++++++++++++++++++++++
 klacks/klacks-impl.lisp | 39 +++++++++++++++++++--
 klacks/klacks.lisp      |  5 +++
 xml/catalog.lisp        | 11 +++---
 xml/sax-handler.lisp    | 68 ++++++++++++++++++++++++++++++++++--
 xml/xml-parse.lisp      | 77 +++++++++++++++++++++++++++++++++++++----
 9 files changed, 252 insertions(+), 17 deletions(-)

diff --git a/doc/html.xsl b/doc/html.xsl
index cefd6bd..b7b0639 100644
--- a/doc/html.xsl
+++ b/doc/html.xsl
@@ -60,6 +60,7 @@
             <li><a href="klacks.html#sources">Parsing incrementally</a></li>
             <li><a href="klacks.html#convenience">Convenience functions</a></li>
             <li><a href="klacks.html#klacksax">Bridging Klacks and SAX</a></li>
+            <li><a href="klacks.html#locator">Location information</a></li>
             <li><a href="klacks.html#klacksax">Examples</a></li>
           </ul>
         </li>
diff --git a/doc/index.xml b/doc/index.xml
index d0d2269..69c450b 100644
--- a/doc/index.xml
+++ b/doc/index.xml
@@ -52,6 +52,9 @@
     <h2>Recent Changes</h2>
     <p class="nomargin"><tt>rel-2007-xx-yy</tt></p>
     <ul class="nomargin">
+      <li>xml:base support (SAX and Klacks only, not yet used in DOM).
+      See documentation <a href="sax.html#saxparser">here</a> and <a
+      href="klacks.html#locator">here</a>.</li>
       <li>Fixed attributes to carry an lname even without when occurring
       without a namespace.</li>
       <li>Klacks improvements: Incompatibly changed
diff --git a/doc/klacks.xml b/doc/klacks.xml
index 6c32e7a..6bd5c0b 100644
--- a/doc/klacks.xml
+++ b/doc/klacks.xml
@@ -282,6 +282,29 @@
       events to the SAX <tt>handler</tt>.
     </p>
 
+    <a name="locator"/>
+    <h3>Location information</h3>
+    <p>
+      <div class="def">Function KLACKS:CURRENT-LINE-NUMBER (source)</div>
+      Return an approximation of the current line number, or NIL.
+    </p>
+    <p>
+      <div class="def">Function KLACKS:CURRENT-COLUMN-NUMBER (source)</div>
+      Return an approximation of the current column number, or NIL.
+    </p>
+    <p>
+      <div class="def">Function KLACKS:CURRENT-SYSTEM-ID (source)</div>
+      Return the URI of the document being parsed.  This is either the
+    main document, or the entity's system ID while contents of a parsed
+    general external entity are being processed.
+    </p>
+    <p>
+      <div class="def">Function KLACKS:CURRENT-XML-BASE (source)</div>
+      Return the [Base URI] of the current element.  This URI can differ from
+   the value returned by <tt>current-system-id</tt> if xml:base
+      attributes are present.
+    </p>
+
     <a name="examples"/>
     <h3>Examples</h3>
     <p>
diff --git a/doc/sax.xml b/doc/sax.xml
index 707fd4d..9fc3937 100644
--- a/doc/sax.xml
+++ b/doc/sax.xml
@@ -476,6 +476,48 @@
       <em>fixme:</em> thread-safety
     </p>
 
+    <a name="saxparser"/>
+    <h3>Location information</h3>
+    <p>
+      <div class="def">Class SAX:SAX-PARSER ()</div>
+      A class providing location information through an
+      implementation-specific subclass.  Parsers will use
+      <tt>sax:register-sax-parser</tt> to pass their parser instance to
+      the handler.  The easiest way to receive sax parsers instances is
+      to inherit from sax-parser-mixin when defining a sax handler.
+    </p>
+    <p>
+      <div class="def">Class SAX:SAX-PARSER-MIXIN ()</div>
+      A mixin for sax handler classes that records the sax handler
+      object for use with the following functions.  Trampoline methods
+      are provided that allow those functions to be called directly on
+      the sax-parser-mixin.
+    </p>
+    <p>
+      <div class="def">Function SAX:SAX-HANDLER (sax-handler-mixin) => sax-handler</div>
+      Return the sax-parser instance recorded by this handler, or NIL.
+    </p>
+    <p>
+      <div class="def">Function SAX:LINE-NUMBER (sax-parser)</div>
+      Return an approximation of the current line number, or NIL.
+    </p>
+    <p>
+      <div class="def">Function SAX:COLUMN-NUMBER (sax-parser)</div>
+      Return an approximation of the current column number, or NIL.
+    </p>
+    <p>
+      <div class="def">Function SAX:SYSTEM-ID (sax-parser)</div>
+      Return the URI of the document being parsed.  This is either the
+    main document, or the entity's system ID while contents of a parsed
+    general external entity are being processed.
+    </p>
+    <p>
+      <div class="def">Function SAX:XML-BASE (sax-parser)</div>
+      Return the [Base URI] of the current element.  This URI can differ from
+   the value returned by <tt>sax:system-id</tt> if xml:base
+      attributes are present.
+    </p>
+
     <a name="catalogs"/>
     <h3>XML Catalogs</h3>
     <p>
diff --git a/klacks/klacks-impl.lisp b/klacks/klacks-impl.lisp
index 7cd6027..40f3290 100644
--- a/klacks/klacks-impl.lisp
+++ b/klacks/klacks-impl.lisp
@@ -356,11 +356,12 @@
 
 (defun klacks/entity-reference (source zstream name cont)
   (assert (not (zstream-token-category zstream)))
-  (with-source (source temporary-streams)
+  (with-source (source temporary-streams context)
     (let ((new-xstream (entity->xstream zstream name :general nil)))
       (push new-xstream temporary-streams)
       (push :stop (zstream-input-stack zstream))
       (zstream-push new-xstream zstream)
+      (push (stream-name-uri (xstream-name new-xstream)) (base-stack context))
       (let ((next
 	     (lambda ()
 	       (klacks/entity-reference-2 source zstream new-xstream cont))))
@@ -371,12 +372,13 @@
 	    (klacks/ext-parsed-ent source zstream next)))))))
 
 (defun klacks/entity-reference-2 (source zstream new-xstream cont)
-  (with-source (source temporary-streams)
+  (with-source (source temporary-streams context)
     (unless (eq (peek-token zstream) :eof)
       (wf-error zstream "Trailing garbage. - ~S" (peek-token zstream)))
     (assert (eq (peek-token zstream) :eof))
     (assert (eq (pop (zstream-input-stack zstream)) new-xstream))
     (assert (eq (pop (zstream-input-stack zstream)) :stop))
+    (pop (base-stack context))
     (setf (zstream-token-category zstream) nil)
     (setf temporary-streams (remove new-xstream temporary-streams))
     (close-xstream new-xstream)
@@ -441,6 +443,39 @@
       element-name attribute-name type default))
 
 
+;;;; locator
+
+(defun source-xstream (source)
+  (car (zstream-input-stack (main-zstream (slot-value source 'context)))))
+
+(defun source-stream-name (source)
+  (let ((xstream (source-xstream source)))
+    (if xstream
+	(xstream-name xstream)
+	nil)))
+
+(defmethod current-line-number ((source cxml-source))
+  (let ((x (source-xstream source)))
+    (if x
+	(xstream-line-number x)
+	nil)))
+
+(defmethod current-column-number ((source cxml-source))
+  (let ((x (source-xstream source)))
+    (if x
+	(xstream-column-number x)
+	nil)))
+
+(defmethod current-system-id ((source cxml-source))
+  (let ((name (source-stream-name source)))
+    (if name
+	(stream-name-uri name)
+	nil)))
+
+(defmethod current-xml-base ((source cxml-source))
+  (car (base-stack (slot-value source 'context))))
+
+
 ;;;; debugging
 
 #+(or)
diff --git a/klacks/klacks.lisp b/klacks/klacks.lisp
index 2f54859..c75bb31 100644
--- a/klacks/klacks.lisp
+++ b/klacks/klacks.lisp
@@ -40,6 +40,11 @@
 ;;;(defgeneric klacks:current-characters (source))
 (defgeneric klacks:current-cdata-section-p (source))
 
+(defgeneric current-line-number (source))
+(defgeneric current-column-number (source))
+(defgeneric current-system-id (source))
+(defgeneric current-xml-base (source))
+
 (defmacro klacks:with-open-source ((var source) &body body)
   `(let ((,var ,source))
      (unwind-protect
diff --git a/xml/catalog.lisp b/xml/catalog.lisp
index df6b214..1828914 100644
--- a/xml/catalog.lisp
+++ b/xml/catalog.lisp
@@ -258,17 +258,17 @@
   ((result :initform (make-entry-file) :accessor result)
    (next :initform '() :accessor next)
    (prefer-stack :initform (list *prefer*) :accessor prefer-stack)
-   (base-stack :accessor base-stack)))
+   (catalog-base-stack :accessor catalog-base-stack)))
 
 (defmethod initialize-instance :after
     ((instance catalog-parser) &key uri)
-  (setf (base-stack instance) (list uri)))
+  (setf (catalog-base-stack instance) (list uri)))
 
 (defmethod prefer ((handler catalog-parser))
   (car (prefer-stack handler)))
 
 (defmethod base ((handler catalog-parser))
-  (car (base-stack handler)))
+  (car (catalog-base-stack handler)))
 
 (defun get-attribute/lname (name attributes)
   (let ((a (find name attributes
@@ -283,6 +283,7 @@
   (setf lname (or lname qname))
   ;; we can dispatch on lnames only because we validate against the DTD,
   ;; which disallows other namespaces.
+  ;; FIXME: we don't, because we can't.
   (push (let ((new (get-attribute/lname "prefer" attrs)))
           (cond
             ((equal new "public") :public)
@@ -290,7 +291,7 @@
             ((null new) (prefer handler))))
         (prefer-stack handler))
   (push (string-or (get-attribute/lname "base" attrs) (base handler))
-        (base-stack handler))
+        (catalog-base-stack handler))
   (flet ((geturi (lname)
            (puri:merge-uris
             (safe-parse-uri (get-attribute/lname lname attrs))
@@ -341,7 +342,7 @@
 
 (defmethod sax:end-element ((handler catalog-parser) uri lname qname)
   (declare (ignore uri lname qname))
-  (pop (base-stack handler))
+  (pop (catalog-base-stack handler))
   (pop (prefer-stack handler)))
 
 (defmethod sax:end-document ((handler catalog-parser))
diff --git a/xml/sax-handler.lisp b/xml/sax-handler.lisp
index 8b14251..0f0b8ea 100644
--- a/xml/sax-handler.lisp
+++ b/xml/sax-handler.lisp
@@ -39,8 +39,6 @@
 ;;   don't really see why.
 ;; o Missing stuff from Java SAX2:
 ;;   * ignorable-whitespace
-;;   * document-locator/(setf document-locator)
-;;     (probably implies a handler class with an appropriate slot)
 ;;   * skipped-entity
 ;;   * The whole ErrorHandler class, this is better handled using
 ;;     conditions (but isn't yet)
@@ -82,10 +80,64 @@
            #:notation-declaration
            #:element-declaration
            #:attribute-declaration
-           #:entity-resolver))
+           #:entity-resolver
+
+	   #:sax-parser
+	   #:sax-parser-mixin
+	   #:register-sax-parser
+	   #:line-number
+	   #:column-number
+	   #:system-id
+	   #:xml-base))
 
 (in-package :sax)
 
+
+;;;; SAX-PARSER interface 
+
+(defclass sax-parser () ())
+
+(defclass sax-parser-mixin ()
+    ((sax-parser :initform nil :reader sax-parser)))
+
+(defgeneric line-number (sax-parser)
+  (:documentation
+   "Return an approximation of the current line number, or NIL.")
+  (:method ((handler sax-parser-mixin))
+    (if (sax-parser handler)
+	(line-number (sax-parser handler))
+	nil)))
+
+(defgeneric column-number (sax-parser)
+  (:documentation
+   "Return an approximation of the current column number, or NIL.")
+  (:method ((handler sax-parser-mixin))
+    (if (sax-parser handler)
+	(column-number (sax-parser handler))
+	nil)))
+
+(defgeneric system-id (sax-parser)
+  (:documentation
+   "Return the URI of the document being parsed.  This is either the
+    main document, or the entity's system ID while contents of a parsed
+    general external entity are being processed.")
+  (:method ((handler sax-parser-mixin))
+    (if (sax-parser handler)
+	(system-id (sax-parser handler))
+	nil)))
+
+(defgeneric xml-base (sax-parser)
+  (:documentation
+   "Return the [Base URI] of the current element.  This URI can differ from
+   the value returned by SAX:SYSTEM-ID if xml:base attributes are present.")
+  (:method ((handler sax-parser-mixin))
+    (if (sax-parser handler)
+	(xml-base (sax-parser handler))
+	nil)))
+
+
+;;;; Configuration variables
+
 ;; The http://xml.org/sax/features/namespaces property
 (defvar *namespace-processing* t
   "If non-nil (the default), namespace processing is enabled.
@@ -349,6 +401,16 @@ finished, if present.")
     (declare (ignore resolver))
     nil))
 
+(defgeneric register-sax-parser
+    (handler sax-parser)
+  (:documentation
+   "Set the SAX-PARSER instance of this handler.")
+  (:method ((handler t) sax-parser)
+    (declare (ignore sax-parser))
+    nil)
+  (:method ((handler sax-parser-mixin) sax-parser)
+    (setf (slot-value handler 'sax-parser) sax-parser)))
+
 ;; internal for now
 (defgeneric dtd (handler dtd)
   (:method ((handler t) dtd) (declare (ignore dtd)) nil))
diff --git a/xml/xml-parse.lisp b/xml/xml-parse.lisp
index 244d9ab..f215f0b 100644
--- a/xml/xml-parse.lisp
+++ b/xml/xml-parse.lisp
@@ -183,6 +183,8 @@
   handler
   (dtd nil)
   model-stack
+  ;; xml:base machen wir fuer klacks mal gleich als expliziten stack:
+  base-stack
   (referenced-notations '())
   (id-table (%make-rod-hash-table))
   ;; FIXME: Wofuer ist name-hashtable da?  Will man das wissen?
@@ -659,6 +661,38 @@
 	  stream
 	  (format nil "End of file~@[: ~?~]" x args)))
 
+(defclass cxml-parser (sax:sax-parser) ((ctx :initarg :ctx)))
+
+(defun parser-xstream (parser)
+  (car (zstream-input-stack (main-zstream (slot-value parser 'ctx)))))
+
+(defun parser-stream-name (parser)
+  (let ((xstream (parser-xstream parser)))
+    (if xstream
+	(xstream-name xstream)
+	nil)))
+
+(defmethod sax:line-number ((parser cxml-parser))
+  (let ((x (parser-xstream parser)))
+    (if x
+	(xstream-line-number x)
+	nil)))
+
+(defmethod sax:column-number ((parser cxml-parser))
+  (let ((x (parser-xstream parser)))
+    (if x
+	(xstream-column-number x)
+	nil)))
+
+(defmethod sax:system-id ((parser cxml-parser))
+  (let ((name (parser-stream-name parser)))
+    (if name
+	(stream-name-uri name)
+	nil)))
+
+(defmethod sax:xml-base ((parser cxml-parser))
+  (car (base-stack (slot-value parser 'ctx))))
+
 (defvar *validate* t)
 (defvar *external-subset-p* nil)
 
@@ -966,8 +1000,10 @@
 (defun call-with-entity-expansion-as-stream (zstream cont name kind internalp)
   ;; `zstream' is for error messages
   (let ((in (entity->xstream zstream name kind internalp)))
+    (push (stream-name-uri (xstream-name in)) (base-stack *ctx*))
     (unwind-protect
         (funcall cont in)
+      (pop (base-stack *ctx*))
       (close-xstream in))))
 
 (defun ensure-dtd ()
@@ -2570,13 +2606,18 @@
   #+rune-is-integer
   (when recode
     (setf handler (make-recoder handler #'rod-to-utf8-string)))
-  (let ((*ctx*
-         (make-context :handler handler
-		       :main-zstream input
-                       :entity-resolver entity-resolver
-                       :disallow-internal-subset disallow-internal-subset))
-        (*validate* validate)
-	(*namespace-bindings* *initial-namespace-bindings*))
+  (let* ((xstream (car (zstream-input-stack input)))
+	 (name (xstream-name xstream))
+	 (base (when name (stream-name-uri name)))
+	 (*ctx*
+	  (make-context :handler handler
+			:main-zstream input
+			:entity-resolver entity-resolver
+			:base-stack (list (or base ""))
+			:disallow-internal-subset disallow-internal-subset))
+	 (*validate* validate)
+	 (*namespace-bindings* *initial-namespace-bindings*))
+    (sax:register-sax-parser handler (make-instance 'cxml-parser :ctx *ctx*))
     (sax:start-document handler)
     ;; document ::= XMLDecl? Misc* (doctypedecl Misc*)? element Misc*
     ;; Misc ::= Comment | PI |  S
@@ -2658,6 +2699,7 @@
       (p/etag input qname))
     (sax:end-element (handler *ctx*) uri lname qname)
     (undeclare-namespaces new-b)
+    (pop (base-stack *ctx*))
     (validate-end-element *ctx* qname)))
 
 (defun p/sztag (input)
@@ -2675,6 +2717,7 @@
 	(when sax:*namespace-processing*
 	  (setf new-namespaces (declare-namespaces attrs))
 	  (mapc #'set-attribute-namespace attrs))
+	(push (compute-base attrs) (base-stack *ctx*))
 	(multiple-value-bind (uri prefix local-name)
 	    (if sax:*namespace-processing*
 		(decode-qname name)
@@ -2701,6 +2744,23 @@
     (when (cdr sem2)
       (wf-error input "no attributes allowed in end tag"))))
 
+;; copy&paste from cxml-rng
+(defun escape-uri (string)
+  (with-output-to-string (out)
+    (loop for c across (cxml::rod-to-utf8-string string) do
+	  (let ((code (char-code c)))
+	    ;; http://www.w3.org/TR/xlink/#link-locators
+	    (if (or (>= code 127) (<= code 32) (find c "<>\"{}|\\^`"))
+		(format out "%~2,'0X" code)
+		(write-char c out))))))
+
+(defun compute-base (attrs)
+  (let ((new (sax:find-attribute "xml:base" attrs))
+	(current (car (base-stack *ctx*))))
+    (if new
+	(puri:merge-uris (escape-uri (sax:attribute-value new)) current)
+	current)))
+
 (defun process-characters (input sem)
   (consume-token input)
   (when (search #"]]>" sem)
@@ -3317,6 +3377,7 @@
                              (return))))
                        res))))
 
+;; used only by read-att-value-2
 (defun internal-entity-expansion (name)
   (let ((def (get-entity-definition name :general (dtd *ctx*))))
     (unless def
@@ -3326,6 +3387,7 @@
     (or (entdef-expansion def)
         (setf (entdef-expansion def) (find-internal-entity-expansion name)))))
 
+;; used only by read-att-value-2
 (defun find-internal-entity-expansion (name)
   (let ((zinput (make-zstream)))
     (with-rune-collector-3 (collect)
@@ -3366,6 +3428,7 @@
          (lambda (zinput)
            (muffle (car (zstream-input-stack zinput))))) ))))
 
+;; callback for DOM
 (defun resolve-entity (name handler dtd)
   (let ((*validate* nil))
     (if (get-entity-definition name :general dtd)