From: Chris Hanson Date: Wed, 24 Sep 2003 22:39:12 +0000 (+0000) Subject: Implement abstraction for null namespace prefix and default namespace X-Git-Tag: 20090517-FFI~1793 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ebff9c9d2db40790a18600399d69accefb4d0b71;p=mit-scheme.git Implement abstraction for null namespace prefix and default namespace URI, then change their representations to be something other than #F. Change references to namespace "URI" to be "IRI" instead. Make some changes to enhance support for namespace declaration parsing. --- diff --git a/v7/src/xml/xml-parser.scm b/v7/src/xml/xml-parser.scm index 440fb87b8..480b7d1ce 100644 --- a/v7/src/xml/xml-parser.scm +++ b/v7/src/xml/xml-parser.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: xml-parser.scm,v 1.41 2003/09/24 03:26:19 cph Exp $ +$Id: xml-parser.scm,v 1.42 2003/09/24 22:39:09 cph Exp $ Copyright 2001,2002,2003 Massachusetts Institute of Technology @@ -176,9 +176,7 @@ USA. (xml-declaration-parser "XML text declaration" #t)) (define (transform-declaration attributes text-decl? p) - (if (not (for-all? attributes - (lambda (attribute) - (simple-xml-attribute-value? (cdr attribute))))) + (if (not (for-all? attributes xml-attribute-value)) (perror p "XML declaration can't contain entity refs" attributes)) (let ((finish (lambda (version encoding standalone) @@ -350,7 +348,7 @@ USA. "Incorrect attribute value" (string->symbol name))) (if (and (not (eq? type '|CDATA|)) - (simple-xml-attribute-value? av)) + (xml-attribute-value attribute)) (set-car! av (trim-attribute-whitespace (car av)))) attributes) (begin @@ -472,38 +470,35 @@ USA. (tail (loop (cdr attributes)))) (let ((s (car name)) (pn (cdr name))) - (let ((uri + (let ((iri (lambda () - (if (not (simple-xml-attribute-value? value)) - (perror pn "Illegal namespace URI" value)) - (if (string-null? (car value)) - #f ;xmlns="" - (car value)))) - (forbidden-uri - (lambda (uri) - (perror pn "Forbidden namespace URI" uri)))) - (let ((guarantee-legal-uri - (lambda (uri) - (if (and uri - (or (string=? uri xml-uri) - (string=? uri xmlns-uri))) - (forbidden-uri uri))))) + (string->symbol + (or (xml-attribute-value (car attributes)) + (perror pn "Illegal namespace IRI" value))))) + (forbidden-iri + (lambda (iri) + (perror pn "Forbidden namespace IRI" iri)))) + (let ((guarantee-legal-iri + (lambda (iri) + (if (or (eq? iri xml-iri) + (eq? iri xmlns-iri)) + (forbidden-iri iri))))) (cond ((string=? "xmlns" s) - (let ((uri (uri))) - (guarantee-legal-uri uri) - (cons (cons #f uri) tail))) + (let ((iri (iri))) + (guarantee-legal-iri iri) + (cons (cons (null-xml-name-prefix) iri) tail))) ((string-prefix? "xmlns:" s) (if (string=? "xmlns:xmlns" s) (perror pn "Illegal namespace prefix" s)) - (let ((uri (uri))) - (if (not uri) ;legal in XML 1.1 - (forbidden-uri "")) + (let ((iri (iri))) + (if (default-xml-namespace-iri? iri) + ;; legal in XML 1.1 + (forbidden-iri "")) (if (string=? "xmlns:xml" s) - (if (not (and uri (string=? uri xml-uri))) - (forbidden-uri uri)) - (guarantee-legal-uri uri)) - (cons (cons (string->symbol (string-tail s 6)) - uri) + (if (not (eq? iri xml-iri)) + (forbidden-iri iri)) + (guarantee-legal-iri iri)) + (cons (cons (string-tail->symbol s 6) iri) tail))) (else tail)))))) *prefix-bindings*))) @@ -517,31 +512,34 @@ USA. (p (cdr n))) (let ((simple (string->symbol s)) (c (string-find-next-char s #\:))) - (let ((uri + (let ((iri (and (not *in-dtd?*) (or element-name? c) - (let ((prefix (and c (string->symbol (string-head s c))))) + (let ((prefix + (if c + (string-head->symbol s c) + (null-xml-name-prefix)))) (case prefix - ((xmlns) xmlns-uri) - ((xml) xml-uri) + ((xmlns) xmlns-iri) + ((xml) xml-iri) (else (let ((entry (assq prefix *prefix-bindings*))) (if entry (cdr entry) (begin - (if prefix + (if (not (null-xml-name-prefix? prefix)) (perror p "Unknown XML prefix" prefix)) - #f))))))))) - (if uri + (default-xml-namespace-iri)))))))))) + (if iri (%make-xml-name simple - (string->symbol uri) + iri (if c - (string->symbol (string-tail s (fix:+ c 1))) + (string-tail->symbol s (fix:+ c 1)) simple)) simple))))) -(define xml-uri "http://www.w3.org/XML/1998/namespace") -(define xmlns-uri "http://www.w3.org/2000/xmlns/") +(define xml-iri "http://www.w3.org/XML/1998/namespace") +(define xmlns-iri "http://www.w3.org/2000/xmlns/") ;;;; Processing instructions @@ -887,7 +885,9 @@ USA. (let ((entity (find-parameter-entity name))) (and entity (xml-parameter-!entity-value entity)))))) - (if (simple-xml-attribute-value? value) + (if (and (pair? value) + (string? (car value)) + (null? (cdr value))) (car value) (begin (set! *parameter-entities* 'STOP) @@ -917,7 +917,9 @@ USA. (let ((value (xml-!entity-value entity))) (cond ((xml-external-id? value) #f) (in-attribute? value) - ((simple-xml-attribute-value? value) + ((and (pair? value) + (string? (car value)) + (null? (cdr value))) (reparse-entity-value-string name (car value) p)) (else (if (or *standalone?* *internal-dtd?*) @@ -1106,12 +1108,14 @@ USA. (type (vector-ref v 1)) (default (vector-ref v 2))) (list name type - (if (and (not (eq? type '|CDATA|)) - (pair? default) - (simple-xml-attribute-value? (cdr default))) - (list (car default) - (trim-attribute-whitespace (cadr default))) - default)))) + (let ((dv + (and (not (eq? type '|CDATA|)) + (pair? default) + (xml-attribute-value default)))) + (if dv + (list (car default) + (trim-attribute-whitespace dv)) + default))))) (seq S parse-attribute-name S diff --git a/v7/src/xml/xml-struct.scm b/v7/src/xml/xml-struct.scm index 6832b00f4..dcbcac616 100644 --- a/v7/src/xml/xml-struct.scm +++ b/v7/src/xml/xml-struct.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: xml-struct.scm,v 1.29 2003/09/24 04:55:56 cph Exp $ +$Id: xml-struct.scm,v 1.30 2003/09/24 22:39:12 cph Exp $ Copyright 2001,2002,2003 Massachusetts Institute of Technology @@ -40,9 +40,9 @@ USA. (write (combo-name-simple name) port)))) (define-record-type - (make-universal-name uri local combos) + (make-universal-name iri local combos) universal-name? - (uri universal-name-uri) + (iri universal-name-iri) (local universal-name-local) (combos universal-name-combos)) @@ -58,39 +58,48 @@ USA. (define (error:not-xml-name object caller) (error:wrong-type-argument object "an XML name" caller)) -(define (make-xml-namespace-uri uri) - (if (string? uri) +(define (make-xml-namespace-iri iri) + (if (string? iri) (begin - (if (not (namespace-uri-string? uri)) - (error:not-xml-namespace-uri uri 'MAKE-XML-NAMESPACE-URI)) - (string->symbol uri)) + (if (not (namespace-iri-string? iri)) + (error:not-xml-namespace-iri iri 'MAKE-XML-NAMESPACE-IRI)) + (string->symbol iri)) (begin - (if uri (guarantee-xml-namespace-uri uri 'MAKE-XML-NAMESPACE-URI)) - uri))) + (guarantee-xml-namespace-iri iri 'MAKE-XML-NAMESPACE-IRI) + iri))) -(define (xml-namespace-uri? object) +(define (xml-namespace-iri? object) (and (interned-symbol? object) - (namespace-uri-string? (symbol-name object)))) + (namespace-iri-string? (symbol-name object)))) -(define (namespace-uri-string? object) - (and (fix:> (string-length object) 0) - (utf8-string-valid? object))) +(define (namespace-iri-string? object) + ;; See RFC 1630 for correct syntax. + (utf8-string-valid? object)) -(define (guarantee-xml-namespace-uri object caller) - (if (not (xml-namespace-uri? object)) - (error:not-xml-namespace-uri object caller))) +(define (default-xml-namespace-iri? object) + (eq? object '||)) -(define (error:not-xml-namespace-uri object caller) - (error:wrong-type-argument object "an XML namespace URI" caller)) +(define (default-xml-namespace-iri) + '||) -(define (xml-namespace-uri-string uri) - (guarantee-xml-namespace-uri uri 'XML-NAMESPACE-URI-STRING) - (symbol->string uri)) +(define (guarantee-xml-namespace-iri object caller) + (if (not (xml-namespace-iri? object)) + (error:not-xml-namespace-iri object caller))) + +(define (error:not-xml-namespace-iri object caller) + (error:wrong-type-argument object "an XML namespace IRI" caller)) + +(define (xml-namespace-iri->string iri) + (guarantee-xml-namespace-iri iri 'XML-NAMESPACE-IRI->STRING) + (symbol->string iri)) -(define (xml-intern simple #!optional uri) - (make-xml-name simple (if (default-object? uri) #f uri))) +(define (xml-intern simple #!optional iri) + (make-xml-name simple + (if (default-object? iri) + (default-xml-namespace-iri) + iri))) -(define (make-xml-name simple uri) +(define (make-xml-name simple iri) (let ((lose (lambda () (error:wrong-type-argument simple "an XML name" 'MAKE-XML-NAME)))) @@ -99,27 +108,25 @@ USA. ((string? simple) (values simple (string->symbol simple))) (else (lose))) (let ((type (string-is-xml-nmtoken? string))) - (cond ((and type (not uri)) + (cond ((and type (default-xml-namespace-iri? iri)) symbol) ((eq? type 'NAME) (%make-xml-name symbol - (make-xml-namespace-uri uri) + (make-xml-namespace-iri iri) (let ((c (string-find-next-char string #\:))) (if c - (substring->symbol string - (fix:+ c 1) - (string-length string)) + (string-tail->symbol string (fix:+ c 1)) symbol)))) (else (lose))))))) -(define (%make-xml-name simple uri local) +(define (%make-xml-name simple iri local) (let ((uname (hash-table/intern! (hash-table/intern! universal-names - uri + iri make-eq-hash-table) local (lambda () - (make-universal-name uri + (make-universal-name iri local (make-eq-hash-table)))))) (hash-table/intern! (universal-name-combos uname) @@ -140,25 +147,30 @@ USA. (define (xml-name-string name) (symbol-name (xml-name-simple name))) -(define (xml-name-uri name) - (cond ((xml-nmtoken? name) #f) - ((combo-name? name) (universal-name-uri (combo-name-universal name))) - (else (error:not-xml-name name 'XML-NAME-URI)))) +(define (xml-name-iri name) + (cond ((xml-nmtoken? name) (default-xml-namespace-iri)) + ((combo-name? name) (universal-name-iri (combo-name-universal name))) + (else (error:not-xml-name name 'XML-NAME-IRI)))) -(define (xml-name-uri=? name uri) - (eq? (xml-name-uri name) uri)) +(define (xml-name-iri=? name iri) + (eq? (xml-name-iri name) iri)) (define (xml-name-prefix name) - (let ((simple - (lambda (name) - (let ((s (symbol-name name))) - (let ((c (string-find-next-char s #\:))) - (if c - (string->symbol (string-head s c)) - #f)))))) - (cond ((xml-nmtoken? name) (simple name)) - ((combo-name? name) (simple (combo-name-simple name))) - (else (error:not-xml-name name 'XML-NAME-PREFIX))))) + (let ((s + (symbol-name + (cond ((xml-nmtoken? name) name) + ((combo-name? name) (combo-name-simple name)) + (else (error:not-xml-name name 'XML-NAME-PREFIX)))))) + (let ((c (string-find-next-char s #\:))) + (if c + (string-head->symbol s c) + (null-xml-name-prefix))))) + +(define (null-xml-name-prefix? object) + (eq? object ':NULL)) + +(define (null-xml-name-prefix) + ':NULL) (define (xml-name-prefix=? name prefix) (eq? (xml-name-prefix name) prefix)) @@ -168,7 +180,7 @@ USA. (let ((s (symbol-name name))) (let ((c (string-find-next-char s #\:))) (if c - (string->symbol (string-tail s (fix:+ c 1))) + (string-tail->symbol s (fix:+ c 1)) name)))) ((combo-name? name) (universal-name-local (combo-name-universal name))) (else (error:not-xml-name name 'XML-NAME-LOCAL)))) @@ -638,35 +650,51 @@ USA. (or (xml-external-id-id dtd) (xml-external-id-uri dtd)))) -(define (simple-xml-attribute-value? object) - (and (pair? object) - (xml-char-data? (car object)) - (null? (cdr object)) - (car object))) - -(define (guarantee-simple-xml-attribute-value object caller) - (let ((v (simple-xml-attribute-value? object))) +(define (xml-attribute-value attr) + (and (pair? (cdr attr)) + (string? (cadr attr)) + (null? (cddr attr)) + (cadr attr))) + +(define (guarantee-xml-attribute-value object #!optional caller) + (let ((v (xml-attribute-value object))) (if (not v) - (error:not-simple-xml-attribute-value object caller)) + (error:not-xml-attribute-value object + (if (default-object? caller) + #f + caller))) v)) -(define (error:not-simple-xml-attribute-value object caller) +(define (error:not-xml-attribute-value object caller) (error:wrong-type-argument object "simple XML attribute value" caller)) +(define (xml-attribute-namespace-decl? attr) + (or (xml-name=? (car attr) 'xmlns) + (xml-name-prefix=? (car attr) 'xmlns))) + (define (xml-element-namespace-decls elt) - (guarantee-xml-element elt 'XML-ELEMENT-NAMESPACE-DECLS) - (let loop ((attrs (xml-element-attributes elt))) - (if (pair? attrs) - (let ((name (caar attrs)) - (keep - (lambda (prefix) - (cons (cons prefix - (make-xml-namespace-uri - (guarantee-simple-xml-attribute-value - (cdar attrs) - #f))) - (loop (cdr attrs)))))) - (cond ((xml-name=? name 'xmlns) (keep #f)) - ((xml-name-prefix=? name 'xmlns) (keep (xml-name-local name))) - (else (loop (cdr attrs))))) - '()))) \ No newline at end of file + (keep-matching-items (xml-element-attributes elt) + xml-attribute-namespace-decl?)) + +(define (xml-element-namespace-iri elt prefix) + (let ((attr + (find-matching-item (xml-element-attributes elt) + (lambda (attr) + (or (and (xml-name=? (car attr) 'xmlns) + (null-xml-name-prefix? prefix)) + (and (xml-name-prefix=? (car attr) 'xmlns) + (xml-name-local=? (car attr) prefix))))))) + (and attr + (make-xml-namespace-iri (guarantee-xml-attribute-value attr))))) + +(define (xml-element-namespace-prefix elt iri) + (let ((iri (xml-namespace-iri->string iri))) + (let ((attr + (find-matching-item (xml-element-attributes elt) + (lambda (attr) + (and (xml-attribute-namespace-decl? attr) + (string=? (guarantee-xml-attribute-value attr) iri)))))) + (and attr + (if (xml-name=? (car attr) 'xmlns) + (null-xml-name-prefix) + (xml-name-local (car attr))))))) \ No newline at end of file diff --git a/v7/src/xml/xml.pkg b/v7/src/xml/xml.pkg index 2b3172d05..2fc8e06b0 100644 --- a/v7/src/xml/xml.pkg +++ b/v7/src/xml/xml.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: xml.pkg,v 1.28 2003/09/24 04:17:45 cph Exp $ +$Id: xml.pkg,v 1.29 2003/09/24 22:39:05 cph Exp $ Copyright 2001,2002,2003 Massachusetts Institute of Technology @@ -51,7 +51,9 @@ USA. - error:not-simple-xml-attribute-value + default-xml-namespace-iri + default-xml-namespace-iri? + error:not-xml-attribute-value error:not-xml-!attlist error:not-xml-!element error:not-xml-!entity @@ -64,16 +66,16 @@ USA. error:not-xml-entity-ref error:not-xml-external-id error:not-xml-name - error:not-xml-namespace-uri + error:not-xml-namespace-iri error:not-xml-parameter-!entity error:not-xml-parameter-entity-ref error:not-xml-processing-instructions error:not-xml-unparsed-!entity - guarantee-simple-xml-attribute-value guarantee-xml-!attlist guarantee-xml-!element guarantee-xml-!entity guarantee-xml-!notation + guarantee-xml-attribute-value guarantee-xml-comment guarantee-xml-declaration guarantee-xml-document @@ -82,7 +84,7 @@ USA. guarantee-xml-entity-ref guarantee-xml-external-id guarantee-xml-name - guarantee-xml-namespace-uri + guarantee-xml-namespace-iri guarantee-xml-parameter-!entity guarantee-xml-parameter-entity-ref guarantee-xml-processing-instructions @@ -100,11 +102,13 @@ USA. make-xml-external-id make-xml-name make-xml-name-hash-table - make-xml-namespace-uri + make-xml-namespace-iri make-xml-parameter-!entity make-xml-parameter-entity-ref make-xml-processing-instructions make-xml-unparsed-!entity + null-xml-name-prefix + null-xml-name-prefix? set-xml-!attlist-definitions! set-xml-!attlist-name! set-xml-!element-content-type! @@ -140,7 +144,6 @@ USA. set-xml-unparsed-!entity-id! set-xml-unparsed-!entity-name! set-xml-unparsed-!entity-notation! - simple-xml-attribute-value? xml-!attlist-definitions xml-!attlist-name xml-!attlist? @@ -154,6 +157,8 @@ USA. xml-!notation-name xml-!notation? xml-attribute-list? + xml-attribute-namespace-decl? + xml-attribute-value xml-attribute-value-item? xml-attribute-value? xml-attribute? @@ -196,12 +201,12 @@ USA. xml-name-simple xml-name-simple=? xml-name-string - xml-name-uri - xml-name-uri=? + xml-name-iri + xml-name-iri=? xml-name=? xml-name? - xml-namespace-uri-string - xml-namespace-uri? + xml-namespace-iri->string + xml-namespace-iri? xml-nmtoken? xml-parameter-!entity-name xml-parameter-!entity-value