From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 26 Sep 2003 05:35:43 +0000 (+0000)
Subject: Restrict attribute values to be strings rather than lists of strings
X-Git-Tag: 20090517-FFI~1786
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1b545a3b4f5a45623f406e1db8481af1ccfe2c3d;p=mit-scheme.git

Restrict attribute values to be strings rather than lists of strings
and entity references.  In cases where we used to insert an entity
reference into an attribute value or into content, signal an error.

Create named accessors for the name and value of an attribute.  Soon I
will change the representation.
---

diff --git a/v7/src/xml/xml-output.scm b/v7/src/xml/xml-output.scm
index 979c4b35a..76a145800 100644
--- a/v7/src/xml/xml-output.scm
+++ b/v7/src/xml/xml-output.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml-output.scm,v 1.26 2003/09/26 03:56:51 cph Exp $
+$Id: xml-output.scm,v 1.27 2003/09/26 05:35:36 cph Exp $
 
 Copyright 2001,2002,2003 Massachusetts Institute of Technology
 
@@ -371,24 +371,14 @@ USA.
 (define (write-xml-attribute-value value ctx)
   (emit-char #\" ctx)
   (for-each (lambda (item)
-	      (if (string? item)
-		  (write-xml-string item ctx)
-		  (%write-xml item ctx)))
+	      (write-xml-string item ctx))
 	    value)
   (emit-char #\" ctx))
 
 (define (xml-attribute-columns attribute)
   (+ (xml-name-columns (car attribute))
-     1
-     (let loop ((items (cdr attribute)) (n 2))
-       (if (pair? items)
-	   (loop (cdr items)
-		 (+ n
-		    (if (string? (car items))
-			(xml-string-columns (car items))
-			(+ (xml-name-columns (xml-entity-ref-name (car items)))
-			   2))))
-	   n))))
+     3
+     (xml-string-columns (cadr attribute))))
 
 (define (write-xml-string string ctx)
   (write-escaped-string string
diff --git a/v7/src/xml/xml-parser.scm b/v7/src/xml/xml-parser.scm
index 1a93909cf..cdbe652ae 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.47 2003/09/26 04:27:32 cph Exp $
+$Id: xml-parser.scm,v 1.48 2003/09/26 05:35:40 cph Exp $
 
 Copyright 2001,2002,2003 Massachusetts Institute of Technology
 
@@ -176,8 +176,6 @@ USA.
   (xml-declaration-parser "XML text declaration" #t))
 
 (define (transform-declaration attributes text-decl? p)
-  (if (not (for-all? attributes xml-attribute-value))
-      (perror p "XML declaration can't contain entity refs" attributes))
   (let ((finish
 	 (lambda (version encoding standalone)
 	   (if (and (not text-decl?) (not version))
@@ -204,10 +202,10 @@ USA.
 	 (results '()))
       (if (pair? names)
 	  (if (pair? attributes)
-	      (if (eq? (caar attributes) (car names))
+	      (if (eq? (xml-attribute-name (car attributes)) (car names))
 		  (loop (cdr attributes)
 			(cdr names)
-			(cons (cadar attributes) results))
+			(cons (xml-attribute-value (car attributes)) results))
 		  (loop attributes
 			(cdr names)
 			(cons #f results)))
@@ -347,8 +345,7 @@ USA.
 		(perror (cdar attribute)
 			"Incorrect attribute value"
 			(string->symbol name)))
-	    (if (and (not (eq? type '|CDATA|))
-		     (xml-attribute-value attribute))
+	    (if (not (eq? type '|CDATA|))
 		(set-car! av (trim-attribute-whitespace (car av))))
 	    attributes)
 	  (begin
@@ -465,16 +462,14 @@ USA.
   (set! *prefix-bindings*
 	(let loop ((attributes attributes))
 	  (if (pair? attributes)
-	      (let ((name (caar attributes))
-		    (value (cdar attributes))
+	      (let ((name (xml-attribute-name (car attributes)))
 		    (tail (loop (cdr attributes))))
 		(let ((s (car name))
 		      (pn (cdr name)))
 		  (let ((iri
 			 (lambda ()
 			   (string->symbol
-			    (or (xml-attribute-value (car attributes))
-				(perror pn "Illegal namespace IRI" value)))))
+			    (xml-attribute-value (car attributes)))))
 			(forbidden-iri
 			 (lambda (iri)
 			   (perror pn "Forbidden namespace IRI" iri))))
@@ -626,9 +621,7 @@ USA.
 	(with-pointer p
 	  (transform
 	      (lambda (v)
-		(let ((name (vector-ref v 0)))
-		  (or (dereference-entity name #f p)
-		      (vector (make-xml-entity-ref name)))))
+		(dereference-entity (vector-ref v 0) #f p))
 	    parse-entity-reference-name)))))
 
 (define parse-reference-deferred
@@ -698,10 +691,10 @@ USA.
 	(a2 (alphabet- alphabet (string->alphabet "'"))))
     (*parser
      (encapsulate (lambda (v)
-		    (let ((elements (vector->list v)))
+		    (let ((elements (coalesce-strings! (vector->list v))))
 		      (if (null? elements)
 			  (list "")
-			  (coalesce-strings! elements))))
+			  elements)))
        (alt (sbracket "attribute value" "\"" "\""
 	      (* (alt (match (+ (alphabet a1)))
 		      parse-reference)))
@@ -732,62 +725,52 @@ USA.
 	 (attribute-value-parser alphabet:char-data
 				 parse-reference-deferred)))
     (*parser
-     (map normalize-attribute-value
+     (map (lambda (elements)
+	    (if (not (and (pair? elements)
+			  (string? (car elements))
+			  (null? (cdr elements))))
+		(error "Uncoalesced attribute value:" elements))
+	    (normalize-attribute-value (car elements)))
 	  (require-success "Malformed attribute value"
 	    parser)))))
 
 ;;;; Normalization
 
-(define (normalize-attribute-value elements)
+(define (normalize-attribute-value string)
   (coalesce-strings!
    (reverse!
-    (let loop ((elements elements) (result '()))
-      (if (pair? elements)
-	  (let ((element (car elements))
-		(elements (cdr elements)))
-	    (if (string? element)
-		(let ((buffer
-		       (string->parser-buffer
-			(normalize-line-endings element))))
-		  (let normalize-string
-		      ((port (open-output-string))
-		       (result result))
-		    (let* ((p (get-parser-buffer-pointer buffer))
-			   (char (read-parser-buffer-char buffer)))
-		      (case char
-			((#f)
-			 (loop elements
-			       (cons (get-output-string port) result)))
-			((#\tab #\newline #\return)
-			 (write-char #\space port)
-			 (normalize-string port result))
-			((#\&)
-			 (set-parser-buffer-pointer! buffer p)
-			 (let ((v (parse-char-reference buffer)))
-			   (if v
-			       (begin
-				 (write-string (vector-ref v 0) port)
-				 (normalize-string port result))
-			       (normalize-string
-				(open-output-string)
-				(let ((name
-				       (vector-ref
-					(parse-entity-reference-name buffer)
-					0))
-				      (result
-				       (cons (get-output-string port) result)))
-				  (let ((v (dereference-entity name #t p)))
-				    (if v
-					(expand-entity-value name p
-					  (lambda ()
-					    (loop v result)))
-					(cons (make-xml-entity-ref name)
-					      result))))))))
-			(else
-			 (write-char char port)
-			 (normalize-string port result))))))
-		(loop elements (cons element result))))
-	  result)))))
+    (let loop ((string string) (result '()))
+      (let ((buffer (string->parser-buffer (normalize-line-endings string))))
+	(let normalize-string ((port (open-output-string)) (result result))
+	  (let* ((p (get-parser-buffer-pointer buffer))
+		 (char (read-parser-buffer-char buffer)))
+	    (case char
+	      ((#f)
+	       (cons (get-output-string port) result))
+	      ((#\tab #\newline #\return)
+	       (write-char #\space port)
+	       (normalize-string port result))
+	      ((#\&)
+	       (set-parser-buffer-pointer! buffer p)
+	       (let ((v (parse-char-reference buffer)))
+		 (if v
+		     (begin
+		       (write-string (vector-ref v 0) port)
+		       (normalize-string port result))
+		     (normalize-string
+		      (open-output-string)
+		      (let ((name
+			     (vector-ref (parse-entity-reference-name buffer)
+					 0)))
+			(let ((value (dereference-entity name #t p)))
+			  (expand-entity-value name p
+			    (lambda ()
+			      (loop value
+				    (cons (get-output-string port)
+					  result))))))))))
+	      (else
+	       (write-char char port)
+	       (normalize-string port result))))))))))
 
 (define (trim-attribute-whitespace string)
   (call-with-output-string
@@ -896,31 +879,24 @@ USA.
 
 (define (dereference-entity name in-attribute? p)
   (if (eq? *general-entities* 'STOP)
-      #f
-      (begin
-	(if (assq name *entity-expansion-nesting*)
-	    (perror p "Circular entity reference" name))
-	(let ((entity (find-entity name)))
-	  (if entity
-	      (begin
-		(if (xml-unparsed-!entity? entity)
-		    (perror p "Reference to unparsed entity" name))
-		(let ((value (xml-!entity-value entity)))
-		  (cond ((xml-external-id? value) #f)
-			(in-attribute? value)
-			((and (pair? value)
-			      (string? (car value))
-			      (null? (cdr value)))
-			 (reparse-entity-value-string name (car value) p))
-			(else
-			 (if (or *standalone?* *internal-dtd?*)
-			     (perror p "Reference to partially-defined entity"
-				     name))
-			 #f))))
-	      (begin
-		(if (or *standalone?* *internal-dtd?*)
-		    (perror p "Reference to undefined entity" name))
-		#f))))))
+      (perror p "Reference to externally-defined entity" name))
+  (if (assq name *entity-expansion-nesting*)
+      (perror p "Circular entity reference" name))
+  (let ((entity (find-entity name)))
+    (if (not entity)
+	(perror p "Reference to undefined entity" name))
+    (if (xml-unparsed-!entity? entity)
+	(perror p "Reference to unparsed entity" name))
+    (let ((value (xml-!entity-value entity)))
+      (if (xml-external-id? value)
+	  (perror p "Reference to external entity" name))
+      (if (not (and (pair? value)
+		    (string? (car value))
+		    (null? (cdr value))))
+	  (perror p "Reference to partially-defined entity" name))
+      (if in-attribute?
+	  (car value)
+	  (reparse-entity-value-string name (car value) p)))))
 
 (define (reparse-entity-value-string name string p)
   (let ((v
@@ -1099,14 +1075,11 @@ USA.
 			(type (vector-ref v 1))
 			(default (vector-ref v 2)))
 		    (list name type
-			  (let ((dv
-				 (and (not (eq? type '|CDATA|))
-				      (pair? default)
-				      (xml-attribute-value default))))
-			    (if dv
-				(list (car default)
-				      (trim-attribute-whitespace dv))
-				default)))))
+			  (if (and (not (eq? type '|CDATA|))
+				   (pair? default))
+			      (list (car default)
+				    (trim-attribute-whitespace (cadr default)))
+			      default))))
 	      (seq S
 		   parse-attribute-name
 		   S
diff --git a/v7/src/xml/xml-struct.scm b/v7/src/xml/xml-struct.scm
index ea860bf99..3d1d1d864 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.35 2003/09/26 03:56:58 cph Exp $
+$Id: xml-struct.scm,v 1.36 2003/09/26 05:35:43 cph Exp $
 
 Copyright 2001,2002,2003 Massachusetts Institute of Technology
 
@@ -162,8 +162,7 @@ USA.
        (list-of-type? object xml-attribute-value-item?)))
 
 (define (xml-attribute-value-item? object)
-  (or (xml-char-data? object)
-      (xml-entity-ref? object)))
+  (xml-char-data? object))
 
 (define (xml-content? object)
   (list-of-type? object xml-content-item?))
@@ -172,8 +171,7 @@ USA.
   (or (xml-char-data? object)
       (xml-comment? object)
       (xml-element? object)
-      (xml-processing-instructions? object)
-      (xml-entity-ref? object)))
+      (xml-processing-instructions? object)))
 
 (define-xml-type comment
   (text xml-char-data? canonicalize-char-data))
@@ -196,6 +194,12 @@ USA.
 	       (canonicalize-attribute-value (cdr a))))
        attributes))
 
+(define (xml-attribute-name attr)
+  (car attr))
+
+(define (xml-attribute-value attr)
+  (cadr attr))
+
 (define (canonicalize-attribute-value v)
   (canonicalize-content v))
 
@@ -418,27 +422,10 @@ USA.
     (or (xml-external-id-id dtd)
 	(xml-external-id-iri dtd))))
 
-(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-xml-attribute-value object
-				       (if (default-object? caller)
-					   #f
-					   caller)))
-    v))
-
-(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)))
+  (let ((name (xml-attribute-name attr)))
+    (or (xml-name=? name 'xmlns)
+	(xml-name-prefix=? name 'xmlns))))
 
 (define (xml-element-namespace-decls elt)
   (keep-matching-items (xml-element-attributes elt)
@@ -447,14 +434,14 @@ USA.
 (define (xml-element-namespace-iri elt prefix)
   (let ((attr
 	 (find-matching-item (xml-element-attributes elt)
-	   (if (null-xml-name-prefix? prefix)
-	       (lambda (attr)
-		 (xml-name=? (car attr) 'xmlns))
-	       (lambda (attr)
-		 (and (xml-name-prefix=? (car attr) 'xmlns)
-		      (xml-name-local=? (car attr) prefix)))))))
+	   (let ((qname
+		  (if (null-xml-name-prefix? prefix)
+		      'xmlns
+		      (symbol-append 'xmlns: prefix))))
+	     (lambda (attr)
+	       (xml-name=? (xml-attribute-name attr) qname))))))
     (and attr
-	 (make-xml-namespace-iri (guarantee-xml-attribute-value attr)))))
+	 (make-xml-namespace-iri (cadr attr)))))
 
 (define (xml-element-namespace-prefix elt iri)
   (let ((iri (xml-namespace-iri-string iri)))
@@ -462,8 +449,9 @@ USA.
 	   (find-matching-item (xml-element-attributes elt)
 	     (lambda (attr)
 	       (and (xml-attribute-namespace-decl? attr)
-		    (string=? (guarantee-xml-attribute-value attr) iri))))))
+		    (string=? (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
+	   (let ((name (xml-attribute-name attr)))
+	     (if (xml-name=? name 'xmlns)
+		 (null-xml-name-prefix)
+		 (xml-name-local name)))))))
\ No newline at end of file
diff --git a/v7/src/xml/xml.pkg b/v7/src/xml/xml.pkg
index 088f3fb4d..b2564a2bc 100644
--- a/v7/src/xml/xml.pkg
+++ b/v7/src/xml/xml.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml.pkg,v 1.33 2003/09/26 03:56:45 cph Exp $
+$Id: xml.pkg,v 1.34 2003/09/26 05:35:33 cph Exp $
 
 Copyright 2001,2002,2003 Massachusetts Institute of Technology
 
@@ -100,7 +100,6 @@ USA.
 	  <xml-parameter-entity-ref>
 	  <xml-processing-instructions>
 	  <xml-unparsed-!entity>
-	  error:not-xml-attribute-value
 	  error:not-xml-!attlist
 	  error:not-xml-!element
 	  error:not-xml-!entity
@@ -120,7 +119,6 @@ USA.
 	  guarantee-xml-!element
 	  guarantee-xml-!entity
 	  guarantee-xml-!notation
-	  guarantee-xml-attribute-value
 	  guarantee-xml-comment
 	  guarantee-xml-declaration
 	  guarantee-xml-document
@@ -195,6 +193,7 @@ USA.
 	  xml-!notation-name
 	  xml-!notation?
 	  xml-attribute-list?
+	  xml-attribute-name
 	  xml-attribute-namespace-decl?
 	  xml-attribute-value
 	  xml-attribute-value-item?