[cxml-cvs] CVS update: cxml/xml/xml-parse.lisp
David Lichteblau
dlichteblau at common-lisp.net
Sat Dec 3 21:02:39 UTC 2005
Update of /project/cxml/cvsroot/cxml/xml
In directory common-lisp.net:/tmp/cvs-serv23177/xml
Modified Files:
xml-parse.lisp
Log Message:
-eduni/namespaces/1.0/012.xml [not validating:] FAILED:
- well-formedness violation not detected
-[
-Namespace inequality test: equal after attribute value normalization
-]
Date: Sat Dec 3 22:02:38 2005
Author: dlichteblau
Index: cxml/xml/xml-parse.lisp
diff -u cxml/xml/xml-parse.lisp:1.44 cxml/xml/xml-parse.lisp:1.45
--- cxml/xml/xml-parse.lisp:1.44 Mon Nov 28 23:33:47 2005
+++ cxml/xml/xml-parse.lisp Sat Dec 3 22:02:38 2005
@@ -183,12 +183,8 @@
(defvar *ctx*)
-;; forward declaration for DEFVAR
-(declaim (special *default-namespace-bindings*))
-
(defstruct (context (:conc-name nil))
handler
- (namespace-bindings *default-namespace-bindings*)
(dtd nil)
model-stack
(referenced-notations '())
@@ -202,6 +198,11 @@
(defvar *expand-pe-p* nil)
+(defparameter *namespace-bindings*
+ '((#"" . nil)
+ (#"xmlns" . #"http://www.w3.org/2000/xmlns/")
+ (#"xml" . #"http://www.w3.org/XML/1998/namespace")))
+
;;;; ---------------------------------------------------------------------------
;;;; xstreams
;;;;
@@ -701,6 +702,8 @@
(elmdef (elmdef-external-p def))
(attdef (attdef-external-p def)))))
+;; attribute validation, defaulting, and normalization -- except for for
+;; uniqueness checks, which are done after namespaces have been declared
(defun process-attributes (ctx name attlist)
(let ((e (find-element name (dtd ctx))))
(cond
@@ -716,11 +719,11 @@
(t
(when (standalone-check-necessary-p ad)
(validity-error "(02) Standalone Document Declaration: missing attribute value"))
- (push (build-attribute (attdef-name ad)
- (cadr (attdef-default ad))
- nil)
+ (push (sax:make-attribute :qname (attdef-name ad)
+ :value (cadr (attdef-default ad))
+ :specified-p nil)
attlist)))))
- (dolist (a attlist) ;normalize non-CDATA values
+ (dolist (a attlist) ;normalize non-CDATA values
(let* ((qname (sax:attribute-qname a))
(adef (find-attribute e qname)))
(when (and adef (not (eq (attdef-type adef) :CDATA)))
@@ -729,7 +732,7 @@
(not (rod= (sax:attribute-value a) canon)))
(validity-error "(02) Standalone Document Declaration: attribute value not normalized"))
(setf (sax:attribute-value a) canon)))))
- (when *validate* ;maybe validate attribute values
+ (when *validate* ;maybe validate attribute values
(dolist (a attlist)
(validate-attribute ctx e a))))
((and *validate* attlist)
@@ -2607,66 +2610,52 @@
(sax:end-document handler))))
(defun p/element (input)
- (if sax:*namespace-processing*
- (p/element-ns input)
- (p/element-no-ns input)))
-
-(defun p/element-no-ns (input)
- ;; [39] element ::= EmptyElemTag | STag content ETag
- (error "sorry, bitrot")
- (multiple-value-bind (cat sem) (read-token input)
- (cond ((eq cat :ztag)
- (sax:start-element (handler *ctx*) nil nil (car sem) (build-attribute-list-no-ns (cdr sem)))
- (sax:end-element (handler *ctx*) nil nil (car sem)))
-
- ((eq cat :stag)
- (sax:start-element (handler *ctx*) nil nil (car sem) (build-attribute-list-no-ns (cdr sem)))
- (p/content input)
- (multiple-value-bind (cat2 sem2) (read-token input)
- (unless (and (eq cat2 :etag)
- (eq (car sem2) (car sem)))
- (wf-error input "Bad nesting. ~S / ~S" (mu sem) (mu (cons cat2 sem2)))))
- (sax:end-element (handler *ctx*) nil nil (car sem)))
-
- (t
- (wf-error input "Expecting element.")))))
-
-
-(defun p/element-ns (input)
(multiple-value-bind (cat sem) (read-token input)
(case cat
((:stag :ztag))
(:eof (eox input))
(t (wf-error input "element expected")))
- (destructuring-bind (&optional name &rest attrs) sem
+ (destructuring-bind (&optional name &rest raw-attrs) sem
(validate-start-element *ctx* name)
- (let ((ns-decls (declare-namespaces name attrs)))
- (multiple-value-bind (ns-uri prefix local-name) (decode-qname name)
+ (let* ((attrs
+ (process-attributes *ctx* name (build-attribute-list raw-attrs)))
+ (*namespace-bindings* *namespace-bindings*)
+ new-namespaces)
+ (when sax:*namespace-processing*
+ (setf new-namespaces (declare-namespaces attrs))
+ (mapc #'set-attribute-namespace attrs))
+ (multiple-value-bind (uri prefix local-name)
+ (if sax:*namespace-processing*
+ (decode-qname name)
+ (values nil nil nil))
(declare (ignore prefix))
- (let* ((raw-attlist (build-attribute-list-ns attrs))
- (attlist
- (remove-if-not (lambda (a)
- (or sax:*include-xmlns-attributes*
- (not (xmlns-attr-p (sax:attribute-qname a)))))
- (process-attributes *ctx* name raw-attlist))))
- (cond ((eq cat :ztag)
- (sax:start-element (handler *ctx*) ns-uri local-name name attlist)
- (sax:end-element (handler *ctx*) ns-uri local-name name))
+ (check-attribute-uniqueness attrs)
+ (unless (or sax:*include-xmlns-attributes*
+ (null sax:*namespace-processing*))
+ (setf attrs
+ (remove-if (compose #'xmlns-attr-p #'sax:attribute-qname)
+ attrs)))
+ (cond
+ ((eq cat :ztag)
+ (sax:start-element (handler *ctx*) uri local-name name attrs)
+ (sax:end-element (handler *ctx*) uri local-name name))
- ((eq cat :stag)
- (sax:start-element (handler *ctx*) ns-uri local-name name attlist)
- (p/content input)
- (multiple-value-bind (cat2 sem2) (read-token input)
- (unless (and (eq cat2 :etag)
- (eq (car sem2) name))
- (wf-error input "Bad nesting. ~S / ~S" (mu name) (mu (cons cat2 sem2))))
- (when (cdr sem2)
- (wf-error input "no attributes allowed in end tag")))
- (sax:end-element (handler *ctx*) ns-uri local-name name))
+ ((eq cat :stag)
+ (sax:start-element (handler *ctx*) uri local-name name attrs)
+ (p/content input)
+ (multiple-value-bind (cat2 sem2) (read-token input)
+ (unless (and (eq cat2 :etag)
+ (eq (car sem2) name))
+ (wf-error input "Bad nesting. ~S / ~S"
+ (mu name)
+ (mu (cons cat2 sem2))))
+ (when (cdr sem2)
+ (wf-error input "no attributes allowed in end tag")))
+ (sax:end-element (handler *ctx*) uri local-name name))
- (t
- (wf-error input "Expecting element, got ~S." cat)))))
- (undeclare-namespaces ns-decls))
+ (t
+ (wf-error input "Expecting element, got ~S." cat))))
+ (undeclare-namespaces new-namespaces))
(validate-end-element *ctx* name))))
(defun p/content (input)
@@ -3323,11 +3312,6 @@
;;; Namespace stuff
-(defvar *default-namespace-bindings*
- '((#"" . nil)
- (#"xmlns" . #"http://www.w3.org/2000/xmlns/")
- (#"xml" . #"http://www.w3.org/XML/1998/namespace")))
-
;; We already know that name is part of a valid XML name, so all we
;; have to check is that the first rune is a name-start-rune and that
;; there is not colon in it.
@@ -3357,7 +3341,7 @@
(defun find-namespace-binding (prefix)
- (cdr (or (assoc (or prefix #"") (namespace-bindings *ctx*) :test #'rod=)
+ (cdr (or (assoc (or prefix #"") *namespace-bindings* :test #'rod=)
(wf-error nil "Undeclared namespace prefix: ~A" (rod-string prefix)))))
;; FIXME: Should probably be refactored by adding :start and :end to rod=/rod-equal
@@ -3375,33 +3359,17 @@
(subseq attrname 6)
nil))
-(defun find-namespace-declarations (element attr-alist)
- (let ((result
- (mapcar #'(lambda (attr)
- (cons (attrname->prefix (car attr)) (cdr attr)))
- (remove-if-not #'xmlns-attr-p attr-alist :key #'car))))
- ;; Argh! PROCESS-ATTRIBUTES needs to know the attributes' namespaces
- ;; already. But namespace declarations can be done using default values
- ;; in the DTD. So we need to handle defaulting of attribute values twice,
- ;; once for xmlns attributes, then for all others. (I really hope I'm
- ;; wrong on this one, but I don't see how.)
- (let ((e (find-element element (dtd *ctx*))))
- (when e
- (dolist (ad (elmdef-attributes e)) ;handle default values
- (let* ((name (attdef-name ad))
- (prefix (attrname->prefix name)))
- (when (and (xmlns-attr-p name)
- (not (member prefix result :key #'car :test #'rod=))
- (listp (attdef-default ad)) ;:DEFAULT or :FIXED
- )
- (push (cons prefix (cadr (attdef-default ad))) result))))))
- result))
-
-(defun declare-namespaces (element attr-alist)
- (let ((ns-decls (find-namespace-declarations element attr-alist)))
- (dolist (ns-decl ns-decls )
+(defun find-namespace-declarations (attributes)
+ (loop
+ for attribute in attributes
+ for qname = (sax:attribute-qname attribute)
+ when (xmlns-attr-p qname)
+ collect (cons (attrname->prefix qname) (sax:attribute-value attribute))))
+
+(defun declare-namespaces (attributes)
+ (let ((ns-decls (find-namespace-declarations attributes)))
+ (dolist (ns-decl ns-decls)
;; check some namespace validity constraints
- ;; FIXME: Would be nice to add "this is insane, go ahead" restarts
(let ((prefix (car ns-decl))
(uri (if (rod= #"" (cdr ns-decl))
nil
@@ -3438,7 +3406,7 @@
may be bound to an empty namespace URI, thus ~
undeclaring it."))
(t
- (push (cons prefix uri) (namespace-bindings *ctx*))
+ (push (cons prefix uri) *namespace-bindings*)
(sax:start-prefix-mapping (handler *ctx*)
(car ns-decl)
(cdr ns-decl))))))
@@ -3446,62 +3414,53 @@
(defun undeclare-namespaces (ns-decls)
(dolist (ns-decl ns-decls)
- (setf (namespace-bindings *ctx*) (delete ns-decl (namespace-bindings *ctx*)))
(sax:end-prefix-mapping (handler *ctx*) (car ns-decl))))
-(defun build-attribute-list-no-ns (attr-alist)
- (mapcar #'(lambda (pair)
- (sax:make-attribute :qname (car pair)
- :value (cdr pair)
- :specified-p t))
- attr-alist))
-
-;; FIXME: Use a non-braindead way to enforce attribute uniqueness
-(defun build-attribute-list-ns (attr-alist)
+(defun build-attribute-list (attr-alist)
+ ;; fixme: if there is a reason this function reverses attribute order,
+ ;; it should be documented.
(let (attributes)
(dolist (pair attr-alist)
- (push (build-attribute (car pair) (cdr pair) t) attributes))
-
- ;; 5.3 Uniqueness of Attributes
- ;; In XML documents conforming to [the xmlns] specification, no
- ;; tag may contain two attributes which:
- ;; 1. have identical names, or
- ;; 2. have qualified names with the same local part and with
- ;; prefixes which have been bound to namespace names that are
- ;; identical.
- ;;
- ;; 1. is checked by read-tag-2, so we only deal with 2 here
- (do ((sublist attributes (cdr sublist)))
- ((null sublist) attributes)
- (let ((attr-1 (car sublist)))
+ (push (sax:make-attribute :qname (car pair)
+ :value (cdr pair)
+ :specified-p t)
+ attributes))
+ attributes))
+
+(defun check-attribute-uniqueness (attributes)
+ ;; 5.3 Uniqueness of Attributes
+ ;; In XML documents conforming to [the xmlns] specification, no
+ ;; tag may contain two attributes which:
+ ;; 1. have identical names, or
+ ;; 2. have qualified names with the same local part and with
+ ;; prefixes which have been bound to namespace names that are
+ ;; identical.
+ ;;
+ ;; 1. is checked by read-tag-2, so we only deal with 2 here
+ (loop for (attr-1 . rest) on attributes do
(when (and (sax:attribute-namespace-uri attr-1)
- (find-if #'(lambda (attr-2)
- (and (rod= (sax:attribute-namespace-uri attr-1)
- (sax:attribute-namespace-uri attr-2))
- (rod= (sax:attribute-local-name attr-1)
- (sax:attribute-local-name attr-2))))
- (cdr sublist)))
+ (find-if (lambda (attr-2)
+ (and (rod= (sax:attribute-namespace-uri attr-1)
+ (sax:attribute-namespace-uri attr-2))
+ (rod= (sax:attribute-local-name attr-1)
+ (sax:attribute-local-name attr-2))))
+ rest))
(wf-error nil
"Multiple definitions of attribute ~S in namespace ~S."
(mu (sax:attribute-local-name attr-1))
- (mu (sax:attribute-namespace-uri attr-1))))))))
+ (mu (sax:attribute-namespace-uri attr-1))))))
-(defun build-attribute (name value specified-p)
- (multiple-value-bind (prefix local-name) (split-qname name)
- (declare (ignorable local-name))
- (if (or (not prefix) ;; default namespace doesn't apply to attributes
- (and (rod= #"xmlns" prefix) (not sax:*use-xmlns-namespace*)))
- (sax:make-attribute :qname name
- :value value
- :specified-p specified-p)
+(defun set-attribute-namespace (attribute)
+ (let ((qname (sax:attribute-qname attribute)))
+ (multiple-value-bind (prefix local-name) (split-qname qname)
+ (declare (ignorable local-name))
+ (when (and prefix ;; default namespace doesn't apply to attributes
+ (or (not (rod= #"xmlns" prefix)) sax:*use-xmlns-namespace*))
(multiple-value-bind (uri prefix local-name)
- (decode-qname name)
+ (decode-qname qname)
(declare (ignore prefix))
- (sax:make-attribute :qname name
- :value value
- :namespace-uri uri
- :local-name local-name
- :specified-p specified-p)))))
+ (setf (sax:attribute-namespace-uri attribute) uri)
+ (setf (sax:attribute-local-name attribute) local-name))))))
;;;;;;;;;;;;;;;;;
More information about the Cxml-cvs
mailing list