Update of /project/cxml/cvsroot/cxml/xml In directory clnet:/tmp/cvs-serv2817/xml

Modified Files: catalog.lisp sax-handler.lisp xml-parse.lisp Log Message: xml:base

--- /project/cxml/cvsroot/cxml/xml/catalog.lisp 2006/01/23 21:49:42 1.4 +++ /project/cxml/cvsroot/cxml/xml/catalog.lisp 2007/03/04 21:04:13 1.5 @@ -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)) --- /project/cxml/cvsroot/cxml/xml/sax-handler.lisp 2006/09/09 10:06:17 1.6 +++ /project/cxml/cvsroot/cxml/xml/sax-handler.lisp 2007/03/04 21:04:13 1.7 @@ -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 @@ (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)) --- /project/cxml/cvsroot/cxml/xml/xml-parse.lisp 2007/03/04 18:30:42 1.66 +++ /project/cxml/cvsroot/cxml/xml/xml-parse.lisp 2007/03/04 21:04:13 1.67 @@ -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)