Adding support for cdata and exporting correct-xexpr?

svn: r374

collects/xml/doc.txt

@@ -106,6 +106,13 @@ Functions
        "something-else" set to what it was really given; and the code set to
        the part of the non-Xexpr that caused the exception.
 
+> correct-xexpr? : any (-> a) (exn -> a) -> a
+       If the given thing is an Xexpr, produce an a. Otherwise call the
+       second function with an exn:invalid-xexpr. This second function
+       may inspect this structure and decide to return a "correct" value.
+       This is a method of extending the definition of an Xexpr and is used
+       by the web-server's Xexpr/callbacks. (See for an example.)
+
 Parameters
 ==========
 
@@ -182,6 +189,7 @@ Note: Xexpr is the only important one to understand.  Even then,
         |  (cons Symbol (listof Xexpr)) ;; an element with no attributes
         |  Symbol ;; symbolic entities such as  
         |  Number ;; numeric entities like 
+        |  Cdata
         |  Misc
 
 > Document = (make-document Prolog Element (listof Processing-instruction))
@@ -222,6 +230,12 @@ Note: Xexpr is the only important one to understand.  Even then,
 > Pcdata = (make-pcdata Location Location String)
   (define-struct (pcdata struct:source) (string))
 
+> Cdata = (make-cdata Location Location String)
+  (define-struct (cdata struct:source) (string))
+  Note: The string of a cdata structure is assumed to be of the form
+        "<![CDATA[~a]]>" with proper quoting. If this is an incorrect 
+        assumption, this library will generate invalid XML.
+
 > Entity = (make-entity (U Nat Symbol))
   (define-struct entity (text))
 

collects/xml/private/reader.ss

@@ -189,7 +189,7 @@
                              (lex-error in pos "expected ; at the end of an entity")))])])
             (make-entity start (pos) data))))
       
-      ; lex-tag-cdata-pi-comment : Input-port (-> Location) -> Start-tag | Element | End-tag | Pcdata | Pi | Comment
+      ; lex-tag-cdata-pi-comment : Input-port (-> Location) -> Start-tag | Element | End-tag | Cdata | Pi | Comment
       ; pre: the first char is a #\<
       (define (lex-tag-cdata-pi-comment in pos)
         (let ([start (pos)])
@@ -210,7 +210,7 @@
                 (unless (string=? (read-string 6 in) "CDATA[")
                   (lex-error in pos "expected CDATA following <["))
                 (let ([data (lex-cdata-contents in pos)])
-                  (make-pcdata start (pos) data))]
+                  (make-cdata start (pos) (format "<![CDATA[~a]]>" data)))]
                [else (skip-dtd in pos)
                      (skip-space in)
                      (unless (eq? (peek-char-or-special in) #\<)

collects/xml/private/sig.ss

@@ -16,6 +16,7 @@
      (struct pi (target-name instruction))
      (struct source (start stop))
      (struct pcdata (string))
+     (struct cdata (string))
      (struct entity (text))
      content?))
 
@@ -40,6 +41,7 @@
       xexpr->string
       xexpr-drop-empty-attributes
       xexpr?
+      correct-xexpr?
       validate-xexpr
       (struct exn:invalid-xexpr (code))
       xexpr-attribute?

collects/xml/private/structures.ss

@@ -59,10 +59,14 @@
       ; Pcdata = (make-pcdata Location Location String)
       (define-struct (pcdata source) (string))
       
+      ; Cdata = (make-cdata Location Location String)
+      (define-struct (cdata source) (string))
+      
       ; Content = Pcdata  
       ;         |  Element
       ;         |  Entity
       ;         |  Misc
+      ;         |  Cdata
       
       ; Misc = Comment
       ;      |  Processing-instruction

collects/xml/private/syntax.ss

@@ -55,6 +55,10 @@
       (define (make-pcdata from to x)
         (wrap x from to))
       
+      ; make-cdata : src src str -> cdata
+      (define (make-cdata from to x)
+        (wrap x from to))
+      
       ; make-entity : src src (U sym num) -> entity
       (define (make-entity from to entity)
         (wrap entity from to))
@@ -98,6 +102,7 @@
       (define (entity-text e) (syntax-e e))
       
       (define (pcdata-string x) (syntax-e x))
+      (define (cdata-string x) (syntax-e x))
       
       (define (comment-text c)
         (error 'comment-text "expected a syntax representation of an XML comment, received ~a" c))
@@ -182,6 +187,8 @@
       ; : tst -> bool
       (define (pcdata? x)
         (and (syntax? x) (string (syntax-e x))))
+      (define (cdata? x)
+        (and (syntax? x) (string (syntax-e x))))
       
       ; : tst -> bool
       (define (entity? x)
@@ -200,6 +207,7 @@
       (struct! pi (target-name instruction))
       ;(struct! source (start stop))
       (struct! pcdata (string))
+      (struct! cdata (string))
       (struct! entity (text))
       
       )))

collects/xml/private/writer.ss

@@ -87,6 +87,7 @@
 	((cond
            [(element? el) write-xml-element]
            [(pcdata? el) write-xml-pcdata]
+           [(cdata? el) write-xml-cdata]
            [(entity? el) write-xml-entity]
            [(comment? el) write-xml-comment]
            [(pi? el) write-xml-pi]
@@ -130,6 +131,11 @@
       ;; write-xml-pcdata : Pcdata Nat (Nat Output-Stream -> Void) Output-Stream -> Void
       (define (write-xml-pcdata str over dent out)
 	(write-xml-base (escape (pcdata-string str) escape-table) over dent out))
+
+      ;; write-xml-cdata : Cdata Nat (Nat Output-Stream -> Void) Output-Stream -> Void
+      (define (write-xml-cdata cdata over dent out)
+        ;; XXX: Different kind of quote is needed, for assume the user includes the <![CDATA[...]]> with proper quoting
+        (write-xml-base (format "~a" (cdata-string cdata)) over dent out))
       
       ;; write-xml-pi : Processing-instruction Nat (Nat Output-Stream -> Void) Output-Stream -> Void
       (define (write-xml-pi pi over dent out)

collects/xml/private/xexpr.ss

@@ -18,6 +18,7 @@
       ;;        |  Nat
       ;;        |  Comment
       ;;        |  Processing-instruction
+      ;;        |  Cdata
       ;; Attribute-srep ::= (list Symbol String)
       
       ;; sorting is no longer necessary, since xt3d uses xml->zxexpr, which sorts.
@@ -58,6 +59,7 @@
           ((number? x) (true))
           ((comment? x) (true))
           ((pi? x) (true))
+          ((cdata? x) (true))
           ((list? x)
            (or (null? x)
                (if (symbol? (car x))
@@ -172,7 +174,7 @@
                 (cons (element-name x) (combine atts body)))]
               [(pcdata? x) (pcdata-string x)]
               [(entity? x) (entity-text x)]
-              [(or (comment? x) (pi? x)) x]
+              [(or (comment? x) (pi? x) (cdata? x)) x]
               [(document? x) (error 'xml->xexpr "Expected content, given ~e~nUse document-element to extract the content." x)]
               [else ;(error 'xml->xexpr "Expected content, given ~e" x)
               x]))))
@@ -208,7 +210,7 @@
           [(string? x) (make-pcdata 'scheme 'scheme x)]
           [(or (symbol? x) (and (integer? x) (>= x 0)))
           (make-entity 'scheme 'scheme x)]
-          [(or (comment? x) (pi? x)) x]
+          [(or (comment? x) (pi? x) (cdata? x)) x]
           [else ;(error 'xexpr->xml "malformed xexpr ~s" x)
           x]))