From: Chris Hanson Date: Mon, 23 Jul 2007 04:12:45 +0000 (+0000) Subject: Require all names to conform to XML namespace specification; this is a X-Git-Tag: 20090517-FFI~487 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=bf6843df4dece09e4a1f61c9bcf158d164fc2f41;p=mit-scheme.git Require all names to conform to XML namespace specification; this is a consequence of conforming to the specification. --- diff --git a/v7/src/xml/xml-chars.scm b/v7/src/xml/xml-chars.scm index 399ef38e3..be8cf8aad 100644 --- a/v7/src/xml/xml-chars.scm +++ b/v7/src/xml/xml-chars.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: xml-chars.scm,v 1.9 2007/01/05 21:19:29 cph Exp $ +$Id: xml-chars.scm,v 1.10 2007/07/23 04:12:43 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -396,5 +396,13 @@ USA. alphabet:xml-extender (string->alphabet ".-_:"))) +(define alphabet:ncname-initial + (alphabet- alphabet:name-initial + (string->alphabet ":"))) + +(define alphabet:ncname-subsequent + (alphabet- alphabet:name-subsequent + (string->alphabet ":"))) + (define char-set:xml-whitespace (char-set #\space #\tab #\return #\linefeed)) \ No newline at end of file diff --git a/v7/src/xml/xml-names.scm b/v7/src/xml/xml-names.scm index 4d7598ff5..df6cb46a3 100644 --- a/v7/src/xml/xml-names.scm +++ b/v7/src/xml/xml-names.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: xml-names.scm,v 1.17 2007/07/23 02:46:07 cph Exp $ +$Id: xml-names.scm,v 1.18 2007/07/23 04:12:44 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -41,16 +41,10 @@ USA. (if (string-null? uri-string) qname (begin - (if (not (let ((s (symbol-name qname))) - (let ((c (find-prefix-separator s))) - (case c - ((#f) #t) - ((ILLEGAL) #f) - (else - (case (utf8-string->symbol (string-head s c)) - ((xml) (string=? uri-string xml-uri-string)) - ((xmlns) (string=? uri-string xmlns-uri-string)) - (else #t))))))) + (if (not (case (xml-qname-prefix qname) + ((xml) (string=? uri-string xml-uri-string)) + ((xmlns) (string=? uri-string xmlns-uri-string)) + (else #t))) (error:bad-range-argument uri-string 'MAKE-XML-NAME)) (%make-xml-name qname uri-string))))) @@ -76,12 +70,7 @@ USA. (or (xml-qname? object) (combo-name? object))) -(define (guarantee-xml-name object caller) - (if (not (xml-name? object)) - (error:not-xml-name object caller))) - -(define (error:not-xml-name object caller) - (error:wrong-type-argument object "an XML Name" caller)) +(define-guarantee xml-name "an XML Name") (define (null-xml-namespace-uri? object) (and (uri? object) @@ -110,22 +99,26 @@ USA. (and (symbol? object) (string-is-xml-nmtoken? (symbol-name object)))) -(define (guarantee-xml-nmtoken object caller) - (if (not (xml-nmtoken? object)) - (error:not-xml-nmtoken object caller))) - -(define (error:not-xml-nmtoken object caller) - (error:wrong-type-argument object "an XML name token" caller)) +(define-guarantee xml-nmtoken "an XML name token") (define (xml-nmtoken-string nmtoken) (guarantee-xml-nmtoken nmtoken 'XML-NMTOKEN-STRING) (symbol-name nmtoken)) -(define (string-is-xml-name? string) - (eq? (string-is-xml-nmtoken? string) 'NAME)) +(define (string-is-xml-qname? string) + (let ((end (string-length string))) + (let ((c (substring-find-next-char string 0 end #\:))) + (if c + (and (not (substring-find-next-char string (fix:+ c 1) end #\:)) + (string-is-xml-name? string 0 c) + (string-is-xml-name? string (fix:+ c 1) end)) + (string-is-xml-name? string 0 end))))) -(define (string-is-xml-nmtoken? string) - (let ((buffer (utf8-string->parser-buffer string))) +(define (string-is-xml-name? string #!optional start end) + (eq? (string-is-xml-nmtoken? string start end) 'NAME)) + +(define (string-is-xml-nmtoken? string #!optional start end) + (let ((buffer (utf8-string->parser-buffer string start end))) (letrec ((match-tail (lambda () @@ -218,7 +211,7 @@ USA. (define (make-xml-qname object) (if (string? object) (begin - (if (not (string-is-xml-name? object)) + (if (not (string-is-xml-qname? object)) (error:bad-range-argument object 'MAKE-XML-QNAME)) (utf8-string->symbol object)) (begin @@ -227,48 +220,29 @@ USA. (define (xml-qname? object) (and (interned-symbol? object) - (string-is-xml-name? (symbol-name object)))) - -(define (guarantee-xml-qname object caller) - (if (not (xml-qname? object)) - (error:not-xml-qname object caller))) + (string-is-xml-qname? (symbol-name object)))) -(define (error:not-xml-qname object caller) - (error:wrong-type-argument object "an XML QName" caller)) +(define-guarantee xml-qname "an XML QName") (define (xml-qname-string qname) (guarantee-xml-qname qname 'XML-QNAME-STRING) (symbol->utf8-string qname)) (define (xml-qname-local qname) + (guarantee-xml-qname qname 'XML-QNAME-LOCAL) (let ((s (symbol-name qname))) - (let ((c (find-prefix-separator s))) - (if (or (not c) (eq? c 'ILLEGAL)) - qname - (utf8-string->symbol (string-tail s (fix:+ c 1))))))) + (let ((c (string-find-next-char s #\:))) + (if c + (utf8-string->symbol (string-tail s (fix:+ c 1))) + qname)))) (define (xml-qname-prefix qname) + (guarantee-xml-qname qname 'XML-QNAME-PREFIX) (let ((s (symbol-name qname))) - (let ((c (find-prefix-separator s))) - (if (or (not c) (eq? c 'ILLEGAL)) - (null-xml-name-prefix) - (utf8-string->symbol (string-head s c)))))) - -(define (find-prefix-separator s) - (let ((c (string-find-next-char s #\:))) - (if (or (not c) - (let ((i (fix:+ c 1)) - (e (string-length s))) - (and (let ((char - (let ((port (open-input-string s i e))) - (port/set-coding port 'UTF-8) - (read-char port)))) - (and (not (eof-object? char)) - (not (char=? char #\:)) - (char-in-alphabet? char alphabet:name-initial))) - (not (substring-find-next-char s i e #\:))))) - c - 'ILLEGAL))) + (let ((c (string-find-next-char s #\:))) + (if c + (utf8-string->symbol (string-head s c)) + (null-xml-name-prefix))))) (define-record-type (make-combo-name qname expanded) diff --git a/v7/src/xml/xml-parser.scm b/v7/src/xml/xml-parser.scm index 5a179fc7c..9e44e71e3 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.76 2007/07/23 02:46:09 cph Exp $ +$Id: xml-parser.scm,v 1.77 2007/07/23 04:12:45 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -386,8 +386,7 @@ USA. (if (there-exists? (cdr attrs) (lambda (attr) (xml-name=? (xml-attribute-name attr) name))) - (perror p "Attributes with same name" - (xml-name-qname name))))))) + (perror p "Attributes with same name" (xml-name-qname name))))))) (define (parse-element-content b p name) (let ((vc (parse-content b))) @@ -535,21 +534,26 @@ USA. (*parser (with-pointer p (map (lambda (s) (cons (make-xml-qname s) p)) - (match match-name))))) + (match match-qname))))) (define (simple-name-parser type) (let ((m (string-append "Malformed " type " name"))) - (*parser (require-success m (map make-xml-qname (match match-name)))))) + (*parser (require-success m (map make-xml-qname (match match-ncname)))))) (define parse-entity-name (simple-name-parser "entity")) (define parse-pi-name (simple-name-parser "processing-instructions")) (define parse-notation-name (simple-name-parser "notation")) -(define (match-name buffer) - (and (match-parser-buffer-char-in-alphabet buffer alphabet:name-initial) +(define match-qname + (*matcher + (seq match-ncname + (? (seq ":" match-ncname))))) + +(define (match-ncname buffer) + (and (match-parser-buffer-char-in-alphabet buffer alphabet:ncname-initial) (let loop () (if (match-parser-buffer-char-in-alphabet buffer - alphabet:name-subsequent) + alphabet:ncname-subsequent) (loop) #t)))) @@ -580,25 +584,24 @@ USA. (let ((forbidden-uri (lambda () (perror p "Forbidden namespace URI" value)))) - (let ((guarantee-legal-uri - (lambda () - (if (or (string=? value xml-uri-string) - (string=? value xmlns-uri-string)) - (forbidden-uri))))) - (cond ((xml-name=? qname 'xmlns) - (string->uri value) ;signals error if not URI - (guarantee-legal-uri) - (cons (cons (null-xml-name-prefix) value) tail)) - ((xml-name-prefix=? qname 'xmlns) - (if (xml-name=? qname 'xmlns:xmlns) - (perror p "Illegal namespace prefix" qname)) - (string->uri value) ;signals error if not URI - (if (xml-name=? qname 'xmlns:xml) - (if (not (string=? value xml-uri-string)) - (forbidden-uri)) - (guarantee-legal-uri)) - (cons (cons (xml-name-local qname) value) tail)) - (else tail)))))) + (cond ((xml-name=? qname 'xmlns) + (string->uri value) ;signals error if not URI + (if (or (string=? value xml-uri-string) + (string=? value xmlns-uri-string)) + (forbidden-uri)) + (cons (cons (null-xml-name-prefix) value) tail)) + ((xml-name-prefix=? qname 'xmlns) + (if (xml-name=? qname 'xmlns:xmlns) + (perror p "Illegal namespace prefix" qname)) + (string->uri value) ;signals error if not URI + (if (if (xml-name=? qname 'xmlns:xml) + (not (string=? value xml-uri-string)) + (or (string-null? value) + (string=? value xml-uri-string) + (string=? value xmlns-uri-string))) + (forbidden-uri)) + (cons (cons (xml-name-local qname) value) tail)) + (else tail))))) *prefix-bindings*))) unspecific) @@ -726,7 +729,7 @@ USA. (alt (seq "#" (alt match-decimal (seq "x" match-hexadecimal))) - match-name) + match-qname) ";")))) (define parse-entity-reference-name ;[68] @@ -735,7 +738,7 @@ USA. parse-entity-name))) (define parse-entity-reference-deferred - (*parser (match (seq "&" match-name ";")))) + (*parser (match (seq "&" match-qname ";")))) (define parse-parameter-entity-reference-name ;[69] (*parser @@ -785,7 +788,7 @@ USA. (lambda (a) (car a)))) (define parse-declaration-attributes - (attribute-list-parser (*parser (map make-xml-qname (match match-name))) + (attribute-list-parser (*parser (map make-xml-qname (match match-qname))) (lambda (a) a))) (define (attribute-value-parser alphabet parse-reference) diff --git a/v7/src/xml/xml.pkg b/v7/src/xml/xml.pkg index 0f3a09e0c..888006e40 100644 --- a/v7/src/xml/xml.pkg +++ b/v7/src/xml/xml.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: xml.pkg,v 1.92 2007/07/23 02:46:07 cph Exp $ +$Id: xml.pkg,v 1.93 2007/07/23 04:12:41 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -291,6 +291,8 @@ USA. (export (runtime xml) alphabet:name-initial alphabet:name-subsequent + alphabet:ncname-initial + alphabet:ncname-subsequent coding-requires-bom? normalize-coding))