Re: Robby

svn: r12915

collects/stepper/private/xml-snip-helpers.ss

@@ -53,7 +53,7 @@
          (let* ([source-name (get-source-name editor)]
                 [port (open-input-text-editor editor 0 'end (xml-snip-filter editor) source-name)]
                 [xml (read-xml port)]
-                [xexpr (xml->xexpr (document-element xml))]
+                [xexpr (parameterize ([permissive? #t]) (xml->xexpr (document-element xml)))]
                 [clean-xexpr (if eliminate-whitespace-in-empty-tags?
                                  (eliminate-whitespace-in-empty-tags xexpr)
                                  xexpr)]

collects/xml/private/sig.ss

@@ -41,6 +41,7 @@
       xexpr->string
       xexpr-drop-empty-attributes
       xexpr?
+      permissive?
       correct-xexpr?
       validate-xexpr
       (struct exn:invalid-xexpr (code))

collects/xml/private/xexpr.ss

@@ -146,6 +146,9 @@
              (pair? (cdr b))
              (string? (cadr b))
              (null? (cddr b))))
+      
+      ; permissive? : parameter bool
+      (define permissive? (make-parameter #f))
 
       ;; xml->xexpr : Content -> Xexpr
       (define (xml->xexpr x)
@@ -169,6 +172,7 @@
               [(entity? x) (entity-text 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)]
+              [(permissive?) x]
               [else (error 'xml->xexpr "Expected content, given ~e" x)]))))
 
       ;; attribute->srep : Attribute -> Attribute-srep

collects/xml/test.ss

@@ -3,13 +3,13 @@
 
 (module test mzscheme
   (require xml/xml)
-
-
+  
+  
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;;
   ;; utils
   ;;
-
+  
   ;; test-bad-read-input : format-str str -> void
   ;; First argument is the input, second is the error message
   (define (test-bad-read-input format-str err-string)
@@ -20,11 +20,11 @@
                            (report-err format-str (exn-message x) err-string)))])
         (read-xml (open-input-string str))
         (report-err str "no error" err-string))))
-
+  
   ;; tests-failed : number
   ;; incremened for each test that fails
   (define tests-failed 0)
-
+  
   ;; report-err : string string string -> void
   ;; reports an error in the test suite
   ;; increments tests-failed.
@@ -32,7 +32,7 @@
     (set! tests-failed (+ tests-failed 1))
     (printf "FAILED     test: ~a~n            got: ~a~n       expected: ~a~n"
             test got expected))
-
+  
   ;; done : -> void
   ;; prints out a message saying the tests are done.
   ;; if any tests failed, prints a message saying how many
@@ -40,13 +40,13 @@
     (if (= tests-failed 0)
         (printf "All tests passed~n")
         (printf "~a tests failed~n" tests-failed)))
-
-
+  
+  
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;;
   ;; reader error tests
   ;;
-
+  
   (test-bad-read-input "<" "read-xml: lex-error: at position 1.1/2: unexpected eof")
   (test-bad-read-input "<a>" "read-xml: parse-error: unclosed `a' tag at [1.0/1 1.3/4]")
   (test-bad-read-input
@@ -54,7 +54,7 @@
    "read-xml: parse-error: start tag `a' at [1.0/1 1.3/4] doesn't match end tag `b' at [1.3/4 1.7/8]")
   (test-bad-read-input
    "<a <a>" "read-xml: lex-error: at position 1.4/5: expected / or > to close tag `a'")
-
+  
   (test-bad-read-input "~n<" "read-xml: lex-error: at position 2.1/3: unexpected eof")
   (test-bad-read-input "~n<a>" "read-xml: parse-error: unclosed `a' tag at [2.0/2 2.3/5]")
   (test-bad-read-input
@@ -62,8 +62,21 @@
    "read-xml: parse-error: start tag `a' at [2.0/2 2.3/5] doesn't match end tag `b' at [2.3/5 2.7/9]")
   (test-bad-read-input
    "~n<a <a>" "read-xml: lex-error: at position 2.4/6: expected / or > to close tag `a'")
-
-
+  
+  ;; permissive?
+  (with-handlers ([exn?
+                   (lambda (exn)
+                     (regexp-match #rx"Expected content," (exn-message exn)))])    
+    (report-err "Non-permissive" (xml->xexpr #f) "Exception"))
+  
+  (with-handlers ([exn?
+                   (lambda (exn)
+                     (report-err "Permissive" "Exception" "#f"))])
+    (parameterize ([permissive? #t])
+      (let ([tmp (xml->xexpr #f)])
+        (when tmp
+          (report-err "Permissive" tmp "#f")))))
+  
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;;
   ;; done

collects/xml/xml.scrbl

@@ -235,9 +235,16 @@ like @scheme[display-xml].}
 
 @section{XML and X-expression Conversions}
 
+@defboolparam[permissive? v]{
+ If this is set to non-false, then @scheme[xml->xexpr] will allow
+ non-XML objects, such as other structs, in the content of the converted XML
+ and leave them in place in the resulting ``@tech{X-expression}''.
+}
+                             
 @defproc[(xml->xexpr [content content?]) xexpr?]{
 
-Converts document content into an @tech{X-expression}.}
+Converts document content into an @tech{X-expression}, using
+@scheme[permissive?] to determine if foreign objects are allowed.}
 
 @defproc[(xexpr->xml [xexpr xexpr?]) content?]{