#| -*-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
(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)
"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
(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*)))
(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/")
\f
;;;; Processing instructions
(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)
(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?*)
(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
#| -*-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
(write (combo-name-simple name) port))))
(define-record-type <universal-name>
- (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))
(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))
\f
-(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))))
((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)
(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))
(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))))
(or (xml-external-id-id dtd)
(xml-external-id-uri dtd))))
\f
-(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
#| -*-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
<xml-parameter-entity-ref>
<xml-processing-instructions>
<xml-unparsed-!entity>
- 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
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
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
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!
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?
xml-!notation-name
xml-!notation?
xml-attribute-list?
+ xml-attribute-namespace-decl?
+ xml-attribute-value
xml-attribute-value-item?
xml-attribute-value?
xml-attribute?
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
projects / mit-scheme.git / commitdiff