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 979c4b35a8d8890257315bffe35435e89cb3ad79..76a1458009013936a26de70baf77575d7cd26f7e 100644 (file)
--- 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 1a93909cfab2f8de841d66f3ddb42ecd795267fb..cdbe652ae43ba275158fa47a9408105973453a1b 100644 (file)
--- 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)))))
 \f
 ;;;; 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 ea860bf99de34af48671f6e908846127d9e869ca..3d1d1d8640271f0585d0816a8a63afe193c40c89 100644 (file)
--- 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))))
 \f
-(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 088f3fb4d43b5da558a0c4d1c298f8196e47b1d3..b2564a2bccc717324900080a0b4f38d8ba78bb2e 100644 (file)
--- 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?