[cxml-cvs] CVS cxml/xml
dlichteblau
dlichteblau at common-lisp.net
Sun Mar 4 21:04:13 UTC 2007
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)
More information about the Cxml-cvs
mailing list